From 4cbea925e49b885a8e7b63aa300cc13402f28a52 Mon Sep 17 00:00:00 2001 From: wx20hw Date: Sun, 30 Jan 2022 05:10:14 +0000 Subject: [PATCH 01/35] set up option for thermal roughness --- physics/module_sf_noahmp_glacier.f90 | 24 +++++++--- physics/module_sf_noahmplsm.f90 | 66 ++++++++++++++++++++++++++-- physics/noahmp_tables.f90 | 2 +- physics/sfc_noahmp_drv.F90 | 10 +++-- physics/sfc_noahmp_drv.meta | 7 +++ 5 files changed, 96 insertions(+), 13 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index 4c3a53c88..26dd810c7 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -62,6 +62,7 @@ module noahmp_glacier_globals INTEGER :: OPT_GLA != 1 !(suggested 1) INTEGER :: OPT_SFC != 1 !(suggested 1) + INTEGER :: OPT_TRS != 1 !(suggested 2) ! adjustable parameters for snow processes @@ -1129,8 +1130,10 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso real (kind=kind_phys) :: b !< temporary calculation real (kind=kind_phys) :: t, tdc !< kelvin to degree celsius with limit -50 to +50 real (kind=kind_phys), dimension( 1:nsoil) :: sice !< soil ice + real (kind=kind_phys) :: czil !< calculate roughness length of heat tdc(t) = min( 50., max(-50.,(t-tfrz)) ) + czil=0.5 ! ----------------------------------------------------------------- ! initialization variables that do not depend on stability iteration @@ -1155,10 +1158,18 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso fv = ur*vkc/log(zlvli/z0m) reyni = fv*z0m/(1.5e-05) !introduction of fv dependent z0h for the iter - if (reyni .gt. 2.0) then - z0h = z0m/exp(2.46*(reyni)**0.25 - log(7.4)) !Brutsaert 1982 - else - z0h = z0m/exp(-log(0.397)) !Brusaert 1982, table 4 + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + z0h = z0m*exp(-czil*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + z0h = z0m*0.0001 + elseif (opt_trs == 4) then + if (reyni .gt. 2.0) then + z0h = z0m/exp(2.46*(reyni)**0.25 - log(7.4)) !Brutsaert 1982 + else + z0h = z0m/exp(-log(0.397)) !Brusaert 1982, table 4 + endif endif z0h_total = z0h @@ -3328,7 +3339,8 @@ end subroutine error_glacier ! ================================================================================================== !>\ingroup NoahMP_LSM - subroutine noahmp_options_glacier(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iopt_gla, iopt_sfc) + subroutine noahmp_options_glacier(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iopt_gla,& + iopt_sfc, iopt_trs) implicit none @@ -3339,6 +3351,7 @@ subroutine noahmp_options_glacier(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iop !! 1 -> semi-implicit; 2 -> full implicit (original noah) integer, intent(in) :: iopt_gla !< glacier option (1->phase change; 2->simple) integer, intent(in) :: iopt_sfc !< sfc scheme option + integer, intent(in) :: iopt_trs !< thermal roughness option ! ------------------------------------------------------------------------------------------------- @@ -3348,6 +3361,7 @@ subroutine noahmp_options_glacier(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iop opt_stc = iopt_stc opt_gla = iopt_gla opt_sfc = iopt_sfc + opt_trs = iopt_trs end subroutine noahmp_options_glacier diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 944446085..b602a683e 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -159,6 +159,11 @@ module module_sf_noahmplsm ! **0 -> no crop model, will run default dynamic vegetation ! 1 -> liu, et al. 2016 + integer :: opt_trs !< options for thermal roughness scheme + ! **1 -> z0h=z0 + ! 2 -> czil + ! 3 -> ec style + ! 4 -> kb inversed !------------------------------------------------------------------------------------------! ! physical constants: ! !------------------------------------------------------------------------------------------! @@ -2241,6 +2246,21 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc q2e = fveg * q2v + (1.0 - fveg) * q2b + if (opt_trs == 1) then + z0wrf = fveg * z0m + (1.0 - fveg) * z0mg + z0hwrf = z0wrf + elseif (opt_trs == 2) then + z0wrf = fveg * z0m + (1.0 - fveg) * z0mg + z0hwrf = fveg * z0m*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0m)) & + +(1.0 - fveg) * z0mg*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0mg)) + elseif (opt_trs == 3) then + z0wrf = fveg * z0m + (1.0 - fveg) * z0mg + if (vegtyp.le.5) then + z0hwrf = fveg * z0m + (1.0 - fveg) * z0mg*0.1 + else + z0hwrf = fveg * z0m*0.01 + (1.0 - fveg) * z0mg*0.1 + endif + elseif (opt_trs == 4) then coeffa = (csigmaf0 - csigmaf1)/(1.0 - exp(-1.0*aone)) coeffb = csigmaf0 - coeffa csigmafveg = coeffa * exp(-1.0*aone*fveg) + coeffb @@ -2259,6 +2279,9 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in kbsigmafveg = csigmafveg/log((zlvl-ezpd)/z0wrf) - log((zlvl-ezpd)/z0wrf) z0hwrf = z0wrf/exp(kbsigmafveg) +! place holder doe other roughness scheme +! elseif (opt_trs == x) then + endif else taux = tauxb @@ -2283,7 +2306,19 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in chv = chb z0wrf = z0mg + if (opt_trs == 1) then + z0hwrf = z0wrf + elseif (opt_trs == 2) then + z0hwrf = z0wrf*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0wrf)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0hwrf = z0wrf + else + z0hwrf = z0wrf*0.01 + endif + elseif (opt_trs == 4) then z0hwrf =z0wrf/exp( csigmaf0/log((zlvl-ezpd)/z0wrf) - log((zlvl-ezpd)/z0wrf) ) + endif end if @@ -3965,11 +4000,22 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & cir = (2.-emv*(1.-emg))*emv*sb ! --------------------------------------------------------------------------------------------- + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0h = z0m + else + z0h = z0m*0.01 + endif + elseif (opt_trs == 4) then sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) kbsigmaf1 = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) z0h = z0m/exp(kbsigmaf1) csigmaf1 = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m)+kbsigmaf1) ! for output for interpolation - + endif ! -- tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) @@ -4582,7 +4628,19 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & csigmaf0 = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m) + kbsigmaf0) - z0h = max(z0m/exp(kbsigmaf0),1.0e-6) + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0h = z0m + else + z0h = z0m*0.01 + endif + elseif (opt_trs == 4) then + z0h = max(z0m/exp(kbsigmaf0),1.0e-6) + endif ! ! for sfcdiff3; maybe should move to inside the option ! @@ -9782,7 +9840,7 @@ end subroutine psn_crop !>\ingroup NoahMP_LSM subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, & - iopt_rsf , iopt_soil, iopt_pedo, iopt_crop ) + iopt_rsf , iopt_soil, iopt_pedo, iopt_crop ,iopt_trs ) implicit none @@ -9804,6 +9862,7 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc integer, intent(in) :: iopt_soil !soil parameters set-up option integer, intent(in) :: iopt_pedo !pedo-transfer function (1->saxton and rawls) integer, intent(in) :: iopt_crop !crop model option (0->none; 1->liu et al.) + integer, intent(in) :: iopt_trs !thermal roughness scheme option (1->z0h=z0; 2->rb reversed) ! ------------------------------------------------------------------------------------------------- @@ -9824,6 +9883,7 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc opt_soil = iopt_soil opt_pedo = iopt_pedo opt_crop = iopt_crop + opt_trs = iopt_trs end subroutine noahmp_options diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 9cb25b3f3..5f6246a0f 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -735,7 +735,7 @@ module noahmp_tables real :: refkdt_table = 3.0 !< parameter in the surface runoff parameterization real :: frzk_table =0.15 !< frozen ground parameter real :: zbot_table = -8.0 !< depth [m] of lower boundary soil temperature - real :: czil_table = 0.1 !< parameter used in the calculation of the roughness length for heat + real :: czil_table = 0.5 !< parameter used in the calculation of the roughness length for heat ! mptable.tbl radiation parameters diff --git a/physics/sfc_noahmp_drv.F90 b/physics/sfc_noahmp_drv.F90 index 1fd9773ff..397a09674 100644 --- a/physics/sfc_noahmp_drv.F90 +++ b/physics/sfc_noahmp_drv.F90 @@ -111,7 +111,7 @@ subroutine noahmpdrv_run & shdmin, shdmax, snoalb, sfalb, flag_iter,con_g, & idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & - iopt_stc, xlatin, xcoszin, iyrlen, julian, garea, & + iopt_stc, iopt_trs,xlatin, xcoszin, iyrlen, julian, garea, & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, & con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & con_fvirt, con_rd, con_hfus, thsfc_loc, & @@ -213,6 +213,7 @@ subroutine noahmpdrv_run & integer , intent(in) :: iopt_snf ! option for partitioning precipitation into rainfall & snowfall integer , intent(in) :: iopt_tbot ! option for lower boundary condition of soil temperature integer , intent(in) :: iopt_stc ! option for snow/soil temperature time scheme (only layer 1) + integer , intent(in) :: iopt_trs ! option for thermal roughness scheme real(kind=kind_phys), dimension(:) , intent(in) :: xlatin ! latitude real(kind=kind_phys), dimension(:) , intent(in) :: xcoszin ! cosine of zenith angle integer , intent(in) :: iyrlen ! year length [days] @@ -700,8 +701,8 @@ subroutine noahmpdrv_run & call noahmp_options(idveg ,iopt_crs, iopt_btr , iopt_run, iopt_sfc, & iopt_frz, iopt_inf , iopt_rad, iopt_alb, & - iopt_snf, iopt_tbot, iopt_stc, & - iopt_rsf, iopt_soil, iopt_pedo, iopt_crop ) + iopt_snf, iopt_tbot, iopt_stc, iopt_rsf, & + iopt_soil,iopt_pedo, iopt_crop,iopt_trs ) if ( vegetation_category == isice_table ) then @@ -714,7 +715,8 @@ subroutine noahmpdrv_run & ice_flag = -1 temperature_soil_bot = min(temperature_soil_bot,263.15) - call noahmp_options_glacier(iopt_alb, iopt_snf, iopt_tbot, iopt_stc, iopt_gla, iopt_sfc ) + call noahmp_options_glacier(iopt_alb, iopt_snf, iopt_tbot, iopt_stc, iopt_gla, & + iopt_sfc ,iopt_trs) call noahmp_glacier ( & i_location ,1 ,cosine_zenith ,nsnow , & diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index e37036c32..712a457a6 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -424,6 +424,13 @@ dimensions = () type = integer intent = in +[iopt_trs] + standard_name = control_for_land_surface_scheme_surface_thermal_roughness + long_name = choice for surface thermal roughness option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in [xlatin] standard_name = latitude long_name = latitude From 22de66b8306b687585c5521367ab1a706e04209d Mon Sep 17 00:00:00 2001 From: wx20hw Date: Mon, 31 Jan 2022 17:08:50 +0000 Subject: [PATCH 02/35] change czil --- physics/module_sf_noahmp_glacier.f90 | 4 ++-- physics/noahmp_tables.f90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index 26dd810c7..c4c03aaf8 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -1133,7 +1133,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso real (kind=kind_phys) :: czil !< calculate roughness length of heat tdc(t) = min( 50., max(-50.,(t-tfrz)) ) - czil=0.5 + czil=0.1 ! ----------------------------------------------------------------- ! initialization variables that do not depend on stability iteration @@ -1163,7 +1163,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso elseif (opt_trs == 2) then z0h = z0m*exp(-czil*0.4*258.2*sqrt(fv*z0m)) elseif (opt_trs == 3) then - z0h = z0m*0.0001 + z0h = z0m*0.1 elseif (opt_trs == 4) then if (reyni .gt. 2.0) then z0h = z0m/exp(2.46*(reyni)**0.25 - log(7.4)) !Brutsaert 1982 diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 5f6246a0f..9cb25b3f3 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -735,7 +735,7 @@ module noahmp_tables real :: refkdt_table = 3.0 !< parameter in the surface runoff parameterization real :: frzk_table =0.15 !< frozen ground parameter real :: zbot_table = -8.0 !< depth [m] of lower boundary soil temperature - real :: czil_table = 0.5 !< parameter used in the calculation of the roughness length for heat + real :: czil_table = 0.1 !< parameter used in the calculation of the roughness length for heat ! mptable.tbl radiation parameters From 10fa17e895ecd21db0d24d1cef7b12523cabce40 Mon Sep 17 00:00:00 2001 From: wx20hw Date: Wed, 16 Feb 2022 20:03:11 +0000 Subject: [PATCH 03/35] canopy height dependant czil --- physics/module_sf_noahmplsm.f90 | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index b602a683e..0fc4e8948 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -1895,6 +1895,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) :: csigmaf0 real (kind=kind_phys) :: csigmaf1 real (kind=kind_phys) :: csigmafveg + real (kind=kind_phys) :: czil1 real (kind=kind_phys) :: cdmnv real (kind=kind_phys) :: ezpdv @@ -2251,8 +2252,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in z0hwrf = z0wrf elseif (opt_trs == 2) then z0wrf = fveg * z0m + (1.0 - fveg) * z0mg - z0hwrf = fveg * z0m*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0m)) & - +(1.0 - fveg) * z0mg*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0mg)) +! z0hwrf = fveg * z0m*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0m)) & +! +(1.0 - fveg) * z0mg*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0mg)) + czil1=10.0 ** (- (0.40/0.07) * parameters%hvt) + z0hwrf = fveg * z0m*exp(-czil1*0.4*258.2*sqrt(ustarx*z0m)) & + +(1.0 - fveg) * z0mg*exp(-czil1*0.4*258.2*sqrt(ustarx*z0mg)) elseif (opt_trs == 3) then z0wrf = fveg * z0m + (1.0 - fveg) * z0mg if (vegtyp.le.5) then @@ -2309,7 +2313,9 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in if (opt_trs == 1) then z0hwrf = z0wrf elseif (opt_trs == 2) then - z0hwrf = z0wrf*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0wrf)) +! z0hwrf = z0wrf*exp(-parameters%czil*0.4*258.2*sqrt(ustarx*z0wrf)) + czil1=10.0 ** (- (0.40/0.07) * parameters%hvt) + z0hwrf = z0wrf*exp(-czil1*0.4*258.2*sqrt(ustarx*z0wrf)) elseif (opt_trs == 3) then if (vegtyp.le.5) then z0hwrf = z0wrf @@ -3866,7 +3872,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: laisune !sunlit leaf area index, one-sided (m2/m2),effective real (kind=kind_phys) :: laishae !shaded leaf area index, one-sided (m2/m2),effective - real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx + real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx,czil1 real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 integer :: k !index @@ -4003,7 +4009,9 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if (opt_trs == 1) then z0h = z0m elseif (opt_trs == 2) then - z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) +! z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) + czil1= 10.0 ** (- (0.40/0.07) * hcan) + z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) elseif (opt_trs == 3) then if (vegtyp.le.5) then z0h = z0m @@ -4581,7 +4589,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: fh2 !monin-obukhov heat adjustment at 2m real (kind=kind_phys) :: ch2 !surface exchange at 2m - real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx + real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx,czil1 real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 integer :: iter !iteration index @@ -4631,7 +4639,9 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if (opt_trs == 1) then z0h = z0m elseif (opt_trs == 2) then - z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) +! z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) + czil1= 10.0 ** (- (0.40/0.07) * parameters%hvt) + z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) elseif (opt_trs == 3) then if (vegtyp.le.5) then z0h = z0m From b90d4e2c7b2770295406d5344806fb52c1c1d41b Mon Sep 17 00:00:00 2001 From: helin wei Date: Mon, 7 Mar 2022 16:08:57 +0000 Subject: [PATCH 04/35] add canopy heat storage and gvf impact on thermal conductivity --- physics/module_sf_noahmp_glacier.f90 | 3 +- physics/module_sf_noahmplsm.f90 | 88 ++++++++++++++++++---------- physics/sfc_diag_post.F90 | 12 +++- physics/sfc_diag_post.meta | 16 +++++ physics/sfc_noahmp_drv.F90 | 4 +- 5 files changed, 88 insertions(+), 35 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index c4c03aaf8..1ea4a45b8 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -1152,7 +1152,8 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ! the following only applies to opt_sfc =3, opt_sfc = 1 still done its old way snwd = snowh*1000.0 - zlvli = zlvl - zpd +! zlvli = zlvl - zpd + zlvli = zlvl ! fv = ustarx ! the input maybe too high for glacial fv = ur*vkc/log(zlvli/z0m) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 0fc4e8948..0913531f8 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -678,18 +678,21 @@ subroutine noahmp_sflx (parameters, & real (kind=kind_phys) :: latheag !< latent heat vap./sublimation (j/kg) logical :: frozen_ground !< used to define latent heat pathway logical :: frozen_canopy !< used to define latent heat pathway - LOGICAL :: dveg_active !< flag to run dynamic vegetation - LOGICAL :: crop_active !< flag to run crop model + logical :: dveg_active !< flag to run dynamic vegetation + logical :: crop_active !< flag to run crop model +! add canopy heat storage (C.He added based on GY Niu's communication) + real :: canhs ! canopy heat storage change w/m2 ! intent (out) variables need to be assigned a value. these normally get assigned values ! only if dveg == 2. nee = 0.0 npp = 0.0 gpp = 0.0 - pahv = 0. - pahg = 0. - pahb = 0. - pah = 0. + pahv = 0. + pahg = 0. + pahb = 0. + pah = 0. + canhs = 0. ! -------------------------------------------------------------------------------------------------- ! re-process atmospheric forcing @@ -774,7 +777,7 @@ subroutine noahmp_sflx (parameters, & co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in elai ,esai ,fwet ,foln , & !in - fveg ,pahv ,pahg ,pahb , & !in + fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in z0wrf ,z0hwrf , & !out @@ -797,7 +800,7 @@ subroutine noahmp_sflx (parameters, & t2mv ,t2mb ,fsrv , & fsrg ,rssun ,rssha ,albd ,albi ,albsnd,albsni, bgap ,wgap, tgv,tgb,& q1 ,q2v ,q2b ,q2e ,chv ,chb , & !out - emissi ,pah , & + emissi ,pah ,canhs, & shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out qsfc = q1 ! @@ -868,9 +871,9 @@ subroutine noahmp_sflx (parameters, & nsnow ,ist ,errwat ,iloc , jloc ,fveg , & sav ,sag ,fsrv ,fsrg ,zwt ,pah , & #ifdef CCPP - pahv ,pahg ,pahb ,errmsg, errflg) !in ( except errwat [out] and errmsg, errflg [inout] ) + pahv ,pahg ,pahb ,canhs,errmsg, errflg) !in ( except errwat [out] and errmsg, errflg [inout] ) #else - pahv ,pahg ,pahb ) !in ( except errwat, which is out ) + pahv ,pahg ,pahb, canhs ) !in ( except errwat, which is out ) #endif #ifdef CCPP @@ -1405,9 +1408,9 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & nsnow ,ist ,errwat, iloc ,jloc ,fveg , & sav ,sag ,fsrv ,fsrg ,zwt ,pah , & #ifdef CCPP - pahv ,pahg ,pahb ,errmsg, errflg) + pahv ,pahg ,pahb ,canhs,errmsg, errflg) #else - pahv ,pahg ,pahb ) + pahv ,pahg ,pahb ,canhs) #endif ! -------------------------------------------------------------------------------------------------- ! check surface energy balance and water balance @@ -1456,6 +1459,7 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & real (kind=kind_phys), intent(in) :: pahv !precipitation advected heat - total (w/m2) real (kind=kind_phys), intent(in) :: pahg !precipitation advected heat - total (w/m2) real (kind=kind_phys), intent(in) :: pahb !precipitation advected heat - total (w/m2) + real (kind=kind_phys), intent(in) :: canhs !canopy heat storage change (w/m2) C.He added based on GY Niu's communication #ifdef CCPP character(len=*) , intent(inout) :: errmsg @@ -1501,7 +1505,7 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & #endif end if - erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) +pah + erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil+canhs) +pah ! erreng = fveg*sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) if(abs(erreng) > 0.01) then write(message,*) 'erreng =',erreng,' at i,j: ',iloc,jloc @@ -1551,6 +1555,12 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) #else call wrf_message(trim(message)) +#endif + write(message,'(a17,f10.4)') "canopy heat storage: ",canhs +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else + call wrf_message(trim(message)) #endif write(message,'(a17,4f10.4)') "precip advected: ",pah,pahv,pahg,pahb #ifdef CCPP @@ -1605,7 +1615,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in elai ,esai ,fwet ,foln , & !in - fveg ,pahv ,pahg ,pahb , & !in + fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in z0wrf ,z0hwrf , & !out @@ -1627,7 +1637,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in qc ,qsfc ,psfc , & !in t2mv ,t2mb ,fsrv , & fsrg ,rssun ,rssha ,albd ,albi,albsnd ,albsni,bgap ,wgap,tgv,tgb,& - q1 ,q2v ,q2b ,q2e ,chv ,chb, emissi,pah ,& + q1 ,q2v ,q2b ,q2e ,chv ,chb, emissi,pah,canhs,& shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out !jref:end @@ -1701,6 +1711,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(in) :: esai !lai adjusted for burying by snow real (kind=kind_phys) , intent(in) :: fwet !fraction of canopy that is wet [-] real (kind=kind_phys) , intent(in) :: fveg !greeness vegetation fraction (-) + real (kind=kind_phys) , intent(in) :: shdfac !< green vegetation fraction [0.0-1.0] real (kind=kind_phys) , intent(in) :: lat !latitude (radians) real (kind=kind_phys) , intent(in) :: canliq !canopy-intercepted liquid water (mm) real (kind=kind_phys) , intent(in) :: canice !canopy-intercepted ice mass (mm) @@ -1774,6 +1785,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(out) :: t2mb !2-m air temperature over bare ground part [k] real (kind=kind_phys) , intent(out) :: bgap real (kind=kind_phys) , intent(out) :: wgap + real (kind=kind_phys) , intent(out) :: canhs !canopy heat storage change (w/m2) real (kind=kind_phys), dimension(1:2) , intent(out) :: albd !albedo (direct) real (kind=kind_phys), dimension(1:2) , intent(out) :: albi !albedo (diffuse) real (kind=kind_phys), dimension(1:2) , intent(out) :: albsnd !snow albedo (direct) @@ -2032,7 +2044,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , & !in + lat ,z0m ,zlvl ,vegtyp , fveg, & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2157,7 +2169,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in fwet ,laisun ,laisha ,cwp ,dzsnso , & !in - zlvl ,zpd ,z0m ,fveg , & !in + zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in @@ -2172,7 +2184,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in #endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,ghv , & !out - t2mv ,psnsun ,psnsha ,csigmaf1, & !out + t2mv ,psnsun ,psnsha ,csigmaf1,canhs, & !out !jref:start qc ,qsfc ,psfc , & !in q2v ,chv2, chleaf, chuc) !inout @@ -2196,7 +2208,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in dzsnso ,zlvl ,zpdg ,z0mg ,fsno, & !in emg ,stc ,df ,rsurf ,latheag , & !in gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in - thsfc_loc, prslkix,prsik1x,prslk1x,fveg,garea1, & !in + thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in #ifdef CCPP tgb ,cmb ,chb, ustarx,errmsg ,errflg , & !inout #else @@ -2415,7 +2427,7 @@ end subroutine energy subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , & !in + lat ,z0m ,zlvl ,vegtyp , fveg,& !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out ! ------------------------------------------------------------------------------------------------- @@ -2441,6 +2453,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) integer , intent(in) :: vegtyp !vegtyp type + real (kind=kind_phys), intent(in) :: fveg !green vegetation fraction [0.0-1.0] ! outputs real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] @@ -2456,6 +2469,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), dimension(-nsnow+1: 0) :: cvsno !volumetric specific heat (j/m3/k) real (kind=kind_phys), dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) real (kind=kind_phys), dimension( 1:nsoil) :: sice !soil ice content + real (kind=kind_phys), parameter :: sbeta = -2.0 ! -------------------------------------------------------------------------------------------------- ! compute snow thermal conductivity and heat capacity @@ -2488,6 +2502,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) + df = df * exp (sbeta * fveg) ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) @@ -3634,7 +3649,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in fwet ,laisun ,laisha ,cwp ,dzsnso , & !in - zlvl ,zpd ,z0m ,fveg, & !in + zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in @@ -3649,7 +3664,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & #endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,gh , & !out - t2mv ,psnsun ,psnsha ,csigmaf1, & !out + t2mv ,psnsun ,psnsha ,csigmaf1,canhs, & !out qc ,qsfc ,psfc , & !in q2v ,cah2 ,chleaf ,chuc ) !inout @@ -3658,7 +3673,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! ground (tg) temperatures that balance the surface energy budgets ! vegetated: -! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] = 0 +! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] + canhs(tv) = 0 ! -sag + irg[tg] + shg[tg] + evg[tg] + gh[tg] = 0 ! -------------------------------------------------------------------------------------------------- implicit none @@ -3673,6 +3688,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & integer, intent(in) :: isnow !actual no. of snow layers integer, intent(in) :: vegtyp !vegetation physiology type real (kind=kind_phys), intent(in) :: fveg !greeness vegetation fraction (-) + real (kind=kind_phys), intent(in) :: shdfac !greeness vegetation fraction (-) real (kind=kind_phys), intent(in) :: sav !solar rad absorbed by veg (w/m2) real (kind=kind_phys), intent(in) :: sag !solar rad absorbed by ground (w/m2) real (kind=kind_phys), intent(in) :: lwdn !atmospheric longwave radiation (w/m2) @@ -3753,7 +3769,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & #endif ! output -! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil = 0 +! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil + canhs = 0 real (kind=kind_phys), intent(out) :: tauxv !wind stress: e-w (n/m2) real (kind=kind_phys), intent(out) :: tauyv !wind stress: n-s (n/m2) real (kind=kind_phys), intent(out) :: irc !net longwave radiation (w/m2) [+= to atm] @@ -3770,6 +3786,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(out) :: csigmaf1 real (kind=kind_phys), intent(out) :: chleaf !leaf exchange coefficient real (kind=kind_phys), intent(out) :: chuc !under canopy exchange coefficient + real (kind=kind_phys), intent(out) :: canhs !canopy heat storage change (w/m2) real (kind=kind_phys), intent(out) :: q2v real (kind=kind_phys) :: cah !sensible heat conductance, canopy air to zlvl air (m/s) @@ -3864,8 +3881,9 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: ch2v !exchange coefficient for 2m over vegetation. real (kind=kind_phys) :: cq2v !exchange coefficient for 2m over vegetation. real (kind=kind_phys) :: eah2 !2m vapor pressure over canopy - real (kind=kind_phys) :: qfx !moisture flux + real (kind=kind_phys) :: qfx !moisture flux real (kind=kind_phys) :: e1 + real (kind=kind_phys) :: hcv !canopy heat capacity j/m2/k, C.He added real (kind=kind_phys) :: vaie !total leaf area index + stem area index,effective @@ -3929,7 +3947,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! for sfcdiff3 snwd = snowh*1000.0 - zlvlv = zlvl - zpd +! zlvlv = zlvl - zpd + zlvlv = zlvl virtfacv = 1.0 + 0.61 * max(qair, 1.e-8) tv1v = sfctmp * virtfacv @@ -4027,7 +4046,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! -- tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(fveg, 0.1_kind_phys) + tem2 = max(shdfac, 0.1_kind_phys) zvfun1= sqrt(tem1 * tem2) gdx=sqrt(garea1) if(opt_sfc == 1 .or. opt_sfc == 2) then @@ -4156,14 +4175,19 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & evc = min(canice*latheav/dt,evc) end if +! canopy heat capacity + hcv = 0.02*vaie*cwat + canliq*cwat/denh2o + canice*cice/denice !j/m2/k + b = sav-irc-shc-evc-tr+pahv !additional w/m2 - a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity +! a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity + a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) + hcv/dt !volumetric heat capacity dtv = b/a irc = irc + fveg*4.*cir*tv**3*dtv shc = shc + fveg*csh*dtv evc = evc + fveg*cev*destv*dtv tr = tr + fveg*ctr*destv*dtv + canhs = dtv*hcv/dt ! update vegetation surface temperature tv = tv + dtv @@ -4413,7 +4437,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & dzsnso ,zlvl ,zpd ,z0m ,fsno , & !in emg ,stc ,df ,rsurf ,lathea , & !in gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in - thsfc_loc, prslkix,prsik1x,prslk1x,fveg,garea1, & !in + thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in #ifdef CCPP tgb ,cm ,ch,ustarx,errmsg ,errflg , & !inout #else @@ -4470,6 +4494,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) , intent(in) :: prsik1x ! in exner function real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function real (kind=kind_phys) , intent(in) :: fveg + real (kind=kind_phys) , intent(in) :: shdfac real (kind=kind_phys) , intent(in) :: garea1 !jref:start; in @@ -4655,7 +4680,8 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! for sfcdiff3; maybe should move to inside the option ! snwd = snowh*1000.0 - zlvlb = zlvl - zpd +! zlvlb = zlvl - zpd + zlvlb = zlvl virtfacb = 1.0 + 0.61 * max(qair, 1.e-8) tv1b = sfctmp * virtfacb @@ -4672,7 +4698,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! ----------------------------------------------------------------- tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(fveg, 0.1_kind_phys) + tem2 = max(shdfac, 0.1_kind_phys) zvfun1= sqrt(tem1 * tem2) gdx=sqrt(garea1) diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90 index 6f14fe93d..36541b0fc 100644 --- a/physics/sfc_diag_post.F90 +++ b/physics/sfc_diag_post.F90 @@ -16,7 +16,7 @@ end subroutine sfc_diag_post_finalize !! #endif subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con_epsm1, pgr,& - t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & + t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg) use machine, only: kind_phys @@ -29,6 +29,7 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con logical , dimension(:), intent(in) :: dry real(kind=kind_phys), dimension(:), intent(in) :: pgr, u10m, v10m real(kind=kind_phys), dimension(:), intent(inout) :: t2m, q2m, tmpmin, tmpmax, spfhmin, spfhmax + real(kind=kind_phys), dimension(:), intent(inout) :: t2mmp, q2mp real(kind=kind_phys), dimension(:), intent(inout) :: wind10mmax, u10mmax, v10mmax, dpt2m character(len=*), intent(out) :: errmsg @@ -41,6 +42,15 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con errmsg = '' errflg = 0 +! if (lsm == lsm_noahmp) then +! do i=1,im +! if(dry(i)) then +! t2m(i) = t2mmp(i) +! q2m(i) = q2mp(i) +! endif +! enddo +! endif + if (lssav) then do i=1,im tmpmax(i) = max(tmpmax(i),t2m(i)) diff --git a/physics/sfc_diag_post.meta b/physics/sfc_diag_post.meta index 21d76a147..95e8d8428 100644 --- a/physics/sfc_diag_post.meta +++ b/physics/sfc_diag_post.meta @@ -74,6 +74,22 @@ type = real kind = kind_phys intent = in +[t2mmp] + standard_name = temperature_at_2m_from_noahmp + long_name = 2 meter temperature from noahmp + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[q2mp] + standard_name = specific_humidity_at_2m_from_noahmp + long_name = 2 meter specific humidity from noahmp + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [t2m] standard_name = air_temperature_at_2m long_name = 2 meter temperature diff --git a/physics/sfc_noahmp_drv.F90 b/physics/sfc_noahmp_drv.F90 index 397a09674..0ebcbd615 100644 --- a/physics/sfc_noahmp_drv.F90 +++ b/physics/sfc_noahmp_drv.F90 @@ -923,7 +923,7 @@ subroutine noahmpdrv_run & snowc (i) = snow_cover_fraction sncovr1 (i) = snow_cover_fraction -! qsurf (i) = spec_humidity_surface + qsurf (i) = spec_humidity_surface tsurf (i) = tskin(i) tvxy (i) = temperature_leaf @@ -998,7 +998,7 @@ subroutine noahmpdrv_run & cmm (i) = cmxy(i) * wind(i) snwdph (i) = snow_depth * 1000.0 ! convert from m to mm; wait after the stability call - qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) +! qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) ! ! --- change units for output From ae7ac42b3679be983aac2dbd5b9f959c4f6db86f Mon Sep 17 00:00:00 2001 From: barlage Date: Mon, 7 Mar 2022 14:37:38 -0700 Subject: [PATCH 05/35] add sfcdif3 as a separate subroutine --- physics/module_sf_noahmplsm.f90 | 549 ++++++++++---------------------- 1 file changed, 167 insertions(+), 382 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 0913531f8..0248a116b 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -2184,7 +2184,8 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in #endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,ghv , & !out - t2mv ,psnsun ,psnsha ,csigmaf1,canhs, & !out + t2mv ,psnsun ,psnsha ,canhs , & !out + csigmaf1, & !out !jref:start qc ,qsfc ,psfc , & !in q2v ,chv2, chleaf, chuc) !inout @@ -3664,7 +3665,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & #endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,gh , & !out - t2mv ,psnsun ,psnsha ,csigmaf1,canhs, & !out + t2mv ,psnsun ,psnsha ,canhs , & !out + csigmaf1, & !out qc ,qsfc ,psfc , & !in q2v ,cah2 ,chleaf ,chuc ) !inout @@ -3673,7 +3675,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! ground (tg) temperatures that balance the surface energy budgets ! vegetated: -! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] + canhs(tv) = 0 +! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] + canhs[tv] = 0 ! -sag + irg[tg] + shg[tg] + evg[tg] + gh[tg] = 0 ! -------------------------------------------------------------------------------------------------- implicit none @@ -3688,7 +3690,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & integer, intent(in) :: isnow !actual no. of snow layers integer, intent(in) :: vegtyp !vegetation physiology type real (kind=kind_phys), intent(in) :: fveg !greeness vegetation fraction (-) - real (kind=kind_phys), intent(in) :: shdfac !greeness vegetation fraction (-) real (kind=kind_phys), intent(in) :: sav !solar rad absorbed by veg (w/m2) real (kind=kind_phys), intent(in) :: sag !solar rad absorbed by ground (w/m2) real (kind=kind_phys), intent(in) :: lwdn !atmospheric longwave radiation (w/m2) @@ -3703,12 +3704,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in) :: dt !time step (s) real (kind=kind_phys), intent(in) :: fsno !snow fraction - logical , intent(in) :: thsfc_loc - real (kind=kind_phys) , intent(in) :: prslkix ! in exner function - real (kind=kind_phys) , intent(in) :: prsik1x ! in exner function - real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function - real (kind=kind_phys) , intent(in) :: garea1 ! - real (kind=kind_phys), intent(in) :: snowh !actual snow depth [m] real (kind=kind_phys), intent(in) :: fwet !wetted fraction of canopy real (kind=kind_phys), intent(in) :: cwp !canopy wind parameter @@ -3761,7 +3756,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(inout) :: tg !ground temperature (k) real (kind=kind_phys), intent(inout) :: cm !momentum drag coefficient real (kind=kind_phys), intent(inout) :: ch !sensible heat exchange coefficient - real (kind=kind_phys), intent(inout) :: ustarx !< friction velocity #ifdef CCPP character(len=*), intent(inout) :: errmsg @@ -3783,11 +3777,9 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(out) :: t2mv !2 m height air temperature (k) real (kind=kind_phys), intent(out) :: psnsun !sunlit leaf photosynthesis (umolco2/m2/s) real (kind=kind_phys), intent(out) :: psnsha !shaded leaf photosynthesis (umolco2/m2/s) - real (kind=kind_phys), intent(out) :: csigmaf1 real (kind=kind_phys), intent(out) :: chleaf !leaf exchange coefficient real (kind=kind_phys), intent(out) :: chuc !under canopy exchange coefficient real (kind=kind_phys), intent(out) :: canhs !canopy heat storage change (w/m2) - real (kind=kind_phys), intent(out) :: q2v real (kind=kind_phys) :: cah !sensible heat conductance, canopy air to zlvl air (m/s) real (kind=kind_phys) :: u10v !10 m wind speed in eastward dir (m/s) @@ -3857,22 +3849,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: ch2 !surface exchange at 2m real (kind=kind_phys) :: thstar !surface exchange at 2m - real (kind=kind_phys) :: dlf ! leaf dimension - real(kind=kind_phys) :: sigmaa ! momentum partition parameter - real(kind=kind_phys) :: kbsigmaf1 ! kb^-1 for fully convered by vegetation - real(kind=kind_phys) :: kbsigmafc ! kb^-1 under canopy ground - - real (kind=kind_phys) :: fm10 !monin-obukhov momentum adjustment at 10m - real (kind=kind_phys) :: rb1v !Bulk Richardson # over vegetation - real (kind=kind_phys) :: stress1v !Stress over vegetation - real (kind=kind_phys) :: snwd - real (kind=kind_phys) :: virtfacv - real (kind=kind_phys) :: thv1v - real (kind=kind_phys) :: tvsv - real (kind=kind_phys) :: tv1v - real (kind=kind_phys) :: zlvlv - - real (kind=kind_phys) :: thvair real (kind=kind_phys) :: thah real (kind=kind_phys) :: rahc2 !aerodynamic resistance for sensible heat (s/m) @@ -3885,14 +3861,10 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: e1 real (kind=kind_phys) :: hcv !canopy heat capacity j/m2/k, C.He added - real (kind=kind_phys) :: vaie !total leaf area index + stem area index,effective real (kind=kind_phys) :: laisune !sunlit leaf area index, one-sided (m2/m2),effective real (kind=kind_phys) :: laishae !shaded leaf area index, one-sided (m2/m2),effective - real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx,czil1 - real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 - integer :: k !index integer :: iter !iteration index @@ -3905,8 +3877,16 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & integer :: liter !last iteration - integer :: niter !for sfcdiff3 +! New variables for sfcdif3 + logical , intent(in ) :: thsfc_loc + real (kind=kind_phys), intent(in ) :: prslkix ! in exner function + real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function + real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function + real (kind=kind_phys), intent(in ) :: garea1 + real (kind=kind_phys), intent(in ) :: shdfac ! greeness vegetation fraction (-) + real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity + real (kind=kind_phys), intent( out) :: csigmaf1 ! real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 @@ -3918,11 +3898,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & mpe = 1e-6 liter = 0 - fv = ustarx - - niter = 1 - if (ur < 2.0) niter = 2 - ! --------------------------------------------------------------------------------------------- ! initialization variables that do not depend on stability iteration ! --------------------------------------------------------------------------------------------- @@ -3936,31 +3911,12 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & h = 0. qfx = 0. - csigmaf1 = 0. - ! limit lai vaie = min(6.,vai ) laisune = min(6.,laisun) laishae = min(6.,laisha) -! for sfcdiff3 - - snwd = snowh*1000.0 -! zlvlv = zlvl - zpd - zlvlv = zlvl - - virtfacv = 1.0 + 0.61 * max(qair, 1.e-8) - tv1v = sfctmp * virtfacv - - if(thsfc_loc) then ! Use local potential temperature - thv1v = sfctmp * prslkix * virtfacv - else ! Use potential temperature reference to 1000 hPa - thv1v = sfctmp / prslk1x * virtfacv - endif -! - - ! saturation vapor pressure at ground temperature t = tdc(tg) @@ -3975,8 +3931,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & qsfc = 0.622*eair/(psfc-0.378*eair) - dlf = parameters%dleaf !leaf dimension - ! canopy height hcan = parameters%hvt @@ -4024,37 +3978,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 cir = (2.-emv*(1.-emg))*emv*sb ! --------------------------------------------------------------------------------------------- - - if (opt_trs == 1) then - z0h = z0m - elseif (opt_trs == 2) then -! z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) - czil1= 10.0 ** (- (0.40/0.07) * hcan) - z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) - elseif (opt_trs == 3) then - if (vegtyp.le.5) then - z0h = z0m - else - z0h = z0m*0.01 - endif - elseif (opt_trs == 4) then - sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) - kbsigmaf1 = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) - z0h = z0m/exp(kbsigmaf1) - csigmaf1 = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m)+kbsigmaf1) ! for output for interpolation - endif -! -- - tem1 = (z0m - z0lo) / (z0up - z0lo) - tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(shdfac, 0.1_kind_phys) - zvfun1= sqrt(tem1 * tem2) - gdx=sqrt(garea1) - if(opt_sfc == 1 .or. opt_sfc == 2) then - loop1: do iter = 1, niterc ! begin stability iteration -! use newly derived z0m/z0h - if(iter == 1) then z0hg = z0mg else @@ -4089,6 +4014,15 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & cm = cm / ur endif + if(opt_sfc == 3) then + call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in + zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in + zpd ,snowh ,fveg ,garea1 ,.true. ,vaie , & !in + ustarx ,fm ,fh ,fm2 ,fh2 , & !inout + z0h ,fv ,csigmaf1,cm ,ch ) !out + + endif + ramc = max(1.,1./(cm*ur)) rahc = max(1.,1./(ch*ur)) rawc = rahc @@ -4209,135 +4143,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & end do loop1 ! end stability iteration - endif !opt_sfc 1 or 2 -! -! sfcdiff3 -! - if (opt_sfc == 3) then - - z0hg = z0mg - - do iter = 1, niter !1 or 2; depending on ur - - if(thsfc_loc) then ! Use local potential temperature - tvsv = tah * virtfacv - else ! Use potential temperature referenced to 1000 hPa - tvsv = tah/prsik1x * virtfacv - endif - - call stability & - (zlvlv, zvfun1, gdx,tv1v,thv1v, ur, z0m, z0h, tvsv, grav,thsfc_loc, & - rb1v, fm,fh,fm10,fh2,cm,ch,stress1v,fv) - - ramc = max(1.,1./(cm*ur)) - rahc = max(1.,1./(ch*ur)) - rawc = rahc - -! aerodyn resistance between heights z0g and d+z0v, rag, and leaf -! boundary layer resistance, rb - - call ragrb(parameters,iter ,vaie ,rhoair ,hg ,tah , & !in - zpd ,z0mg ,z0hg ,hcan ,uc , & !in - z0h ,fv ,cwp ,vegtyp ,mpe , & !in - tv ,mozg ,fhg ,iloc ,jloc , & !inout - ramg ,rahg ,rawg ,rb ) !out - -! es and d(es)/dt evaluated at tv - - t = tdc(tv) - call esat(t, esatw, esati, dsatw, dsati) - if (t .gt. 0.) then - estv = esatw - destv = dsatw - else - estv = esati - destv = dsati - end if - -! stomatal resistance - - if(iter == 1) then - if (opt_crs == 1) then ! ball-berry - call stomata (parameters,vegtyp,mpe ,parsun ,foln ,iloc , jloc , & !in - tv ,estv ,eah ,sfctmp,sfcprs, & !in - o2air ,co2air,igs ,btran ,rb , & !in - rssun ,psnsun) !out - - call stomata (parameters,vegtyp,mpe ,parsha ,foln ,iloc , jloc , & !in - tv ,estv ,eah ,sfctmp,sfcprs, & !in - o2air ,co2air,igs ,btran ,rb , & !in - rssha ,psnsha) !out - end if - - if (opt_crs == 2) then ! jarvis - call canres (parameters,parsun,tv ,btran ,eah ,sfcprs, & !in - rssun ,psnsun,iloc ,jloc ) !out - - call canres (parameters,parsha,tv ,btran ,eah ,sfcprs, & !in - rssha ,psnsha,iloc ,jloc ) !out - end if - end if - -! prepare for sensible heat flux above veg. - - cah = 1./rahc - cvh = 2.*vaie/rb - cgh = 1./rahg - cond = cah + cvh + cgh - ata = (sfctmp*cah + tg*cgh) / cond - bta = cvh/cond - csh = (1.-bta)*rhoair*cpair*cvh - -! prepare for latent heat flux above veg. - - caw = 1./rawc - cew = fwet*vaie/rb - ctw = (1.-fwet)*(laisune/(rb+rssun) + laishae/(rb+rssha)) - cgw = 1./(rawg+rsurf) - cond = caw + cew + ctw + cgw - aea = (eair*caw + estg*cgw) / cond - bea = (cew+ctw)/cond - cev = (1.-bea)*cew*rhoair*cpair/gammav ! barlage: change to vegetation v3.6 - ctr = (1.-bea)*ctw*rhoair*cpair/gammav - -! evaluate surface fluxes with current temperature and solve for dts - - tah = ata + bta*tv ! canopy air t. - eah = aea + bea*estv ! canopy air e - - irc = fveg*(air + cir*tv**4) - shc = fveg*rhoair*cpair*cvh * ( tv-tah) - evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6 - tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav - if (tv > tfrz) then - evc = min(canliq*latheav/dt,evc) ! barlage: add if block for canice in v3.6 - else - evc = min(canice*latheav/dt,evc) - end if - - b = sav-irc-shc-evc-tr+pahv !additional w/m2 - a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity - dtv = b/a - - irc = irc + fveg*4.*cir*tv**3*dtv - shc = shc + fveg*csh*dtv - evc = evc + fveg*cev*destv*dtv - tr = tr + fveg*ctr*destv*dtv - -! update vegetation surface temperature - tv = tv + dtv -! tah = ata + bta*tv ! canopy air t; update here for consistency - -! for computing m-o length in the next iteration - h = rhoair*cpair*(tah - sfctmp) /rahc - hg = rhoair*cpair*(tg - tah) /rahg - -! consistent specific humidity from canopy air vapor pressure - qsfc = (0.622*eah)/(sfcprs-0.378*eah) - - enddo ! iteration - endif ! sfcdiff3 - ! under-canopy fluxes and tg air = - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4 @@ -4443,7 +4248,8 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & #else tgb ,cm ,ch,ustarx, & !inout #endif - tauxb ,tauyb ,irb ,shb ,evb,csigmaf0,& !out + tauxb ,tauyb ,irb ,shb ,evb , & !out + csigmaf0, & !out ghb ,t2mb ,dx ,dz8w ,ivgtyp , & !out qc ,qsfc ,psfc , & !in sfcprs ,q2b ,ehb2 ) !in @@ -4489,14 +4295,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) real (kind=kind_phys), intent(in) :: fsno !snow fraction - logical , intent(in) :: thsfc_loc - real (kind=kind_phys) , intent(in) :: prslkix ! in exner function - real (kind=kind_phys) , intent(in) :: prsik1x ! in exner function - real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function - real (kind=kind_phys) , intent(in) :: fveg - real (kind=kind_phys) , intent(in) :: shdfac - real (kind=kind_phys) , intent(in) :: garea1 - !jref:start; in integer , intent(in) :: ivgtyp real (kind=kind_phys) , intent(in) :: qc !cloud water mixing ratio @@ -4513,7 +4311,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(inout) :: tgb !ground temperature (k) real (kind=kind_phys), intent(inout) :: cm !momentum drag coefficient real (kind=kind_phys), intent(inout) :: ch !sensible heat exchange coefficient - real (kind=kind_phys), intent(inout) :: ustarx !friction velocity #ifdef CCPP character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg @@ -4529,7 +4326,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(out) :: evb !latent heat flux (w/m2) [+ to atm] real (kind=kind_phys), intent(out) :: ghb !ground heat flux (w/m2) [+ to soil] real (kind=kind_phys), intent(out) :: t2mb !2 m height air temperature (k) - real (kind=kind_phys), intent(out) :: csigmaf0 ! !jref:start real (kind=kind_phys), intent(out) :: q2b !bare ground heat conductance real (kind=kind_phys) :: ehb !bare ground heat conductance @@ -4540,17 +4336,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! local variables - real (kind=kind_phys) :: rb1b !Bulk Richardson # over bare soil - real (kind=kind_phys) :: stress1b !Stress over bare soil - real (kind=kind_phys) :: snwd - real (kind=kind_phys) :: virtfacb - real (kind=kind_phys) :: thv1b - real (kind=kind_phys) :: tvsb - real (kind=kind_phys) :: tv1b - real (kind=kind_phys) :: zlvlb - - real (kind=kind_phys) :: fm10 - real (kind=kind_phys) :: taux !wind stress: e-w (n/m2) real (kind=kind_phys) :: tauy !wind stress: n-s (n/m2) real (kind=kind_phys) :: fira !total net longwave rad (w/m2) [+ to atm] @@ -4577,9 +4362,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: cev !coefficients for ev as function of esat[ts] real (kind=kind_phys) :: cgh !coefficients for st as function of ts - real(kind=kind_phys) :: kbsigmaf0 - real(kind=kind_phys) :: reynb - !jref:start real (kind=kind_phys) :: rahb2 !aerodynamic resistance for sensible heat 2m (s/m) real (kind=kind_phys) :: rawb2 !aerodynamic resistance for water vapor 2m (s/m) @@ -4614,18 +4396,26 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: fh2 !monin-obukhov heat adjustment at 2m real (kind=kind_phys) :: ch2 !surface exchange at 2m - real(kind=kind_phys) :: tem1,tem2,zvfun1,gdx,czil1 - real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 - integer :: iter !iteration index integer :: niterb !number of iterations for surface temperature - integer :: niter - real (kind=kind_phys) :: mpe !prevents overflow error if division by zero !jref:start ! data niterb /3/ data niterb /5/ save niterb + +! New variables for sfcdif3 + + logical , intent(in ) :: thsfc_loc + real (kind=kind_phys), intent(in ) :: prslkix ! in exner function + real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function + real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function + real (kind=kind_phys), intent(in ) :: fveg + real (kind=kind_phys), intent(in ) :: shdfac + real (kind=kind_phys), intent(in ) :: garea1 + real (kind=kind_phys), intent(inout) :: ustarx !friction velocity + real (kind=kind_phys), intent( out) :: csigmaf0 ! + real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 tdc(t) = min( 50., max(-50.,(t-tfrz)) ) @@ -4641,69 +4431,10 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & h = 0. qfx = 0. - csigmaf0 = 0. - kbsigmaf0 = 0. - - niter = 1 - if (ur < 2.0) niter = 2 - - fv = ustarx - -! fv = ur*vkc/log((zlvl-zpd)/z0m) - - reynb = fv*z0m/(1.5e-05) - - if (reynb .gt. 2.0) then - kbsigmaf0 = 2.46*reynb**0.25 - log(7.4) - else - kbsigmaf0 = - log(0.397) - endif - - csigmaf0 = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m) + kbsigmaf0) - - if (opt_trs == 1) then - z0h = z0m - elseif (opt_trs == 2) then -! z0h = z0m*exp(-parameters%czil*0.4*258.2*sqrt(fv*z0m)) - czil1= 10.0 ** (- (0.40/0.07) * parameters%hvt) - z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) - elseif (opt_trs == 3) then - if (vegtyp.le.5) then - z0h = z0m - else - z0h = z0m*0.01 - endif - elseif (opt_trs == 4) then - z0h = max(z0m/exp(kbsigmaf0),1.0e-6) - endif -! -! for sfcdiff3; maybe should move to inside the option -! - snwd = snowh*1000.0 -! zlvlb = zlvl - zpd - zlvlb = zlvl - - virtfacb = 1.0 + 0.61 * max(qair, 1.e-8) - tv1b = sfctmp * virtfacb - - if(thsfc_loc) then ! Use local potential temperature - thv1b = sfctmp * prslkix * virtfacb - else ! Use potential temperature reference to 1000 hPa - thv1b = sfctmp / prslk1x * virtfacb - endif - cir = emg*sb cgh = 2.*df(isnow+1)/dzsnso(isnow+1) ! ----------------------------------------------------------------- - tem1 = (z0m - z0lo) / (z0up - z0lo) - tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(shdfac, 0.1_kind_phys) - zvfun1= sqrt(tem1 * tem2) - gdx=sqrt(garea1) - - if (opt_sfc == 1 .or. opt_sfc == 2) then - loop3: do iter = 1, niterb ! begin stability iteration ! if(iter == 1) then @@ -4743,6 +4474,15 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & endif + if(opt_sfc == 3) then + call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in + zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in + zpd ,snowh ,shdfac ,garea1 ,.false. ,0.0 , & !in + ustarx ,fm ,fh ,fm2 ,fh2 , & !inout + z0h ,fv ,csigmaf0,cm ,ch ) !out + + endif + ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) rawb = rahb @@ -4800,83 +4540,8 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & qfx = (qsfc-qair)*cev*gamma/cpair end do loop3 ! end stability iteration - endif ! opt_sfc 1/2 ! ----------------------------------------------------------------- - if (opt_sfc == 3) then - - do iter = 1, niter !1 or 2; depending on ur - - if(thsfc_loc) then ! Use local potential temperature - tvsb = tgb * virtfacb - else ! Use potential temperature referenced to 1000 hPa - tvsb = tgb/prsik1x * virtfacb - endif - - call stability & - (zlvlb, zvfun1, gdx,tv1b,thv1b, ur, z0m, z0h, tvsb, grav,thsfc_loc, & - rb1b, fm,fh,fm10,fh2,cm,ch,stress1b,fv) - - - ramb = max(1.,1./(cm*ur)) - rahb = max(1.,1./(ch*ur)) - rawb = rahb - -!jref - variables for diagnostics - emb = 1./ramb - ehb = 1./rahb - -! es and d(es)/dt evaluated at tg - - t = tdc(tgb) - call esat(t, esatw, esati, dsatw, dsati) - if (t .gt. 0.) then - estg = esatw - destg = dsatw - else - estg = esati - destg = dsati - end if - - csh = rhoair*cpair/rahb - cev = rhoair*cpair/gamma/(rsurf+rawb) - -! surface fluxes and dtg - - irb = cir * tgb**4 - emg*lwdn - shb = csh * (tgb - sfctmp ) - evb = cev * (estg*rhsur - eair ) - ghb = cgh * (tgb - stc(isnow+1)) - - b = sag-irb-shb-evb-ghb+pahb - a = 4.*cir*tgb**3 + csh + cev*destg + cgh - dtg = b/a - - irb = irb + 4.*cir*tgb**3*dtg - shb = shb + csh*dtg - evb = evb + cev*destg*dtg - ghb = ghb + cgh*dtg - -! update ground surface temperature - tgb = tgb + dtg - -! for m-o length -! h = csh * (tgb - sfctmp) - - t = tdc(tgb) - call esat(t, esatw, esati, dsatw, dsati) - if (t .gt. 0.) then - estg = esatw - else - estg = esati - end if - qsfc = 0.622*(estg*rhsur)/(psfc-0.378*(estg*rhsur)) - - qfx = (qsfc-qair)*cev*gamma/cpair - - end do ! end stability iteration - endif ! sfcdiff3 - ! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes. if(opt_stc == 1 .or. opt_stc == 3) then @@ -5409,6 +5074,126 @@ subroutine sfcdif2(parameters,iter ,z0 ,thz0 ,thlm ,sfcspd , & !in ! ---------------------------------------------------------------------- end subroutine sfcdif2 +!== begin sfcdif3 ================================================================================== + +!>\ingroup NoahMP_LSM +!! compute surface drag coefficient cm for momentum and ch for heat. + subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in + zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie , & !in + ustarx ,fm ,fh ,fm2 ,fh2 , & !inout + z0h ,fv ,csigmaf ,cm ,ch ) !out + +! ------------------------------------------------------------------------------------------------- +! computing surface drag coefficient cm for momentum and ch for heat +! ------------------------------------------------------------------------------------------------- + implicit none +! ------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in ) :: iloc ! grid index + integer, intent(in ) :: jloc ! grid index + integer, intent(in ) :: iter ! iteration index + real (kind=kind_phys), intent(in ) :: sfctmp ! temperature at reference height [K] + real (kind=kind_phys), intent(in ) :: qair ! specific humidity at reference height [kg/kg] + real (kind=kind_phys), intent(in ) :: ur ! wind speed [m/s] + real (kind=kind_phys), intent(in ) :: zlvl ! reference height [m] + real (kind=kind_phys), intent(in ) :: tgb ! ground temperature [K] + logical, intent(in ) :: thsfc_loc ! flag for using sfc-based theta + real (kind=kind_phys), intent(in ) :: prslkix ! in exner function + real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function + real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function + real (kind=kind_phys), intent(in ) :: z0m ! roughness length, momentum, ground [m] + real (kind=kind_phys), intent(in ) :: zpd ! zero plane displacement [m] + real (kind=kind_phys), intent(in ) :: snowh ! snow depth [m] + real (kind=kind_phys), intent(in ) :: fveg ! fractional vegetation cover + real (kind=kind_phys), intent(in ) :: garea1 ! grid area [km2] + logical, intent(in ) :: vegetated ! .true. if vegetated + real (kind=kind_phys), intent(in ) :: vaie ! vegetation area index [m2/m2] + real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity [m/s] + real (kind=kind_phys), intent(inout) :: fm ! momentum stability correction, weighted by prior iters + real (kind=kind_phys), intent(inout) :: fh ! sen heat stability correction, weighted by prior iters + real (kind=kind_phys), intent(inout) :: fm2 ! sen heat stability correction, weighted by prior iters + real (kind=kind_phys), intent(inout) :: fh2 ! sen heat stability correction, weighted by prior iters + real (kind=kind_phys), intent( out) :: z0h ! roughness length, sensible heat, ground [m] + real (kind=kind_phys), intent( out) :: fv ! friction velocity (m/s) + real (kind=kind_phys), intent( out) :: csigmaf ! + real (kind=kind_phys), intent( out) :: cm ! drag coefficient for momentum + real (kind=kind_phys), intent( out) :: ch ! drag coefficient for heat + + real (kind=kind_phys) :: reyn ! reynolds number + real (kind=kind_phys) :: kbsigmaf ! kb factor + real (kind=kind_phys) :: snwd ! snow depth [mm] + real (kind=kind_phys) :: zlvlb ! reference height - zpd [m] + real (kind=kind_phys) :: virtfac ! virtual temperature factor [-] + real (kind=kind_phys) :: tv1 ! virtual temperature at reference [K] + real (kind=kind_phys) :: thv1 ! virtual theta at reference [K] + real (kind=kind_phys) :: tvs ! virtural surface temperature [K] + real (kind=kind_phys) :: rb1 ! bulk Richardson - stability output + real (kind=kind_phys) :: stress1 ! stress - stability output + real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output + real (kind=kind_phys) :: dlf ! leaf dimension + real (kind=kind_phys) :: sigmaa ! momentum partition parameter + real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx + real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 + +! ------------------------------------------------------------------------------------------------- + + fv = ustarx +! fv = ur*vkc/log((zlvl-zpd)/z0m) + + if(vegetated) then + + dlf = parameters%dleaf + sigmaa = 1.0 - (0.5/(0.5+vaie)) * exp(-vaie**2/8.0) + kbsigmaf = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) + z0h = z0m/exp(kbsigmaf) + csigmaf = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m) + kbsigmaf) ! for output for interpolation + + else + + reyn = fv*z0m/(1.5e-05) + if (reyn .gt. 2.0) then + kbsigmaf = 2.46*reyn**0.25 - log(7.4) + else + kbsigmaf = - log(0.397) + endif + + z0h = max(z0m/exp(kbsigmaf),1.0e-6) + csigmaf = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m) + kbsigmaf) + + end if + + snwd = snowh*1000.0 + zlvlb = zlvl! - zpd + + virtfac = 1.0 + 0.61 * max(qair, 1.0e-8) + tv1 = sfctmp * virtfac + + if(thsfc_loc) then ! Use local potential temperature + thv1 = sfctmp * prslkix * virtfac + else ! Use potential temperature reference to 1000 hPa + thv1 = sfctmp / prslk1x * virtfac + endif + + tem1 = (z0m - z0lo) / (z0up - z0lo) + tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) + tem2 = max(fveg, 0.1_kind_phys) + zvfun1 = sqrt(tem1 * tem2) + gdx = sqrt(garea1) + + if(thsfc_loc) then ! Use local potential temperature + tvs = tgb * virtfac + else ! Use potential temperature referenced to 1000 hPa + tvs = tgb/prsik1x * virtfac + endif + + call stability (zlvlb, zvfun1, gdx, tv1, thv1, ur, z0m, z0h, tvs, grav, thsfc_loc, & + rb1, fm,fh,fm10,fh2,cm,ch,stress1,fv) + + end subroutine sfcdif3 + !== begin esat ===================================================================================== !>\ingroup NoahMP_LSM From c50f50a07c78e9eed773f8c936d8360b61a1d5c9 Mon Sep 17 00:00:00 2001 From: barlage Date: Mon, 7 Mar 2022 14:42:58 -0700 Subject: [PATCH 06/35] change fveg to shdfac in sfcdif3 vege call --- physics/module_sf_noahmplsm.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 0248a116b..5964e4575 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4017,7 +4017,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,.true. ,vaie , & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out From 53c0c7acfe64609c021e551f1edf67376bcd1387 Mon Sep 17 00:00:00 2001 From: barlage Date: Mon, 7 Mar 2022 15:07:35 -0700 Subject: [PATCH 07/35] move trs options to sfcdif3 --- physics/module_sf_noahmplsm.f90 | 44 ++++++++++++++++++++++++++------- 1 file changed, 35 insertions(+), 9 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 5964e4575..42a213fed 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -3986,6 +3986,19 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & z0hg = z0mg !* exp(-czil*0.4*258.2*sqrt(fv*z0mg)) end if + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + czil1= 10.0 ** (- (0.40/0.07) * parameters%hvt) + z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0h = z0m + else + z0h = z0m*0.01 + endif + endif + ! aerodyn resistances between heights zlvl and d+z0v if(opt_sfc == 1) then @@ -4017,7 +4030,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie , & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out @@ -4477,7 +4490,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.false. ,0.0 , & !in + zpd ,snowh ,shdfac ,garea1 ,.false. ,0.0 ,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out @@ -5080,7 +5093,7 @@ end subroutine sfcdif2 !! compute surface drag coefficient cm for momentum and ch for heat. subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,vegetated,vaie , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie ,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf ,cm ,ch ) !out @@ -5111,6 +5124,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys), intent(in ) :: garea1 ! grid area [km2] logical, intent(in ) :: vegetated ! .true. if vegetated real (kind=kind_phys), intent(in ) :: vaie ! vegetation area index [m2/m2] + integer , intent(in ) :: vegtyp ! vegetation category real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity [m/s] real (kind=kind_phys), intent(inout) :: fm ! momentum stability correction, weighted by prior iters real (kind=kind_phys), intent(inout) :: fh ! sen heat stability correction, weighted by prior iters @@ -5132,8 +5146,8 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys) :: tvs ! virtural surface temperature [K] real (kind=kind_phys) :: rb1 ! bulk Richardson - stability output real (kind=kind_phys) :: stress1 ! stress - stability output + real (kind=kind_phys) :: czil1 ! canopy based czil real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output - real (kind=kind_phys) :: dlf ! leaf dimension real (kind=kind_phys) :: sigmaa ! momentum partition parameter real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 @@ -5145,11 +5159,23 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur if(vegetated) then - dlf = parameters%dleaf - sigmaa = 1.0 - (0.5/(0.5+vaie)) * exp(-vaie**2/8.0) - kbsigmaf = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) - z0h = z0m/exp(kbsigmaf) - csigmaf = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m) + kbsigmaf) ! for output for interpolation + if (opt_trs == 1) then + z0h = z0m + elseif (opt_trs == 2) then + czil1= 10.0 ** (- (0.40/0.07) * parameters%hvt) + z0h = z0m*exp(-czil1*0.4*258.2*sqrt(fv*z0m)) + elseif (opt_trs == 3) then + if (vegtyp.le.5) then + z0h = z0m + else + z0h = z0m*0.01 + endif + elseif (opt_trs == 4) then + sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) + kbsigmaf = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(parameters%dleaf*ur/log((zlvl-zpd)/z0m)) + z0h = z0m/exp(kbsigmaf) + csigmaf = log((zlvl-zpd)/z0m)*(log((zlvl-zpd)/z0m)+kbsigmaf) ! for output for interpolation + endif else From f093f77d40f4d7e0c5097caa20191050964ef5d5 Mon Sep 17 00:00:00 2001 From: barlage Date: Mon, 7 Mar 2022 15:10:50 -0700 Subject: [PATCH 08/35] fix missing czil1 in vege_flux --- physics/module_sf_noahmplsm.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 42a213fed..4a296debb 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -3887,6 +3887,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in ) :: shdfac ! greeness vegetation fraction (-) real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity real (kind=kind_phys), intent( out) :: csigmaf1 ! + real (kind=kind_phys) :: czil1 ! canopy based czil real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 From 13a1d1480410c3c7b453e252f2d3c159e48cb04f Mon Sep 17 00:00:00 2001 From: barlage Date: Tue, 8 Mar 2022 06:55:33 -0700 Subject: [PATCH 09/35] add some clean up to energy --- physics/module_sf_noahmplsm.f90 | 65 +++++++++++++++++---------------- 1 file changed, 33 insertions(+), 32 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 4a296debb..4ff484dfb 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -1952,26 +1952,21 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in chv2 = 0. rb = 0. -! - cdmnv = 0. - ezpdv = 0. - - cdmng = 0. - ezpdg = 0. - - cdmn = 0. - ezpd = 0. - - gsigma = 0. - - z0hwrf = 0. - csigmaf1 = 0. - csigmaf0 = 0. - csigmafveg= 0. - kbsigmafveg = 0. - aone = 0. - coeffa = 0. - coeffb = 0. + cdmnv = 0.0 + ezpdv = 0.0 + cdmng = 0.0 + ezpdg = 0.0 + cdmn = 0.0 + ezpd = 0.0 + gsigma = 0.0 + z0hwrf = 0.0 + csigmaf1 = 0.0 + csigmaf0 = 0.0 + csigmafveg= 0.0 + kbsigmafveg = 0.0 + aone = 0.0 + coeffa = 0.0 + coeffb = 0.0 ! @@ -2190,9 +2185,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in qc ,qsfc ,psfc , & !in q2v ,chv2, chleaf, chuc) !inout - cdmnv = 0.4*0.4/log((zlvl-zpd)/z0m)**2 - aone = 2.6*(10.0*parameters%hvt/(zlvl-zpd))**0.355 - ezpdv = zpd*fveg !for the grid +! new coupling code + + cdmnv = 0.4*0.4/log((zlvl-zpd)/z0m)**2 + aone = 2.6*(10.0*parameters%hvt/(zlvl-zpd))**0.355 + ezpdv = zpd*fveg !for the grid !jref:end #ifdef CCPP @@ -2221,18 +2218,20 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in qc ,qsfc ,psfc , & !in sfcprs ,q2b, chb2) !in - cdmng = 0.4*0.4/log((zlvl-zpdg)/z0mg)**2 - ezpdg = zpdg +! new coupling code + + cdmng = 0.4*0.4/log((zlvl-zpdg)/z0mg)**2 + ezpdg = zpdg ! ! vegetation is optional; use the larger one ! - if (ezpdv .ge. ezpdg ) then - ezpd = ezpdv - elseif (ezpdv .gt. 0.0 .and. ezpdv .lt. ezpdg) then - ezpd = (1.0 -fveg)*ezpdg - else - ezpd = ezpdg - endif + if (ezpdv .ge. ezpdg ) then + ezpd = ezpdv + elseif (ezpdv .gt. 0.0 .and. ezpdv .lt. ezpdg) then + ezpd = (1.0 -fveg)*ezpdg + else + ezpd = ezpdg + endif !jref:end #ifdef CCPP @@ -2260,6 +2259,8 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc q2e = fveg * q2v + (1.0 - fveg) * q2b +! new coupling code + if (opt_trs == 1) then z0wrf = fveg * z0m + (1.0 - fveg) * z0mg z0hwrf = z0wrf From ebb4fa16d3d2494850431a97b3772e60875d8975 Mon Sep 17 00:00:00 2001 From: barlage Date: Tue, 8 Mar 2022 07:01:12 -0700 Subject: [PATCH 10/35] add some groundwater mods from ncar code --- physics/module_sf_noahmplsm.f90 | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 4ff484dfb..445034741 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -7621,8 +7621,10 @@ subroutine soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in if ( parameters%urban_flag ) fcr(1)= 0.95 if(opt_run == 1) then - fff = 6.0 - fsat = parameters%fsatmx*exp(-0.5*fff*(zwt-2.0)) +! fff = 6.0 + fff = parameters%bexp(1) / 3.0 ! calibratable, c.he changed based on gy niu's update +! fsat = parameters%fsatmx*exp(-0.5*fff*(zwt-2.0)) + fsat = parameters%fsatmx*exp(-0.5*fff*zwt) ! c.he changed based on gy niu's update if(qinsur > 0.) then runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) ) pddum = qinsur - runsrf ! m/s @@ -8337,8 +8339,9 @@ subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in real (kind=kind_phys) :: watmin!minimum soil vol soil moisture [m3/m3] real (kind=kind_phys) :: xs !excessive water above saturation [mm] real (kind=kind_phys), parameter :: rous = 0.2 !specific yield [-] - real (kind=kind_phys), parameter :: cmic = 0.20 !microprore content (0.0-1.0) +! real (kind=kind_phys), parameter :: cmic = 0.20 !microprore content (0.0-1.0) !0.0-close to free drainage + real (kind=kind_phys), parameter :: cmic = 0.80 ! calibratable, c.he changed based on gy niu's update ! ------------------------------------------------------------- qdis = 0.0 qin = 0.0 @@ -8380,8 +8383,10 @@ subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in ! groundwater discharge [mm/s] - fff = 6.0 - rsbmx = 5.0 +! fff = 6.0 +! rsbmx = 5.0 + fff = parameters%bexp(iwt) / 3.0 ! calibratable, c.he changed based on gy niu's update + rsbmx = hk(iwt) * 1.0e3 * exp(3.0) ! mm/s, calibratable, c.he changed based on gy niu's update qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*(zwt-2.0)) From 41cf4ecb44a6a983a8132c2986b91a0c2964595b Mon Sep 17 00:00:00 2001 From: helin wei Date: Tue, 8 Mar 2022 14:31:07 +0000 Subject: [PATCH 11/35] gvf impact on thermal conductivity limited to the first soil layer --- physics/module_sf_noahmplsm.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 4a296debb..0601e98f1 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -2503,7 +2503,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) - df = df * exp (sbeta * fveg) + df(1) = df(1) * exp (sbeta * fveg) ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) From c1d813e21bd5238c65c95974264965e2f01540f6 Mon Sep 17 00:00:00 2001 From: helin wei Date: Tue, 8 Mar 2022 19:19:40 +0000 Subject: [PATCH 12/35] correct the reference height --- physics/module_sf_noahmp_glacier.f90 | 3 +-- physics/module_sf_noahmplsm.f90 | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index 1ea4a45b8..c4c03aaf8 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -1152,8 +1152,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ! the following only applies to opt_sfc =3, opt_sfc = 1 still done its old way snwd = snowh*1000.0 -! zlvli = zlvl - zpd - zlvli = zlvl + zlvli = zlvl - zpd ! fv = ustarx ! the input maybe too high for glacial fv = ur*vkc/log(zlvli/z0m) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index a93284475..919d81507 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -5194,7 +5194,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur end if snwd = snowh*1000.0 - zlvlb = zlvl! - zpd + zlvlb = zlvl - zpd virtfac = 1.0 + 0.61 * max(qair, 1.0e-8) tv1 = sfctmp * virtfac From 11b50ca1f939042faf1ec3d10707fb73c2af5f4b Mon Sep 17 00:00:00 2001 From: helin wei Date: Wed, 9 Mar 2022 18:21:04 +0000 Subject: [PATCH 13/35] to read new hig-res ice climatology data --- physics/sfcsub.F | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index e8b61f083..cdc91cca9 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -34,7 +34,8 @@ module sfccyc_module integer, parameter :: kpdalf(2)=(/214,217/) ! real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 - integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata +! integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata + integer, parameter :: xdata=7200, ydata=3600, mdata=xdata*ydata integer :: veg_type_landice integer :: soil_type_landice integer :: num_threads From 4ed3982e48694e9abe52ae2dbf48d79068484c43 Mon Sep 17 00:00:00 2001 From: helin wei Date: Thu, 10 Mar 2022 17:49:49 +0000 Subject: [PATCH 14/35] replace fveg by lai/laimax to be used for dependent --- physics/module_sf_noahmplsm.f90 | 60 ++++++++++++++++++++++++--------- 1 file changed, 45 insertions(+), 15 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 919d81507..7e17f511d 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -682,6 +682,10 @@ subroutine noahmp_sflx (parameters, & logical :: crop_active !< flag to run crop model ! add canopy heat storage (C.He added based on GY Niu's communication) real :: canhs ! canopy heat storage change w/m2 +! maximum lai/sai used for some parameterizations based on plant growthi + real (kind=kind_phys) :: saimax !< monthly maximum stem area index, one-sided + real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided + ! intent (out) variables need to be assigned a value. these normally get assigned values ! only if dveg == 2. @@ -732,7 +736,7 @@ subroutine noahmp_sflx (parameters, & ! vegetation phenology call phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai ,igs, pgs) + lai , sai , laimax, saimax, troot , elai , esai ,igs, pgs) !input gvf should be consistent with lai if(dveg == 1 .or. dveg == 6 .or. dveg == 7) then @@ -776,7 +780,7 @@ subroutine noahmp_sflx (parameters, & sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in + elai ,esai ,laimax, saimax, fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in @@ -1055,7 +1059,7 @@ end subroutine atm !!vegetation phenology considering vegetation canopy being buried by snow and !!evolution in time. subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai , igs, pgs) + lai , sai , laimax, saimax, troot , elai , esai , igs, pgs) ! -------------------------------------------------------------------------------------------------- ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time @@ -1076,6 +1080,8 @@ subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yea real (kind=kind_phys) , intent(inout) :: sai !sai, unadjusted for burying by snow ! outputs + real (kind=kind_phys) , intent(out ) :: saimax !< monthly maximum stem area index, one-sided + real (kind=kind_phys) , intent(out ) :: laimax !< monthly maximum leaf area index, one-sided real (kind=kind_phys) , intent(out ) :: elai !leaf area index, after burying by snow real (kind=kind_phys) , intent(out ) :: esai !stem area index, after burying by snow real (kind=kind_phys) , intent(out ) :: igs !growing season index (0=off, 1=on) @@ -1095,6 +1101,23 @@ subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yea real (kind=kind_phys) :: t !current month (1.00, ..., 12.00) ! -------------------------------------------------------------------------------------------------- +! derive monthly maximum lai and sai from monthly lai + + laimax=parameters%laim(1) + saimax=parameters%saim(1) + + do k=1,12 + + if(parameters%laim(k).ge.laimax)then + laimax=parameters%laim(k) + endif + + if(parameters%saim(k).ge.saimax)then + saimax=parameters%saim(k) + endif + + enddo + if (croptype == 0) then if ( dveg == 1 .or. dveg == 3 .or. dveg == 4 ) then @@ -1614,7 +1637,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in + elai ,esai ,laimax, saimax, fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in @@ -1709,6 +1732,8 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(in) :: cosz !cosine solar zenith angle (0-1) real (kind=kind_phys) , intent(in) :: elai !lai adjusted for burying by snow real (kind=kind_phys) , intent(in) :: esai !lai adjusted for burying by snow + real (kind=kind_phys) , intent(in) :: saimax !< monthly maximum stem area index, one-sided + real (kind=kind_phys) , intent(in) :: laimax !< monthly maximum leaf area index, one-sided real (kind=kind_phys) , intent(in) :: fwet !fraction of canopy that is wet [-] real (kind=kind_phys) , intent(in) :: fveg !greeness vegetation fraction (-) real (kind=kind_phys) , intent(in) :: shdfac !< green vegetation fraction [0.0-1.0] @@ -2039,7 +2064,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , fveg, & !in + lat ,z0m ,zlvl ,vegtyp , elai,laimax, & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2163,7 +2188,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in - fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + laimax, saimax,fwet ,laisun ,laisha ,cwp ,dzsnso , & !in zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in @@ -2429,7 +2454,7 @@ end subroutine energy subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , fveg,& !in + lat ,z0m ,zlvl ,vegtyp , elai, laimax,& !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out ! ------------------------------------------------------------------------------------------------- @@ -2454,8 +2479,9 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: lat !latitude (radians) real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) - integer , intent(in) :: vegtyp !vegtyp type - real (kind=kind_phys), intent(in) :: fveg !green vegetation fraction [0.0-1.0] + real (kind=kind_phys), intent(in) :: elai !lai adjusted for burying by snow + real (kind=kind_phys), intent(in) :: laimax !< monthly maximum leaf area index, one-sided + integer , intent(in) :: vegtyp !vegtyp type ! outputs real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] @@ -2504,7 +2530,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) - df(1) = df(1) * exp (sbeta * fveg) + df(1) = df(1) * exp (sbeta * elai/laimax) ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) @@ -3650,7 +3676,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in - fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + laimax, saimax,fwet ,laisun ,laisha ,cwp ,dzsnso , & !in zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in @@ -3706,6 +3732,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in) :: fsno !snow fraction real (kind=kind_phys), intent(in) :: snowh !actual snow depth [m] + real (kind=kind_phys), intent(in) :: saimax !< monthly maximum stem area index, one-sided + real (kind=kind_phys), intent(in) :: laimax !< monthly maximum leaf area index, one-sided real (kind=kind_phys), intent(in) :: fwet !wetted fraction of canopy real (kind=kind_phys), intent(in) :: cwp !canopy wind parameter @@ -4032,7 +4060,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp , & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,laimax,saimax,vegtyp, & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out @@ -4492,7 +4520,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.false. ,0.0 ,ivgtyp , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,4.5,1.4,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out @@ -5095,7 +5123,7 @@ end subroutine sfcdif2 !! compute surface drag coefficient cm for momentum and ch for heat. subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,vegetated,vaie ,vegtyp , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie,laimax,saimax,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf ,cm ,ch ) !out @@ -5126,6 +5154,8 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys), intent(in ) :: garea1 ! grid area [km2] logical, intent(in ) :: vegetated ! .true. if vegetated real (kind=kind_phys), intent(in ) :: vaie ! vegetation area index [m2/m2] + real (kind=kind_phys), intent(in ) :: saimax !< monthly maximum stem area index, one-sided + real (kind=kind_phys), intent(in ) :: laimax !< monthly maximum leaf area index, one-sided integer , intent(in ) :: vegtyp ! vegetation category real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity [m/s] real (kind=kind_phys), intent(inout) :: fm ! momentum stability correction, weighted by prior iters @@ -5207,7 +5237,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(fveg, 0.1_kind_phys) + tem2 = max(vaie/(laimax+saimax), 0.1_kind_phys) zvfun1 = sqrt(tem1 * tem2) gdx = sqrt(garea1) From 8e1b316051e6039101e8c3173a5af9dd2df63590 Mon Sep 17 00:00:00 2001 From: helin wei Date: Thu, 10 Mar 2022 19:11:01 +0000 Subject: [PATCH 15/35] simplify the code with internal function maxval --- physics/module_sf_noahmplsm.f90 | 56 ++++++++++----------------------- 1 file changed, 17 insertions(+), 39 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 7e17f511d..c945e66ff 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -683,8 +683,6 @@ subroutine noahmp_sflx (parameters, & ! add canopy heat storage (C.He added based on GY Niu's communication) real :: canhs ! canopy heat storage change w/m2 ! maximum lai/sai used for some parameterizations based on plant growthi - real (kind=kind_phys) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided ! intent (out) variables need to be assigned a value. these normally get assigned values @@ -736,7 +734,7 @@ subroutine noahmp_sflx (parameters, & ! vegetation phenology call phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , laimax, saimax, troot , elai , esai ,igs, pgs) + lai , sai , troot , elai , esai ,igs, pgs) !input gvf should be consistent with lai if(dveg == 1 .or. dveg == 6 .or. dveg == 7) then @@ -780,7 +778,7 @@ subroutine noahmp_sflx (parameters, & sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,laimax, saimax, fwet ,foln , & !in + elai ,esai ,fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in @@ -1059,7 +1057,7 @@ end subroutine atm !!vegetation phenology considering vegetation canopy being buried by snow and !!evolution in time. subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , laimax, saimax, troot , elai , esai , igs, pgs) + lai , sai , troot , elai , esai , igs, pgs) ! -------------------------------------------------------------------------------------------------- ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time @@ -1080,8 +1078,6 @@ subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yea real (kind=kind_phys) , intent(inout) :: sai !sai, unadjusted for burying by snow ! outputs - real (kind=kind_phys) , intent(out ) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys) , intent(out ) :: laimax !< monthly maximum leaf area index, one-sided real (kind=kind_phys) , intent(out ) :: elai !leaf area index, after burying by snow real (kind=kind_phys) , intent(out ) :: esai !stem area index, after burying by snow real (kind=kind_phys) , intent(out ) :: igs !growing season index (0=off, 1=on) @@ -1101,23 +1097,6 @@ subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yea real (kind=kind_phys) :: t !current month (1.00, ..., 12.00) ! -------------------------------------------------------------------------------------------------- -! derive monthly maximum lai and sai from monthly lai - - laimax=parameters%laim(1) - saimax=parameters%saim(1) - - do k=1,12 - - if(parameters%laim(k).ge.laimax)then - laimax=parameters%laim(k) - endif - - if(parameters%saim(k).ge.saimax)then - saimax=parameters%saim(k) - endif - - enddo - if (croptype == 0) then if ( dveg == 1 .or. dveg == 3 .or. dveg == 4 ) then @@ -1637,7 +1616,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,laimax, saimax, fwet ,foln , & !in + elai ,esai ,fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in @@ -1732,8 +1711,6 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(in) :: cosz !cosine solar zenith angle (0-1) real (kind=kind_phys) , intent(in) :: elai !lai adjusted for burying by snow real (kind=kind_phys) , intent(in) :: esai !lai adjusted for burying by snow - real (kind=kind_phys) , intent(in) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys) , intent(in) :: laimax !< monthly maximum leaf area index, one-sided real (kind=kind_phys) , intent(in) :: fwet !fraction of canopy that is wet [-] real (kind=kind_phys) , intent(in) :: fveg !greeness vegetation fraction (-) real (kind=kind_phys) , intent(in) :: shdfac !< green vegetation fraction [0.0-1.0] @@ -2064,7 +2041,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , elai,laimax, & !in + lat ,z0m ,zlvl ,vegtyp , elai, & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2188,7 +2165,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in - laimax, saimax,fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in @@ -2454,7 +2431,7 @@ end subroutine energy subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , elai, laimax,& !in + lat ,z0m ,zlvl ,vegtyp , elai, & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out ! ------------------------------------------------------------------------------------------------- @@ -2480,7 +2457,6 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) real (kind=kind_phys), intent(in) :: elai !lai adjusted for burying by snow - real (kind=kind_phys), intent(in) :: laimax !< monthly maximum leaf area index, one-sided integer , intent(in) :: vegtyp !vegtyp type ! outputs @@ -2498,6 +2474,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) real (kind=kind_phys), dimension( 1:nsoil) :: sice !soil ice content real (kind=kind_phys), parameter :: sbeta = -2.0 + real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided ! -------------------------------------------------------------------------------------------------- ! compute snow thermal conductivity and heat capacity @@ -2530,6 +2507,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) + laimax = maxval(parameters%laim) df(1) = df(1) * exp (sbeta * elai/laimax) ! compute lake thermal properties @@ -3676,7 +3654,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in - laimax, saimax,fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in @@ -3732,8 +3710,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in) :: fsno !snow fraction real (kind=kind_phys), intent(in) :: snowh !actual snow depth [m] - real (kind=kind_phys), intent(in) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys), intent(in) :: laimax !< monthly maximum leaf area index, one-sided real (kind=kind_phys), intent(in) :: fwet !wetted fraction of canopy real (kind=kind_phys), intent(in) :: cwp !canopy wind parameter @@ -4060,7 +4036,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,laimax,saimax,vegtyp, & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp, & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out @@ -4520,7 +4496,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,4.5,1.4,ivgtyp , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out @@ -5123,7 +5099,7 @@ end subroutine sfcdif2 !! compute surface drag coefficient cm for momentum and ch for heat. subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,vegetated,vaie,laimax,saimax,vegtyp , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf ,cm ,ch ) !out @@ -5154,8 +5130,6 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys), intent(in ) :: garea1 ! grid area [km2] logical, intent(in ) :: vegetated ! .true. if vegetated real (kind=kind_phys), intent(in ) :: vaie ! vegetation area index [m2/m2] - real (kind=kind_phys), intent(in ) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys), intent(in ) :: laimax !< monthly maximum leaf area index, one-sided integer , intent(in ) :: vegtyp ! vegetation category real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity [m/s] real (kind=kind_phys), intent(inout) :: fm ! momentum stability correction, weighted by prior iters @@ -5183,10 +5157,14 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys) :: sigmaa ! momentum partition parameter real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 + real (kind=kind_phys) :: saimax !< monthly maximum stem area index, one-sided + real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided ! ------------------------------------------------------------------------------------------------- fv = ustarx + laimax = maxval(parameters%laim) + saimax = maxval(parameters%saim) ! fv = ur*vkc/log((zlvl-zpd)/z0m) if(vegetated) then From 70507a0cdca6274e23943f9e96ac06750d7bf410 Mon Sep 17 00:00:00 2001 From: helin wei Date: Thu, 10 Mar 2022 22:23:34 +0000 Subject: [PATCH 16/35] to avoid exception floating point --- physics/module_sf_noahmplsm.f90 | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index c945e66ff..99b0cde7f 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -2507,8 +2507,12 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) - laimax = maxval(parameters%laim) - df(1) = df(1) * exp (sbeta * elai/laimax) + if(elai.gt.0.) then + laimax = maxval(parameters%laim) + laimax = min(laimax, 0.1) + + df(1) = df(1) * exp (sbeta * elai/laimax) + endif ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) @@ -5165,6 +5169,9 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur fv = ustarx laimax = maxval(parameters%laim) saimax = maxval(parameters%saim) + laimax = min(laimax, 0.1) + saimax = min(saimax, 0.1) + ! fv = ur*vkc/log((zlvl-zpd)/z0m) if(vegetated) then From d33598bb0079f56aeec3af97689fb24cb04049ba Mon Sep 17 00:00:00 2001 From: helin wei Date: Fri, 11 Mar 2022 16:28:53 +0000 Subject: [PATCH 17/35] revert the df1 change due to some negative impact on surface temperature --- physics/module_sf_noahmplsm.f90 | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 99b0cde7f..f9024c321 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -2041,7 +2041,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , elai, & !in + lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2431,7 +2431,7 @@ end subroutine energy subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , elai, & !in + lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out ! ------------------------------------------------------------------------------------------------- @@ -2456,7 +2456,6 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: lat !latitude (radians) real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) - real (kind=kind_phys), intent(in) :: elai !lai adjusted for burying by snow integer , intent(in) :: vegtyp !vegtyp type ! outputs @@ -2474,7 +2473,6 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) real (kind=kind_phys), dimension( 1:nsoil) :: sice !soil ice content real (kind=kind_phys), parameter :: sbeta = -2.0 - real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided ! -------------------------------------------------------------------------------------------------- ! compute snow thermal conductivity and heat capacity @@ -2507,12 +2505,6 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) - if(elai.gt.0.) then - laimax = maxval(parameters%laim) - laimax = min(laimax, 0.1) - - df(1) = df(1) * exp (sbeta * elai/laimax) - endif ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) From 3095d719239fbc804d632eeca711e7d5ed2680fd Mon Sep 17 00:00:00 2001 From: helin wei Date: Mon, 14 Mar 2022 21:06:18 +0000 Subject: [PATCH 18/35] correct the condition to avoid a divide by zero exception --- physics/module_sf_noahmplsm.f90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index f9024c321..1460e61f4 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -5151,7 +5151,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys) :: czil1 ! canopy based czil real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output real (kind=kind_phys) :: sigmaa ! momentum partition parameter - real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx + real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx,slaifrac real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 real (kind=kind_phys) :: saimax !< monthly maximum stem area index, one-sided real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided @@ -5161,8 +5161,12 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur fv = ustarx laimax = maxval(parameters%laim) saimax = maxval(parameters%saim) - laimax = min(laimax, 0.1) - saimax = min(saimax, 0.1) + + if(laimax+saimax .gt. 0) then + slaifrac=vaie/(laimax+saimax) + else + slaifrac=0.1_kind_phys + endif ! fv = ur*vkc/log((zlvl-zpd)/z0m) @@ -5214,7 +5218,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(vaie/(laimax+saimax), 0.1_kind_phys) + tem2 = max(slaifrac, 0.1_kind_phys) zvfun1 = sqrt(tem1 * tem2) gdx = sqrt(garea1) From 27ea849d8e88c70f6e3a1d014a0c85d0dd6ef2b9 Mon Sep 17 00:00:00 2001 From: helin wei Date: Tue, 15 Mar 2022 13:25:51 +0000 Subject: [PATCH 19/35] further refinement of the impact of vegetation on zvfun --- physics/module_sf_noahmplsm.f90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 1460e61f4..360536ec3 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -5164,6 +5164,8 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur if(laimax+saimax .gt. 0) then slaifrac=vaie/(laimax+saimax) + slaifrac=min(slaifrac,1.) + slaifrac=fveg*slaifrac else slaifrac=0.1_kind_phys endif From c722905e5240250ac7986624af0688f12737d8fb Mon Sep 17 00:00:00 2001 From: helin wei Date: Wed, 16 Mar 2022 03:20:38 +0000 Subject: [PATCH 20/35] replace shdfac by fveg for zvfun --- physics/module_sf_noahmplsm.f90 | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 360536ec3..ef022b4ee 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4032,7 +4032,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp, & !in + zpd ,snowh ,fveg ,garea1 ,.true. ,vaie ,vegtyp, & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out @@ -4492,7 +4492,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in + zpd ,snowh,fveg ,garea1 ,.false. ,0.0,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out @@ -5161,14 +5161,17 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur fv = ustarx laimax = maxval(parameters%laim) saimax = maxval(parameters%saim) - - if(laimax+saimax .gt. 0) then + if(dveg.eq.4 .or. dveg.eq.5) then + if(laimax+saimax .gt. 0 .and. fveg .gt. 0) then slaifrac=vaie/(laimax+saimax) slaifrac=min(slaifrac,1.) slaifrac=fveg*slaifrac else slaifrac=0.1_kind_phys endif + else + slaifrac=fveg + endif ! fv = ur*vkc/log((zlvl-zpd)/z0m) From 4284846e2110f9c6e6781de2c002ae35964f03a1 Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Fri, 18 Mar 2022 14:45:38 +0000 Subject: [PATCH 21/35] modify the eddy diffusivity for heat at the top of the canopy --- physics/module_sf_noahmplsm.f90 | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index ef022b4ee..6e59407bb 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -3828,6 +3828,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: fm !momentum stability correction, weighted by prior iters real (kind=kind_phys) :: fh !sen heat stability correction, weighted by prior iters real (kind=kind_phys) :: fhg !sen heat stability correction, ground + real (kind=kind_phys) :: fhgh !sen heat stability correction, canopy real (kind=kind_phys) :: hcan !canopy height (m) [note: hcan >= z0mg] real (kind=kind_phys) :: a !temporary calculation @@ -4048,7 +4049,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & call ragrb(parameters,iter ,vaie ,rhoair ,hg ,tah , & !in zpd ,z0mg ,z0hg ,hcan ,uc , & !in z0h ,fv ,cwp ,vegtyp ,mpe , & !in - tv ,mozg ,fhg ,iloc ,jloc , & !inout + tv ,mozg ,fhg ,fhgh ,iloc ,jloc , & !inout ramg ,rahg ,rawg ,rb ) !out ! es and d(es)/dt evaluated at tv @@ -4604,7 +4605,7 @@ end subroutine bare_flux subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in zpd ,z0mg ,z0hg ,hcan ,uc , & !in z0h ,fv ,cwp ,vegtyp ,mpe , & !in - tv ,mozg ,fhg ,iloc ,jloc , & !inout + tv ,mozg ,fhg ,fhgh ,iloc ,jloc , & !inout ramg ,rahg ,rawg ,rb ) !out ! -------------------------------------------------------------------------------------------------- ! compute under-canopy aerodynamic resistance rag and leaf boundary layer @@ -4638,6 +4639,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in real (kind=kind_phys), intent(inout) :: mozg !monin-obukhov stability parameter real (kind=kind_phys), intent(inout) :: fhg !stability correction + real (kind=kind_phys), intent(inout) :: fhgh !stability correction, canopy ! outputs real (kind=kind_phys) :: ramg !aerodynamic resistance for momentum (s/m) @@ -4652,29 +4654,36 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in real (kind=kind_phys) :: tmprah2 !temporary calculation for aerodynamic resistances real (kind=kind_phys) :: tmprb !temporary calculation for rb real (kind=kind_phys) :: molg,fhgnew,cwpc + real (kind=kind_phys) :: mozgh, fhgnewh ! -------------------------------------------------------------------------------------------------- ! stability correction to below canopy resistance mozg = 0. molg = 0. + mozgh = 0. if(iter > 1) then tmp1 = vkc * (grav/tah) * hg/(rhoair*cpair) if (abs(tmp1) .le. mpe) tmp1 = mpe molg = -1. * fv**3 / tmp1 mozg = min( (zpd-z0mg)/molg, 1.) + mozgh = min( (hcan - zpd)/molg, 1.) end if if (mozg < 0.) then fhgnew = (1. - 15.*mozg)**(-0.25) + fhgnewh = 0.74 * (1. - 9.*mozg)**(-0.5) ! PHIh else fhgnew = 1.+ 4.7*mozg + fhgnewh = 0.74 + 4.7*mozgh ! PHIh endif if (iter == 1) then fhg = fhgnew + fhgh = fhgnewh else fhg = 0.5 * (fhg+fhgnew) + fhgh = 0.5 * (fhgh+fhgnewh) endif cwpc = (cwp * vai * hcan * fhg)**0.5 @@ -4686,7 +4695,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in ! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. - kh = max ( vkc*fv*(hcan-zpd), mpe ) + kh = max ( vkc*fv*(hcan-zpd)/fhgh, mpe ) ramg = 0. rahg = tmprah2 / kh rawg = rahg From 4aa59df23cc99a6c523fa37785c399df946ae719 Mon Sep 17 00:00:00 2001 From: rongqian yang Date: Fri, 18 Mar 2022 19:10:49 +0000 Subject: [PATCH 22/35] Noah MP driver and meta changes for MYNN --- physics/sfc_noahmp_drv.F90 | 106 ++++++++++++++++++++++++++++++++++-- physics/sfc_noahmp_drv.meta | 53 ++++++++++++++++++ 2 files changed, 154 insertions(+), 5 deletions(-) diff --git a/physics/sfc_noahmp_drv.F90 b/physics/sfc_noahmp_drv.F90 index 0ebcbd615..a16534364 100644 --- a/physics/sfc_noahmp_drv.F90 +++ b/physics/sfc_noahmp_drv.F90 @@ -11,8 +11,12 @@ !> This module contains the CCPP-compliant NoahMP land surface model driver. module noahmpdrv + use module_sf_noahmplsm + implicit none + integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS + private public :: noahmpdrv_init, noahmpdrv_run, noahmpdrv_finalize @@ -27,6 +31,7 @@ module noahmpdrv !! subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & nlunit, pores, resid, & + do_mynnsfclay,do_mynnedmf, & errmsg, errflg) use machine, only: kind_phys @@ -40,6 +45,10 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & real (kind=kind_phys), dimension(:), intent(out) :: pores, resid + logical, intent(in) :: do_mynnsfclay + logical, intent(in) :: do_mynnedmf + + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -68,9 +77,31 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & return end if + if (.not. do_mynnsfclay .and. do_mynnedmf) then + errmsg = 'Problem : do_mynnsfclay = .false.' // & + 'but mynnpbl is .true.. Exiting ...' + errflg = 1 + return + end if + + if ( do_mynnsfclay .and. .not. do_mynnedmf) then + errmsg = 'Problem : do_mynnsfclay = .true.' // & + 'but mynnpbl is .false.. Exiting ...' + errflg = 1 + return + end if + + !--- initialize soil vegetation call set_soilveg(me, isot, ivegsrc, nlunit) + + ! initialize psih and psim + + if ( do_mynnsfclay ) then + call psi_init(psi_opt,errmsg,errflg) + endif + pores (:) = maxsmc (:) resid (:) = drysmc (:) @@ -107,7 +138,7 @@ subroutine noahmpdrv_run & ! --- inputs: ( im, km, lsnowl, itime, ps, u1, v1, t1, q1, soiltyp, & vegtype, sigmaf, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & - prsl1, prslk1, prslki, prsik1, zf, dry, wind, slopetyp, & + prsl1, prslk1, prslki, prsik1, zf,pblh, dry, wind, slopetyp, & shdmin, shdmax, snoalb, sfalb, flag_iter,con_g, & idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & @@ -120,6 +151,7 @@ subroutine noahmpdrv_run & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & canopy, trans, tsurf, zorl, & rb1, fm1, fh1, ustar1, stress1, fm101, fh21, & + rmol1,flhc1,flqc1,do_mynnsfclay, & ! --- Noah MP specific @@ -140,7 +172,7 @@ subroutine noahmpdrv_run & use funcphys, only : fpvs use sfc_diff, only : stability - use module_sf_noahmplsm +! use module_sf_noahmplsm use module_sf_noahmp_glacier use noahmp_tables, only : isice_table, co2_table, o2_table, & isurban_table, smcref_table, smcdry_table, & @@ -160,6 +192,8 @@ subroutine noahmpdrv_run & integer, parameter :: nsoil = 4 ! hardwired to Noah integer, parameter :: nsnow = 3 ! max. snow layers + integer, parameter :: iz0tlnd = 0 ! z0t treatment option + real(kind=kind_phys), save :: zsoil(nsoil) data zsoil / -0.1, -0.4, -1.0, -2.0 / @@ -193,6 +227,15 @@ subroutine noahmpdrv_run & real(kind=kind_phys), dimension(:) , intent(in) :: prsik1 ! Exner function at the ground surfac real(kind=kind_phys), dimension(:) , intent(in) :: zf ! height of bottom layer [m] + + logical , intent(in) :: do_mynnsfclay !flag for MYNN sfc layer scheme + + real(kind=kind_phys), dimension(:) , intent(in) :: pblh ! height of pbl + real(kind=kind_phys), dimension(:) , intent(inout) :: rmol1 ! + real(kind=kind_phys), dimension(:) , intent(inout) :: flhc1 ! + real(kind=kind_phys), dimension(:) , intent(inout) :: flqc1 ! + + logical , dimension(:) , intent(in) :: dry ! = T if a point with any land real(kind=kind_phys), dimension(:) , intent(in) :: wind ! wind speed [m/s] integer , dimension(:) , intent(in) :: slopetyp ! surface slope classification @@ -505,6 +548,16 @@ subroutine noahmpdrv_run & real (kind=kind_phys) :: prsik1x ! in exner function real (kind=kind_phys) :: prslk1x ! in exner function + real (kind=kind_phys) :: ch2 + real (kind=kind_phys) :: cq2 + real (kind=kind_phys) :: qfx + real (kind=kind_phys) :: wspd1 ! wind speed with all components + real (kind=kind_phys) :: pblhx ! height of pbl + + real (kind=kind_phys) :: rah_total ! + real (kind=kind_phys) :: cah_total ! + + ! ! --- local variable ! @@ -594,6 +647,8 @@ subroutine noahmpdrv_run & vwind_forcing = v1(i) area_grid = garea(i) + pblhx = pblh(i) + prslkix = prslki(i) prsik1x = prsik1(i) prslk1x = prslk1(i) @@ -725,7 +780,8 @@ subroutine noahmpdrv_run & spec_humidity_forcing,sw_radiation_forcing ,precipitation_forcing,radiation_lw_forcing , & temperature_soil_bot ,forcing_height ,snow_ice_frac_old ,zsoil , & thsfc_loc ,prslkix ,prsik1x ,prslk1x , & - vegetation_frac ,area_grid , & + air_pressure_surface ,pblhx ,iz0tlnd ,itime , & + vegetation_frac ,area_grid ,psi_opt , & snowfall ,snow_water_equiv_old ,snow_albedo_old , & cm_noahmp ,ch_noahmp ,snow_levels ,snow_water_equiv , & soil_moisture_vol ,interface_depth ,snow_depth ,snow_level_ice , & @@ -804,6 +860,8 @@ subroutine noahmpdrv_run & spec_humidity_forcing ,area_grid ,cloud_water_forcing , & sw_radiation_forcing ,radiation_lw_forcing ,thsfc_loc , & prslkix ,prsik1x ,prslk1x , & + pblhx ,iz0tlnd ,itime , & + psi_opt , & precip_convective , & precip_non_convective ,precip_sh_convective ,precip_snow , & precip_graupel ,precip_hail ,temperature_soil_bot , & @@ -923,7 +981,7 @@ subroutine noahmpdrv_run & snowc (i) = snow_cover_fraction sncovr1 (i) = snow_cover_fraction - qsurf (i) = spec_humidity_surface +! qsurf (i) = spec_humidity_surface tsurf (i) = tskin(i) tvxy (i) = temperature_leaf @@ -986,11 +1044,49 @@ subroutine noahmpdrv_run & zvfun(i) = sqrt(tem1 * tem2) gdx=sqrt(garea(i)) + if ( .not. do_mynnsfclay) then !GFS sfcdiff + call stability & (zf(i), zvfun(i), gdx, virtual_temperature, vptemp,wind(i), z0_total, z0h_total, & tvs1, con_g, thsfc_loc, & rb1(i), fm1(i), fh1(i), fm101(i), fh21(i), cm(i), ch(i), stress1(i), ustar1(i)) + rmol1(i) = undefined !not used in GFS sfcdif -> to satsify output + flhc1(i) = undefined + flqc1(i) = undefined + + rah_total = max(1.0,1.0/( ch(i)*wind(i)) ) + cah_total = density * con_cp /rah_total +! tskin(i) = sensible_heat_total/cah_total + temperature_forcing ! test to use combined ch and SH to backout Ts + + ch(i) = ch_vegetated * vegetation_frac + ch_bare_ground*(1.0-vegetation_frac) + + else ! MYNN - note the GFS option is the same as sfcdif3; so removed. + + qfx = evap(i) / con_hvap ! use flux from output + + call sfcdif4(i_location ,j_location ,uwind_forcing ,vwind_forcing , & + temperature_forcing, air_pressure_forcing ,air_pressure_surface , & + pblhx,gdx,z0_total,itime,snwdph(i),0,psi_opt,surface_temperature, & + spec_humidity_forcing,forcing_height,iz0tlnd,spec_humidity_surface,& + sensible_heat_total,qfx,cm(i),ch(i),ch2,cq2,rmol1(i),ustar1(i), & + rb1(i),fm1(i),fh1(i),stress1(i),fm101(i),fh21(i),wspd1,flhc1(i), & + flqc1(i) ) + + ch(i)=ch(i)/wspd1 + cm(i)=cm(i)/wspd1 + + ch(i) = ch_vegetated * vegetation_frac + ch_bare_ground*(1.0-vegetation_frac) + + rah_total = max(1.0,1.0/( ch(i)*wind(i)) ) + cah_total = density * con_cp /rah_total + +! tskin(i) = sensible_heat_total/cah_total + temperature_forcing ! + + endif + + + cmxy(i) = cm(i) chxy(i) = ch(i) @@ -998,7 +1094,7 @@ subroutine noahmpdrv_run & cmm (i) = cmxy(i) * wind(i) snwdph (i) = snow_depth * 1000.0 ! convert from m to mm; wait after the stability call -! qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) + qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) ! ! --- change units for output diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 1246fa1b0..9ad9092ec 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -65,6 +65,20 @@ type = real intent = out kind = kind_phys +[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 +[do_mynnedmf] + standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -271,6 +285,14 @@ type = real kind = kind_phys intent = in +[pblh] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [dry] standard_name = flag_nonzero_land_surface_fraction long_name = flag indicating presence of some land surface area fraction @@ -741,6 +763,37 @@ type = real kind = kind_phys intent = inout +[rmol1] + standard_name = reciprocal_of_obukhov_length + long_name = one over obukhov length + units = m-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[flhc1] + standard_name = surface_exchange_coefficient_for_heat + long_name = surface exchange coefficient for heat + units = W m-2 K-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[flqc1] + standard_name = surface_exchange_coefficient_for_moisture + long_name = surface exchange coefficient for moisture + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[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 [snowxy] standard_name = number_of_snow_layers long_name = number of snow layers From c58e8492ddd6ee76b85a66ddbddd10d7dc3db76c Mon Sep 17 00:00:00 2001 From: rongqian yang Date: Fri, 18 Mar 2022 19:12:25 +0000 Subject: [PATCH 23/35] Noah MP glacier changes for MYNN --- physics/module_sf_noahmp_glacier.f90 | 101 +++++++++++++++++++++++++-- 1 file changed, 97 insertions(+), 4 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index c4c03aaf8..997166744 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -7,6 +7,7 @@ module noahmp_glacier_globals use machine , only : kind_phys use sfc_diff, only : stability + use module_sf_noahmplsm, only : sfcdif4 implicit none @@ -122,7 +123,9 @@ subroutine noahmp_glacier (& iloc ,jloc ,cosz ,nsnow ,nsoil ,dt , & ! in : time/space/model-related sfctmp ,sfcprs ,uu ,vv ,q2 ,soldn , & ! in : forcing prcp ,lwdn ,tbot ,zlvl ,ficeold ,zsoil , & ! in : forcing - thsfc_loc ,prslkix ,prsik1x ,prslk1x ,sigmaf1 ,garea1 , & ! in : + thsfc_loc ,prslkix ,prsik1x ,prslk1x , & + psfc ,pblhx ,iz0tlnd ,itime , & + sigmaf1 ,garea1 ,psi_opt , & ! in : qsnow ,sneqvo ,albold ,cm ,ch ,isnow , & ! in/out : sneqv ,smc ,zsnso ,snowh ,snice ,snliq , & ! in/out : tg ,stc ,sh2o ,tauss ,qsfc , & ! in/out : @@ -149,6 +152,8 @@ subroutine noahmp_glacier (& real (kind=kind_phys) , intent(in) :: cosz !< cosine solar zenith angle [0-1] integer , intent(in) :: nsnow !< maximum no. of snow layers integer , intent(in) :: nsoil !< no. of soil layers + integer , intent(in) :: psi_opt + real (kind=kind_phys) , intent(in) :: dt !< time step [sec] real (kind=kind_phys) , intent(in) :: sfctmp !< surface air temperature [k] real (kind=kind_phys) , intent(in) :: sfcprs !< pressure (pa) @@ -166,6 +171,12 @@ subroutine noahmp_glacier (& real (kind=kind_phys) , intent(in) :: prslkix !< pressure (pa) real (kind=kind_phys) , intent(in) :: prsik1x !< pressure (pa) real (kind=kind_phys) , intent(in) :: prslk1x !< pressure (pa) + + real (kind=kind_phys) , intent(in) :: psfc ! surface pressure + real (kind=kind_phys) , intent(in) :: pblhx ! pbl height + integer , intent(in) :: iz0tlnd ! + integer , intent(in) :: itime !< timestep + real (kind=kind_phys) , intent(in) :: sigmaf1 !< areal fractional cover of green vegetation real (kind=kind_phys) , intent(in) :: garea1 !< area of the grid cell @@ -274,6 +285,7 @@ subroutine noahmp_glacier (& vv ,solad ,solai ,cosz ,zlvl , & !in tbot ,zbot ,zsnso ,dzsnso ,sigmaf1 ,garea1 , & !in thsfc_loc ,prslkix ,prsik1x ,prslk1x , & !in + psfc ,pblhx ,iz0tlnd ,itime ,psi_opt , & tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout #ifdef CCPP @@ -405,6 +417,7 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair vv ,solad ,solai ,cosz ,zref , & !in tbot ,zbot ,zsnso ,dzsnso ,sigmaf1 ,garea1 , & !in thsfc_loc ,prslkix ,prsik1x ,prslk1x , & !in + psfc ,pblhx ,iz0tlnd ,itime ,psi_opt , & tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout #ifdef CCPP @@ -427,6 +440,8 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair ! inputs integer , intent(in) :: nsnow !< maximum no. of snow layers integer , intent(in) :: nsoil !< number of soil layers + integer , intent(in) :: psi_opt + integer , intent(in) :: isnow !< actual no. of snow layers real (kind=kind_phys) , intent(in) :: dt !< time step [sec] real (kind=kind_phys) , intent(in) :: qsnow !< snowfall on the ground (mm/s) @@ -451,6 +466,12 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair real (kind=kind_phys) , intent(in) :: prslkix ! in exner function real (kind=kind_phys) , intent(in) :: prsik1x ! in exner function real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function + + real (kind=kind_phys) , intent(in) :: pblhx !< PBL height (m) + real (kind=kind_phys) , intent(in) :: psfc !< surface pressure + integer , intent(in) :: iz0tlnd !< z0t option + integer , intent(in) :: itime !< integration time + real (kind=kind_phys) , intent(in) :: sigmaf1 !< areal fractional cover of green vegetation real (kind=kind_phys) , intent(in) :: garea1 !< area of the grid cell @@ -561,7 +582,9 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in - thsfc_loc ,prslkix ,prsik1x ,prslk1x ,sigmaf1 ,garea1 , & !in + thsfc_loc ,prslkix ,prsik1x ,prslk1x , & + psfc ,pblhx ,iz0tlnd ,itime ,uu ,vv , & + sigmaf1 ,garea1 ,psi_opt , & !in #ifdef CCPP cm ,ch ,tg ,qsfc ,errmsg ,errflg , & !inout #else @@ -997,7 +1020,9 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in - thsfc_loc ,prslkix ,prsik1x ,prslk1x ,sigmaf1 ,garea1 , & !in + thsfc_loc ,prslkix ,prsik1x ,prslk1x , & + psfc ,pblhx ,iz0tlnd ,itime ,uu ,vv , & + sigmaf1 ,garea1 ,psi_opt , & !in #ifdef CCPP cm ,ch ,tgb ,qsfc ,errmsg ,errflg , & !inout #else @@ -1020,6 +1045,8 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ! input integer, intent(in) :: nsnow !< maximum no. of snow layers integer, intent(in) :: nsoil !< number of soil layers + integer, intent(in) :: psi_opt + real (kind=kind_phys), intent(in) :: emg !< ground emissivity integer, intent(in) :: isnow !< actual no. of snow layers real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: df !< thermal conductivity of snow/soil (w/m/k) @@ -1048,6 +1075,14 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso real (kind=kind_phys), intent(in) :: prslkix ! in exner function real (kind=kind_phys), intent(in) :: prsik1x ! in exner function real (kind=kind_phys), intent(in) :: prslk1x ! in exner function + + real (kind=kind_phys) , intent(in) :: pblhx !< + real (kind=kind_phys) , intent(in) :: psfc !< + integer , intent(in) :: iz0tlnd !< + integer , intent(in) :: itime !< integration time + real (kind=kind_phys) , intent(in) :: uu !< + real (kind=kind_phys) , intent(in) :: vv !< + real (kind=kind_phys), intent(in) :: sigmaf1 ! real (kind=kind_phys), intent(in) :: garea1 ! @@ -1095,11 +1130,19 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso integer :: iter !< iteration index real (kind=kind_phys) :: z0h !< roughness length, sensible heat, ground (m) + real (kind=kind_phys) :: qfx + real (kind=kind_phys) :: cq2 !< surface exchange at 2m + + real(kind=kind_phys) :: rb1i ! bulk richardson # real(kind=kind_phys) :: fm10i ! fm10 over land ice real(kind=kind_phys) :: stress1i! wind stress m2 S-2 + real(kind=kind_phys) :: wspd1i + real(kind=kind_phys) :: flhc1i + real(kind=kind_phys) :: flqc1i + real(kind=kind_phys) :: tv1i ! virtual potential temp @ ref level real(kind=kind_phys) :: thv1i ! virtual potential temp @ ref level @@ -1149,6 +1192,10 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso h = 0. + fh2 = 0. + qfx = 0. + + ! the following only applies to opt_sfc =3, opt_sfc = 1 still done its old way snwd = snowh*1000.0 @@ -1194,8 +1241,10 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso tem2 = max(sigmaf1, 0.1_kind_phys) zvfun1= sqrt(tem1 * tem2) gdx=sqrt(garea1) - if(opt_sfc == 1 .or. opt_sfc == 2) then !Add option for sfc scheme,use '1' for both '1'/'2' + + if(opt_sfc == 1 .or. opt_sfc == 2 .or. opt_sfc == 4) then !Add option for sfc scheme,use '1' for both '1'/'2' loop3: do iter = 1, niterb ! begin stability iteration + if(opt_sfc == 1 .or. opt_sfc == 2) then ! for now, only allow sfcdif1 until others can be fixed @@ -1211,8 +1260,45 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso #ifdef CCPP if (errflg /= 0) return #endif + endif + + if(opt_sfc == 4) then + + call sfcdif4(1 ,1 ,uu ,vv ,sfctmp , & !allow location for use in the driver + sfcprs ,psfc ,pblhx ,gdx ,z0m , & + itime ,snwd ,1 ,psi_opt, & + tgb ,qair ,zlvl ,iz0tlnd,qsfc , & ! use zlvli? + h ,qfx ,cm ,ch ,ch2 , & ! ch2 = cq2 most of times + cq2 ,moz ,fv ,rb1i, fm, fh, & + stress1i,fm10i ,fh2 , wspd1i ,flhc1i ,flqc1i) ! some are for use in the driver call + + + ! Undo the multiplication by windspeed that SFCDIF4 + ! applies to exchange coefficients CH and CM: + + ch = ch / wspd1i + cm = cm / wspd1i + ch2 = ch2 / wspd1i + cq2 = cq2 / wspd1i + + if(snwd > 0.) then + cm = min(0.01,cm) + ch = min(0.01,ch) + ch2 = min(0.01,ch2) + cq2 = min(0.01,cq2) + end if + + endif ! 4 + + ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) + + if(opt_sfc == 4) then + ramb = max(1.,1./(cm*wspd1i) ) + rahb = max(1.,1./(ch*wspd1i) ) + endif + rawb = rahb ! es and d(es)/dt evaluated at tg @@ -1264,6 +1350,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso estg = esati end if qsfc = 0.622*(estg*rhsur)/(sfcprs-0.378*(estg*rhsur)) + qfx = (qsfc-qair)*cev*gamma/cpair end do loop3 ! end stability iteration end if @@ -1362,6 +1449,12 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ! 2m air temperature ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) cq2b = ehb2 + + if (opt_sfc == 4) then + ehb2 = ch2 * wspd1i ! need conductance,z0h from sfcdif4 + cq2b = cq2 * wspd1i ! conductance + endif + if (ehb2.lt.1.e-5 ) then t2mb = tgb q2b = qsfc From 56142b2ed549b57a02b165797ddc67161a1548ba Mon Sep 17 00:00:00 2001 From: rongqian yang Date: Fri, 18 Mar 2022 19:14:16 +0000 Subject: [PATCH 24/35] Noah MP non-glacier changes for MYNN --- physics/module_sf_noahmplsm.f90 | 1436 ++++++++++++++++++++++++++++++- 1 file changed, 1403 insertions(+), 33 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index ef022b4ee..09faf0e05 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -10,10 +10,22 @@ module module_sf_noahmplsm use machine , only : kind_phys use sfc_diff, only : stability + use physcons, only : rcp => con_rocp, & + & ep_1 => con_fvirt, & + & ep_2 => con_eps, & + & r_d => con_rd, & + & cp => con_cp, & + & g => con_g, & + & xlv => con_hvap + + implicit none public :: noahmp_options public :: noahmp_sflx + public :: sfcdif4 + public :: psi_init + private :: atm private :: phenology @@ -373,6 +385,32 @@ module module_sf_noahmplsm end type noahmp_parameters +! +! for sfcdif4 +! + real, parameter :: prt=1. !prandtl number + real, parameter :: p1000mb = 100000. + + real, parameter :: svp1 = 0.6112 + real, parameter :: svp2 = 17.67 + real, parameter :: svp3 = 29.65 + real, parameter :: svpt0 = 273.15 + real, parameter :: ep_3=1.-ep_2 + real, parameter :: ep2=ep_2 + real, parameter :: onethird = 1./3. + real, parameter :: sqrt3 = 1.7320508075688773 + real, parameter :: atan1 = 0.785398163397 !in radians + + real, parameter :: karman = 0.4 + real, parameter :: vconvc=1.25 + + real, parameter :: snowz0 = 0.011 + real, parameter :: wmin = 0.1 + + real, dimension(0:1000 ),save :: psim_stab,psim_unstab, & + psih_stab,psih_unstab + + contains ! !== begin noahmp_sflx ============================================================================== @@ -385,6 +423,7 @@ subroutine noahmp_sflx (parameters, & smceq , & ! in : vegetation/soil characteristics sfctmp , sfcprs , psfc , uu , vv , q2, garea1 , & ! in : forcing qc , soldn , lwdn,thsfc_loc, prslkix,prsik1x,prslk1x,& ! in : forcing + pblhx , iz0tlnd , itime ,psi_opt ,& prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing tbot , co2air , o2air , foln , ficeold , zlvl , & ! in : forcing albold , sneqvo , & ! in/out : @@ -448,6 +487,11 @@ subroutine noahmp_sflx (parameters, & real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function real (kind=kind_phys) , intent(in) :: garea1 ! in exner function + real (kind=kind_phys) , intent(in) :: pblhx ! pbl height + integer , intent(in) :: iz0tlnd !< z0t option + integer , intent(in) :: itime !< + integer , intent(in) :: psi_opt !< + real (kind=kind_phys) , intent(inout) :: zlvl !< reference height (m) real (kind=kind_phys) , intent(in) :: cosz !< cosine solar zenith angle [0-1] real (kind=kind_phys) , intent(in) :: tbot !< bottom condition for soil temp. [k] @@ -682,8 +726,6 @@ subroutine noahmp_sflx (parameters, & logical :: crop_active !< flag to run crop model ! add canopy heat storage (C.He added based on GY Niu's communication) real :: canhs ! canopy heat storage change w/m2 -! maximum lai/sai used for some parameterizations based on plant growthi - ! intent (out) variables need to be assigned a value. these normally get assigned values ! only if dveg == 2. @@ -734,7 +776,7 @@ subroutine noahmp_sflx (parameters, & ! vegetation phenology call phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai ,igs, pgs) + lai , sai , troot , elai , esai ,igs, pgs) !input gvf should be consistent with lai if(dveg == 1 .or. dveg == 6 .or. dveg == 7) then @@ -778,10 +820,11 @@ subroutine noahmp_sflx (parameters, & sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in + elai ,esai ,fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in + pblhx ,iz0tlnd, itime ,psi_opt, & z0wrf ,z0hwrf , & !out imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out @@ -1057,7 +1100,7 @@ end subroutine atm !!vegetation phenology considering vegetation canopy being buried by snow and !!evolution in time. subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai , igs, pgs) + lai , sai , troot , elai , esai , igs, pgs) ! -------------------------------------------------------------------------------------------------- ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time @@ -1616,10 +1659,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in + elai ,esai ,fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in + pblhx , iz0tlnd, itime,psi_opt, & z0wrf ,z0hwrf , & !out imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out @@ -1700,6 +1744,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function real (kind=kind_phys) , intent(in) :: garea1 + real (kind=kind_phys) , intent(in) :: pblhx ! pbl height + integer , intent(in) :: iz0tlnd + integer , intent(in) :: itime + integer , intent(in) :: psi_opt + real (kind=kind_phys) , intent(in) :: qair !specific humidity (kg/kg) real (kind=kind_phys) , intent(in) :: sfctmp !air temperature (k) real (kind=kind_phys) , intent(in) :: thair !potential temperature (k) @@ -2041,7 +2090,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , & !in + lat ,z0m ,zlvl ,vegtyp , fveg, & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2173,6 +2222,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in + pblhx ,iz0tlnd ,itime ,psi_opt , & eah ,tah ,tv ,tgv ,cmv, ustarx , & !inout #ifdef CCPP chv ,dx ,dz8w ,errmsg ,errflg , & !inout @@ -2209,6 +2259,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in emg ,stc ,df ,rsurf ,latheag , & !in gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in + pblhx ,iz0tlnd ,itime ,psi_opt , & #ifdef CCPP tgb ,cmb ,chb, ustarx,errmsg ,errflg , & !inout #else @@ -2261,6 +2312,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc q2e = fveg * q2v + (1.0 - fveg) * q2b +! effectibe skin temperature + + ts = (fveg*chv*tah + (1.0-fveg)*chb*tgb ) / ch + + ! new coupling code if (opt_trs == 1) then @@ -2431,7 +2487,7 @@ end subroutine energy subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , & !in + lat ,z0m ,zlvl ,vegtyp , fveg,& !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out ! ------------------------------------------------------------------------------------------------- @@ -2456,7 +2512,8 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: lat !latitude (radians) real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) - integer , intent(in) :: vegtyp !vegtyp type + integer , intent(in) :: vegtyp !vegtyp type + real (kind=kind_phys), intent(in) :: fveg !green vegetation fraction [0.0-1.0] ! outputs real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] @@ -2505,6 +2562,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) + df(1) = df(1) * exp (sbeta * fveg) ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) @@ -3650,7 +3708,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in - fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in @@ -3658,6 +3716,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in + pblhx ,iz0tlnd ,itime ,psi_opt , & eah ,tah ,tv ,tg ,cm,ustarx,& !inout #ifdef CCPP ch ,dx ,dz8w ,errmsg ,errflg , & !inout @@ -3705,6 +3764,12 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in) :: dt !time step (s) real (kind=kind_phys), intent(in) :: fsno !snow fraction + real (kind=kind_phys) , intent(in) :: pblhx ! pbl height + integer , intent(in) :: iz0tlnd + integer , intent(in) :: itime + integer , intent(in) :: psi_opt + + real (kind=kind_phys), intent(in) :: snowh !actual snow depth [m] real (kind=kind_phys), intent(in) :: fwet !wetted fraction of canopy real (kind=kind_phys), intent(in) :: cwp !canopy wind parameter @@ -3788,6 +3853,10 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: wspd ! ------------------------ local variables ---------------------------------------------------- + real (kind=kind_phys) :: gdx !grid dx + real (kind=kind_phys) :: snwd ! snowdepth in mm + integer :: mnice ! MYNN ice flag + real (kind=kind_phys) :: cw !water vapor exchange coefficient real (kind=kind_phys) :: fv !friction velocity (m/s) real (kind=kind_phys) :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2) @@ -3850,6 +3919,15 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: ch2 !surface exchange at 2m real (kind=kind_phys) :: thstar !surface exchange at 2m + real (kind=kind_phys) :: fm10 + real (kind=kind_phys) :: rb1v + real (kind=kind_phys) :: stress1v + + + real (kind=kind_phys) :: flhcv ! for MYNN + real (kind=kind_phys) :: flqcv ! for MYNN + real (kind=kind_phys) :: wspdv ! for MYNN + real (kind=kind_phys) :: thvair real (kind=kind_phys) :: thah real (kind=kind_phys) :: rahc2 !aerodynamic resistance for sensible heat (s/m) @@ -3979,6 +4057,16 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 cir = (2.-emv*(1.-emg))*emv*sb +! + gdx = sqrt(garea1) + snwd = snowh * 1000.0 + + if (snowh .gt. 0.1) then + mnice = 1 + else + mnice = 0 + endif + ! --------------------------------------------------------------------------------------------- loop1: do iter = 1, niterc ! begin stability iteration @@ -4032,14 +4120,41 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,.true. ,vaie ,vegtyp, & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out endif + if(opt_sfc == 4) then + + call sfcdif4(iloc ,jloc ,uu ,vv ,sfctmp , & + sfcprs ,psfc ,pblhx ,gdx ,z0m , & + itime ,snwd ,mnice ,psi_opt, & + tah ,qair ,zlvl ,iz0tlnd,qsfc , & + h ,qfx ,cm ,ch ,ch2v , & + cq2v ,moz ,fv ,rb1v, fm, fh, & + stress1v,fm10 ,fh2 ,wspdv ,flhcv ,flqcv) + + + ! Undo the multiplication by windspeed that SFCDIF4 + ! applies to exchange coefficients CH and CM + + ch = ch / wspdv + cm = cm / wspdv + ch2v = ch2v / wspdv + + endif + + ramc = max(1.,1./(cm*ur)) rahc = max(1.,1./(ch*ur)) + + if (opt_sfc == 4 ) then + ramc = max(1.,1./(cm*wspdv) ) + rahc = max(1.,1./(ch*wspdv) ) + endif + rawc = rahc ! aerodyn resistance between heights z0g and d+z0v, rag, and leaf @@ -4149,6 +4264,11 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! consistent specific humidity from canopy air vapor pressure qsfc = (0.622*eah)/(sfcprs-0.378*eah) + if ( opt_sfc == 4 ) then + qfx = (qsfc-qair)*rhoair*caw + endif + + if (liter == 1) then exit loop1 endif @@ -4228,6 +4348,15 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & cah2 = fv*vkc/log((2.+z0h)/z0h) cah2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) cq2v = cah2 + endif + + if (opt_sfc == 4 ) then + rahc2 = max(1.,1./(ch2v*wspdv)) + rawc2 = rahc2 + cah2 = 1./rahc2 + cq2v = 1./max(1.,1./(cq2v*wspdv)) + endif + if (cah2 .lt. 1.e-5 ) then t2mv = tah ! q2v = (eah*0.622/(sfcprs - 0.378*eah)) @@ -4237,7 +4366,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! q2v = (eah*0.622/(sfcprs - 0.378*eah))- qfx/(rhoair*fv)* 1./vkc * log((2.+z0h)/z0h) q2v = qsfc - ((evc+tr)/fveg+evg)/(latheav*rhoair) * 1./cq2v endif - endif ! update ch for output ch = cah @@ -4258,6 +4386,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & emg ,stc ,df ,rsurf ,lathea , & !in gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in + pblhx , iz0tlnd , itime ,psi_opt ,& #ifdef CCPP tgb ,cm ,ch,ustarx,errmsg ,errflg , & !inout #else @@ -4310,6 +4439,12 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) real (kind=kind_phys), intent(in) :: fsno !snow fraction + real (kind=kind_phys), intent(in) :: pblhx !pbl height (m) + integer, intent(in) :: iz0tlnd + integer, intent(in) :: itime + integer, intent(in) :: psi_opt + + !jref:start; in integer , intent(in) :: ivgtyp real (kind=kind_phys) , intent(in) :: qc !cloud water mixing ratio @@ -4351,6 +4486,19 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! local variables + real (kind=kind_phys) :: gdx !grid dx + real (kind=kind_phys) :: snwd ! snowdepth in mm + integer :: mnice ! MYNN ice flag + + real (kind=kind_phys) :: fm10 + real (kind=kind_phys) :: rb1b + real (kind=kind_phys) :: stress1b + + real (kind=kind_phys) :: wspdb + real (kind=kind_phys) :: flhcb + real (kind=kind_phys) :: flqcb +! + real (kind=kind_phys) :: taux !wind stress: e-w (n/m2) real (kind=kind_phys) :: tauy !wind stress: n-s (n/m2) real (kind=kind_phys) :: fira !total net longwave rad (w/m2) [+ to atm] @@ -4449,6 +4597,15 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & cir = emg*sb cgh = 2.*df(isnow+1)/dzsnso(isnow+1) + gdx = sqrt(garea1) + snwd = snowh * 1000.0 + + if (snowh .gt. 0.1) then + mnice = 1 + else + mnice = 0 + endif + ! ----------------------------------------------------------------- loop3: do iter = 1, niterb ! begin stability iteration @@ -4492,14 +4649,47 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh,fveg ,garea1 ,.false. ,0.0,ivgtyp , & !in + zpd ,snowh ,shdfac ,garea1 ,.false. ,0.0 ,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out endif + if(opt_sfc == 4) then + + call sfcdif4(iloc ,jloc ,uu ,vv ,sfctmp , & + sfcprs ,psfc ,pblhx ,gdx ,z0m , & + itime ,snwd ,mnice ,psi_opt , & + tgb ,qair ,zlvl ,iz0tlnd,qsfc , & + h ,qfx ,cm ,ch ,ch2b , & + cq2b ,moz ,fv ,rb1b, fm, fh , & + stress1b,fm10 ,fh2 , wspdb ,flhcb ,flqcb) + + ! Undo the multiplication by windspeed that SFCDIF4 + ! applies to exchange coefficients CH and CM: + + ch = ch / wspdb + cm = cm / wspdb + ch2b = ch2b / wspdb + cq2b = cq2b / wspdb + + if(snwd > 0.) then + cm = min(0.01,cm) + ch = min(0.01,ch) + ch2b = min(0.01,ch2b) + cq2b = min(0.01,cq2b) + end if + + endif ! 4 + ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) + + if(opt_sfc == 4) then + ramb = max(1.,1./(cm*wspdb) ) + rahb = max(1.,1./(ch*wspdb) ) + endif + rawb = rahb !jref - variables for diagnostics @@ -4581,6 +4771,13 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ehb2 = fv*vkc/log((2.+z0h)/z0h) ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) cq2b = ehb2 + endif + + if(opt_sfc == 4) then + ehb2 = 1. /(max(1.,1./ch2b*wspdb)) + cq2b = 1. /(max(1.,1./cq2b*wspdb)) + endif + if (ehb2.lt.1.e-5 ) then t2mb = tgb q2b = qsfc @@ -4589,7 +4786,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) endif if (parameters%urban_flag) q2b = qsfc - end if ! update ch ch = ehb @@ -5095,7 +5291,7 @@ end subroutine sfcdif2 !! compute surface drag coefficient cm for momentum and ch for heat. subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,vegetated,vaie,vegtyp , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie ,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf ,cm ,ch ) !out @@ -5151,28 +5347,12 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys) :: czil1 ! canopy based czil real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output real (kind=kind_phys) :: sigmaa ! momentum partition parameter - real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx,slaifrac + real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 - real (kind=kind_phys) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided ! ------------------------------------------------------------------------------------------------- fv = ustarx - laimax = maxval(parameters%laim) - saimax = maxval(parameters%saim) - if(dveg.eq.4 .or. dveg.eq.5) then - if(laimax+saimax .gt. 0 .and. fveg .gt. 0) then - slaifrac=vaie/(laimax+saimax) - slaifrac=min(slaifrac,1.) - slaifrac=fveg*slaifrac - else - slaifrac=0.1_kind_phys - endif - else - slaifrac=fveg - endif - ! fv = ur*vkc/log((zlvl-zpd)/z0m) if(vegetated) then @@ -5223,7 +5403,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(slaifrac, 0.1_kind_phys) + tem2 = max(fveg, 0.1_kind_phys) zvfun1 = sqrt(tem1 * tem2) gdx = sqrt(garea1) @@ -9757,5 +9937,1195 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc end subroutine noahmp_options + subroutine sfcdif4(iloc ,jloc ,ux ,vx ,t1d , & + p1d ,psfcpa,pblhx ,dx ,znt , & + itime ,snwh ,isice ,psi_opt, & + tsk ,qx ,zlvl ,iz0tlnd,qsfc , & + hfx ,qfx ,cm ,chs ,chs2 , & + cqs2 , & + rmolx ,ust , rbx, fmx, fhx,stressx,& + fm10x, fh2x, wspdx,flhcx,flqcx) + + + +!------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------- + +! input + + integer,intent(in ) :: iloc + integer,intent(in ) :: jloc + integer, intent(in) :: itime + + integer, intent(in) :: psi_opt + + integer, intent(in) :: isice ! for the glacier/snowh > 0.1m + + real, intent(in ) :: pblhx ! planetary boundary layer height + real, intent(in ) :: tsk ! skin temperature + real, intent(in ) :: psfcpa ! pressure in pascal + real, intent(in ) :: p1d !lowest model layer pressure (pa) + real, intent(in ) :: t1d !lowest model layer temperature + real, intent(in ) :: qx !water vapor specific humidity (kg/kg) from input + real, intent(in ) :: zlvl ! thickness of lowest full level layer + real, intent(in ) :: hfx ! sensible heat flux + real, intent(in ) :: qfx ! moisture flux + real, intent(in ) :: dx ! horisontal grid spacing + real, intent(in ) :: ux ! u and v winds + real, intent(in ) :: vx + real, intent(in ) :: znt ! z0m in m or inout + real, intent(in ) :: snwh ! in mm + +! optional vars + + integer,optional,intent(in ) :: iz0tlnd + + real, intent(inout) :: qsfc + real, intent(inout) :: ust + real, intent(inout) :: chs + real, intent(inout) :: chs2 + real, intent(inout) :: cqs2 + real, intent(inout) :: cm + + real, intent(inout) :: rmolx + real, intent(inout) :: rbx + real, intent(inout) :: fmx + real, intent(inout) :: fhx + real, intent(inout) :: stressx + real, intent(inout) :: fm10x + real, intent(inout) :: fh2x + + real, intent(inout) :: wspdx + real, intent(inout) :: flhcx + real, intent(inout) :: flqcx + + real :: zolx + real :: molx + +! diagnostics out +! real, intent(out) :: u10 +! real, intent(out) :: v10 +! real, intent(out) :: th2 +! real, intent(out) :: t2 +! real, intent(out) :: q2 +! real, intent(out) :: qsfc + + +! local + + real :: za ! height of full-sigma level + real :: thvx ! virtual potential temperature + real :: zqkl ! height of upper half level + real :: zqklp1 ! height of lower half level (surface) + real :: thx ! potential temperature + real :: psih ! similarity function for heat + real :: psih2 ! similarity function for heat 2m + real :: psih10 ! similarity function for heat 10m + real :: psim ! similarity function for momentum + real :: psim2 ! similarity function for momentum 2m + real :: psim10 ! similarity function for momentum 10m + + real :: gz1oz0 ! log(za/z0) + real :: gz2oz0 ! log(z2/z0) + real :: gz10oz0 ! log(z10/z0) + + real :: rhox ! density + real :: govrth ! g/theta for stability l + real :: tgdsa ! tsk + real :: tvir ! temporal variable src4 -> tvir + real :: thgb ! potential temperature ground + real :: psfcx ! surface pressure + real :: cpm + real :: qgh + + integer :: n,i,k,kk,l,nzol,nk,nzol2,nzol10 + + real :: zolzt, zolz0, zolza + real :: gz1ozt,gz2ozt,gz10ozt + + + real :: pl,thcon,tvcon,e1 + real :: zl,tskv,dthvdz,dthvm,vconv,rzol,rzol2,rzol10,zol2,zol10 + real :: dtg,psix,dtthx,psix10,psit,psit2,psiq,psiq2,psiq10 + real :: fluxc,vsgd,z0q,visc,restar,czil,restar2 + + real :: dqg + real :: tabs + real :: qsfcmr + real :: t1dc + real :: zt + real :: zq + real :: zratio + real :: qstar +!------------------------------------------------------------------- + + psfcx=psfcpa/1000. ! to kPa for saturation check + + if (itime == 1) then !init SP, MR + if (isice == 0) then + tabs = 0.5*(tsk + t1d) + if (tabs .lt. 273.15) then + !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) + e1=svp1*exp(4648*(1./273.15 - 1./tabs) - & + & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs)) + else + !saturation vapor pressure wrt water (bolton 1980) + e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3)) + endif + + qsfc =ep2*e1/(psfcx-ep_3*e1) !avg with the input? + qsfcmr =qsfc/(1.-qsfc) !to mixing ratio + endif + + if (isice == 1) then + if (tsk .lt. 273.15) then + !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) + e1=svp1*exp(4648*(1./273.15 - 1./tsk) - & + & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk)) + else + !saturation vapor pressure wrt water (bolton 1980) + e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3)) + endif + + qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity + qsfcmr=ep2*e1/(psfcx-e1) !mixing ratio + + endif + + else + ! use what comes out of the lsm + if (isice == 0) then + tabs = 0.5*(tsk + t1d) + if (tabs .lt. 273.15) then + !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) + e1=svp1*exp(4648*(1./273.15 - 1./tabs) - & + & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs)) + else + !saturation vapor pressure wrt water (bolton 1980) + e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3)) + endif + + qsfc =ep2*e1/(psfcx-ep_3*e1) ! avg with previous qsfc? + qsfcmr=qsfc/(1.-qsfc) + + endif + + if (isice == 1) then + if (tsk .lt. 273.15) then + !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) + e1=svp1*exp(4648*(1./273.15 - 1./tsk) - & + & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk)) + else + !saturation vapor pressure wrt water (bolton 1980) + e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3)) + endif + + qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity + qsfcmr=qsfc/(1.-qsfc) + + endif + + endif !done INIT if itime=1 +! convert (tah or tgb = tsk) temperature to potential temperature. + tgdsa = tsk + thgb = tsk*(p1000mb/psfcpa)**rcp !psfcpa is pa + +! store virtual, virtual potential and potential temperature + + pl = p1d/1000. + thx = t1d*(p1000mb*0.001/pl)**rcp + t1dc = t1d - 273.15 + + thvx = thx*(1.+ep_1*qx) !qx is SH from input + tvir = t1d*(1.+ep_1*qx) + + rhox=psfcx*1000./(r_d*tvir) + govrth=g/thx + za = zlvl + + !za=0.5*dz8w + + +! directly from input; check units + +! qfx = qflx * rhox +! hfx = hflx * rhox * cp + + + +! q2sat = qgh in lsm +!jref: canres and esat is calculated in the loop so should that be changed?? +! qgh=ep_2*e1/(pl-e1) +! cpm=cp*(1.+0.8*qx) + + +! qgh changed to use lowest-level air temp + + if (t1d .lt. 273.15) then + !saturation vapor pressure wrt ice + e1=svp1*exp(4648.*(1./273.15 - 1./t1d) - & + & 11.64*log(273.15/t1d) + 0.02265*(273.15 - t1d)) + else + !saturation vapor pressure wrt water (bolton 1980) + e1=svp1*exp(svp2*(t1d-svpt0)/(t1d-svp3)) + endif + + + !qgh=ep2*e1/(pl-ep_3*e1) !specific humidity + + qgh=ep2*e1/(pl-e1) !sat. mixing ratio ? + +! cpm=cp*(1.+0.84*qx) ! qx is SH + cpm=cp*(1.+0.84*qx/(1.0-qx) ) + + wspdx=sqrt(ux*ux+vx*vx) + + tskv=thgb*(1.+ep_1*qsfc) !avg with tsurf not used + dthvdz=(thvx-tskv) + + fluxc = max(hfx/rhox/cp + ep_1*tskv*qfx/rhox,0.) !hfx + qfx are fluxes units: wm^-2 and kg m^-2 s^-1 +! vconv = vconvc*(g/tgdsa*pblh*fluxc)**.33 + + vconv = vconvc*(g/tgdsa*min(1.5*pblhx,4000.0)*fluxc)**.33 !wstar +! vsgd = 0.32 * (max(dx/5000.-1.,0.))**.33 + + vsgd = min(0.32 * (max(dx/5000.-1.,0.))**.33,0.5) + wspdx=sqrt(wspdx*wspdx+vconv*vconv+vsgd*vsgd) + wspdx=max(wspdx,0.1) !0.1 is wmin + rbx=govrth*za*dthvdz/(wspdx*wspdx) !buld rich # + + if (itime == 1) then + rbx=max(rbx,-2.0) + rbx=min(rbx, 2.0) + else + rbx=max(rbx,-4.0) + rbx=min(rbx, 4.0) + endif + + +! visc=(1.32+0.009*(t1d-273.15))*1.e-5 +! kinematic viscosity + + + visc=1.326e-5*(1. + 6.542e-3*t1dc + 8.301e-6*t1dc*t1dc & + - 4.84e-9*t1dc*t1dc*t1dc) + +!compute roughness reynolds number (restar) using default znt +!the GFS option has been removed + + restar=max(ust*znt/visc,0.1) + +! get zt, zq based on the input +! the GFS roughness option and spp_pbl have been removed + + if (snwh > 50. .or. isice == 1) then ! (mm) treat as snow cover - use andreas cover isice =1 + call andreas_2002(znt,visc,ust,zt,zq) + else + if ( present(iz0tlnd) ) then + if ( iz0tlnd .le. 1 ) then + call zilitinkevich_1995(znt,zt,zq,restar,& + ust,karman,1.0,iz0tlnd,0,0.0) + elseif ( iz0tlnd .eq. 2 ) then + call yang_2008(znt,zt,zq,ust,molx,& + qstar,restar,visc) + elseif ( iz0tlnd .eq. 3 ) then + !original mynn in wrf-arw used this form: + call garratt_1992(zt,zq,znt,restar,1.0) + endif + +! the GFS option is removed along with gfs_z0_lnd + + else + + !default to zilitinkevich + call zilitinkevich_1995(znt,zt,zq,restar,& + ust,karman,1.0,0,0,0.0) + endif + endif + + +! --------- +! calculate bulk richardson no. of surface layer, +! according to akb(1976), eq(12). + + gz1oz0= log((za+znt)/znt) + gz1ozt= log((za+znt)/zt) + gz2oz0= log((2.0+znt)/znt) + gz2ozt= log((2.0+znt)/zt) + gz10oz0=log((10.+znt)/znt) +! gz10ozt=log((10.+znt)/zt) + + zratio=znt/zt !need estimate for li et al. + + +! vconv = 0.25*sqrt(g/tskv*pblh(i)*dthvm) +! if(mol.lt.0.) br=amin1(br,0.0) -> check the input mol later +! rmol=-govrth*dthvdz*za*karman + + if (rbx .gt. 0.0) then + + !compute z/l first guess: + call li_etal_2010(zolx,rbx,za/znt,zratio) + !zol=za*karman*g*mol/(thx*max(ust*ust,0.0001)) + zolx=max(zolx,0.0) + zolx=min(zolx,20.) + + + !use pedros iterative function to find z/l + !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt) + !use brute-force method + + zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt) + zolx=max(zolx,0.0) + zolx=min(zolx,20.) + + zolzt = zolx*zt/za ! zt/l + zolz0 = zolx*znt/za ! z0/l + zolza = zolx*(za+znt)/za ! (z+z0/l + zol10 = zolx*(10.+znt)/za ! (10+z0)/l + zol2 = zolx*(2.+znt)/za ! (2+z0)/l + + !compute psim and psih + !call psi_beljaars_holtslag_1991(psim,psih,zol) + !call psi_businger_1971(psim,psih,zol) + !call psi_zilitinkevich_esau_2007(psim,psih,zol) + !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za) + !call psi_cb2005(psim,psih,zolza,zolz0) + + psim=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) + psih=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) + psim10=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) +! psih10=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) + psih2=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt) + + ! 1.0 over monin-obukhov length + + rmolx= zolx/za + + elseif(rbx .eq. 0.) then + !========================================================= + !-----class 3; forced convection/neutral: + !========================================================= + + psim=0.0 + psih=psim + psim10=0. +! psih10=0. + psih2=0. + + zolx =0. + rmolx =0. + + elseif(rbx .lt. 0.)then + !========================================================== + !-----class 4; free convection: + !========================================================== + + !compute z/l first guess: + + call li_etal_2010(zolx,rbx,za/znt,zratio) + + !zol=za*karman*g*mol/(th1d*max(ust_lnd*ust_lnd,0.001)) + + zolx=max(zolx,-20.0) + zolx=min(zolx,0.0) + + + !use pedros iterative function to find z/l + !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt) + !use brute-force method + + zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt) + zolx=max(zolx,-20.0) + zolx=min(zolx,0.0) + + zolzt = zolx*zt/za ! zt/l + zolz0 = zolx*znt/za ! z0/l + zolza = zolx*(za+znt)/za ! (z+z0/l + zol10 = zolx*(10.+znt)/za ! (10+z0)/l + zol2 = zolx*(2.+znt)/za ! (2+z0)/l + + !compute psim and psih + !call psi_hogstrom_1996(psim,psih,zol, zt_lnd, zntstoch_lnd, za) + !call psi_businger_1971(psim,psih,zol) + !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za) + ! use tables + + psim=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) + psih=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) + psim10=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) +! psih10=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) + psih2=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt) + + !---limit psih and psim in the case of thin layers and + !---high roughness. this prevents denominator in fluxes + !---from getting too small + + psih=min(psih,0.9*gz1ozt) + psim=min(psim,0.9*gz1oz0) + psih2=min(psih2,0.9*gz2ozt) + psim10=min(psim10,0.9*gz10oz0) +! psih10=min(psih10,0.9*gz10ozt) + + rmolx = zolx/za + + endif + + ! calculate the resistance: + + psix =max(gz1oz0-psim, 1.0) + psix10=max(gz10oz0-psim10, 1.0) + psit =max(gz1ozt-psih , 1.0) + psit2 =max(gz2ozt-psih2, 1.0) + psiq =max(log((za+zq)/zq)-psih ,1.0) + psiq2 =max(log((2.0+zq)/zq)-psih2 ,1.0) + + !------------------------------------------------------------ + !-----compute the frictional velocity: + !------------------------------------------------------------ + + + ! to prevent oscillations average with old value + +! oldust = ust + + ust=0.5*ust+0.5*karman*wspdx/psix + ust=max(ust,0.005) + +! stress=ust**2 + + !set ustm = ust over land. + +! ustmx=ust + + + !---------------------------------------------------- + !----compute the temperature scale (a.k.a. friction temperature, t*, or mol) + !----and compute the moisture scale (or q*) + !---------------------------------------------------- + + dtg=thvx-tskv + +! oldtst=mol + + molx=karman*dtg/psit/prt !T* + + !t_star = -hfx/(ust*cpm*rho1d) + !t_star = mol + !---------------------------------------------------- + ! dqg=(qvsh-qsfc)*1000. !(kg/kg -> g/kg) + + dqg=(qx-qsfc)*1000. !(kg/kg -> g/kg) + qstar=karman*dqg/psiq/prt + + cm = (karman/psix)*(karman/psix)*wspdx + +! cm = (karman/psix)*(karman/psix) +! ch = (karman/psix)*(karman/psit) + + chs=ust*karman/psit + cqs2=ust*karman/psiq2 + chs2=ust*karman/psit2 + +! u10=ux*psix10/psix +! v10=vx*psix10/psix + + flhcx = rhox*cpm*ust*karman/psit + flqcx = rhox*1.0*ust*karman/psiq + +! ch = flhcx/(cpm*rhox) !same chs + + fmx = psix + fhx = psit + fm10x = psix10 + fh2x =psit2 + +! ustmx = ust + + stressx = ust**2 ! or cm*wind*wind + + end subroutine sfcdif4 + + subroutine zilitinkevich_1995(z_0,zt,zq,restar,ustar,karman,& + & landsea,iz0tlnd2,spp_pbl,rstoch) + + implicit none + real, intent(in) :: z_0,restar,ustar,karman,landsea + integer, optional, intent(in):: iz0tlnd2 + real, intent(out) :: zt,zq + real :: czil !=0.100 in chen et al. (1997) + !=0.075 in zilitinkevich (1995) + !=0.500 in lemone et al. (2008) + integer, intent(in) :: spp_pbl + real, intent(in) :: rstoch + + + if (landsea-1.5 .gt. 0) then !water + + !this is based on zilitinkevich, grachev, and fairall (2001; + !their equations 15 and 16). + if (restar .lt. 0.1) then + zt = z_0*exp(karman*2.0) + zt = min( zt, 6.0e-5) + zt = max( zt, 2.0e-9) + zq = z_0*exp(karman*3.0) + zq = min( zq, 6.0e-5) + zq = max( zq, 2.0e-9) + else + zt = z_0*exp(-karman*(4.0*sqrt(restar)-3.2)) + zt = min( zt, 6.0e-5) + zt = max( zt, 2.0e-9) + zq = z_0*exp(-karman*(4.0*sqrt(restar)-4.2)) + zq = min( zt, 6.0e-5) + zq = max( zt, 2.0e-9) + endif + + else !land + + !option to modify czil according to chen & zhang, 2009 + if ( iz0tlnd2 .eq. 1 ) then + czil = 10.0 ** ( -0.40 * ( z_0 / 0.07 ) ) + else + czil = 0.085 !0.075 !0.10 + end if + + zt = z_0*exp(-karman*czil*sqrt(restar)) + zt = min( zt, 0.75*z_0) + + zq = z_0*exp(-karman*czil*sqrt(restar)) + zq = min( zq, 0.75*z_0) + +! stochastically perturb thermal and moisture roughness length. +! currently set to half the amplitude: + if (spp_pbl==1) then + zt = zt + zt * 0.5 * rstoch + zt = max(zt, 0.0001) + zq = zt + endif + + endif + + return + + end subroutine zilitinkevich_1995 + +!!data. the formula for land uses a constant ratio (z_0/7.4) taken +!!from garratt (1992). + subroutine garratt_1992(zt,zq,z_0,ren,landsea) + + implicit none + real, intent(in) :: ren, z_0,landsea + real, intent(out) :: zt,zq + real :: rq + real, parameter :: e=2.71828183 + + if (landsea-1.5 .gt. 0) then !water + + zt = z_0*exp(2.0 - (2.48*(ren**0.25))) + zq = z_0*exp(2.0 - (2.28*(ren**0.25))) + + zq = min( zq, 5.5e-5) + zq = max( zq, 2.0e-9) + zt = min( zt, 5.5e-5) + zt = max( zt, 2.0e-9) !same lower limit as ecmwf + else !land + zq = z_0/(e**2.) !taken from garratt (1980,1992) + zt = zq + endif + + return + + end subroutine garratt_1992 +!-------------------------------------------------------------------- +!>\ingroup mynn_sfc +!> this is a modified version of yang et al (2002 qjrms, 2008 jamc) +!! and chen et al (2010, j of hydromet). although it was originally +!! designed for arid regions with bare soil, it is modified +!! here to perform over a broader spectrum of vegetation. +!! +!!the original formulation relates the thermal roughness length (zt) +!!to u* and t*: +!! +!! zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar)**0.25)) +!! +!!where ht = renc*visc/ustar and the critical reynolds number +!!(renc) = 70. beta was originally = 10 (2002 paper) but was revised +!!to 7.2 (in 2008 paper). their form typically varies the +!!ratio z0/zt by a few orders of magnitude (1-1e4). +!! +!!this modified form uses beta = 1.5 and a variable renc (function of z_0), +!!so zt generally varies similarly to the zilitinkevich form (with czil = 0.1) +!!for very small or negative surface heat fluxes but can become close to the +!!zilitinkevich with czil = 0.2 for very large hfx (large negative t*). +!!also, the exponent (0.25) on tstar was changed to 1.0, since we found +!!zt was reduced too much for low-moderate positive heat fluxes. +!! +!!this should only be used over land! + 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 :: ht, &! roughness height at critical reynolds number + tstar2, &! bounded t*, forced to be non-positive + qstar2, &! bounded q*, forced to be non-positive + z_02, &! bounded z_0 for variable renc2 calc + renc2 ! variable renc, function of z_0 + real, intent(out) :: zt,zq + real, parameter :: renc=300., & !old constant renc + beta=1.5, & !important for diurnal variation + m=170., & !slope for renc2 function + b=691. !y-intercept for renc2 function + + z_02 = min(z_0,0.5) + z_02 = max(z_02,0.04) + renc2= b + m*log(z_02) + ht = renc2*visc/max(ustar,0.01) + tstar2 = min(tstar, 0.0) + qstar2 = min(qst,0.0) + + zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar2)**1.0)) + zq = ht * exp(-beta*(ustar**0.5)*(abs(qstar2)**1.0)) + !zq = zt + + zt = min(zt, z_0/2.0) + zq = min(zq, z_0/2.0) + + return + + end subroutine yang_2008 + +!>\ingroup mynn_sfc +!> this is taken from andreas (2002; j. of hydromet) and +!! andreas et al. (2005; blm). +!! +!! this should only be used over snow/ice! + subroutine andreas_2002(z_0,bvisc,ustar,zt,zq) + + implicit none + real, intent(in) :: z_0, bvisc, ustar + real, intent(out) :: zt, zq + real :: ren2, zntsno + + real, parameter :: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, & + bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, & + bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183 + + real, parameter :: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, & + bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, & + bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180 + + !calculate zo for snow (andreas et al. 2005, blm) + zntsno = 0.135*bvisc/ustar + & + (0.035*(ustar*ustar)/9.8) * & + (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.) + ren2 = ustar*zntsno/bvisc + + ! make sure that re is not outside of the range of validity + ! for using their equations + if (ren2 .gt. 1000.) ren2 = 1000. + + if (ren2 .le. 0.135) then + + zt = zntsno*exp(bt0_s + bt1_s*log(ren2) + bt2_s*log(ren2)**2) + zq = zntsno*exp(bq0_s + bq1_s*log(ren2) + bq2_s*log(ren2)**2) + + else if (ren2 .gt. 0.135 .and. ren2 .lt. 2.5) then + + zt = zntsno*exp(bt0_t + bt1_t*log(ren2) + bt2_t*log(ren2)**2) + zq = zntsno*exp(bq0_t + bq1_t*log(ren2) + bq2_t*log(ren2)**2) + + else + + zt = zntsno*exp(bt0_r + bt1_r*log(ren2) + bt2_r*log(ren2)**2) + zq = zntsno*exp(bq0_r + bq1_r*log(ren2) + bq2_r*log(ren2)**2) + + endif + + return + + end subroutine andreas_2002 +!-------------------------------------------------------------------- +!>\ingroup mynn_sfc +!! this subroutine returns a more robust z/l that best matches +!! the z/l from hogstrom (1996) for unstable conditions and beljaars +!! and holtslag (1991) for stable conditions. + subroutine li_etal_2010(zl, rib, zaz0, z0zt) + + implicit none + real, intent(out) :: zl + real, intent(in) :: rib, 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, & + &bu32=-0.9213, bu33=-0.1057 + real, parameter :: aw11=0.5738, aw12=-0.4399, aw21=-4.901,& + &aw22=52.50, bw11=-0.0539, bw12=1.540, & + &bw21=-0.669, bw22=-3.282 + real, parameter :: as11=0.7529, as21=14.94, bs11=0.1569,& + &bs21=-0.3091, bs22=-1.303 + + !set limits according to li et al (2010), p 157. + zaz02=zaz0 + if (zaz0 .lt. 100.0) zaz02=100. + if (zaz0 .gt. 100000.0) zaz02=100000. + + !set more limits according to li et al (2010) + z0zt2=z0zt + if (z0zt .lt. 0.5) z0zt2=0.5 + if (z0zt .gt. 100.0) z0zt2=100. + + alfa = log(zaz02) + beta = log(z0zt2) + + if (rib .le. 0.0) then + zl = au11*alfa*rib**2 + ( & + & (bu11*beta + bu12)*alfa**2 + & + & (bu21*beta + bu22)*alfa + & + & (bu31*beta**2 + bu32*beta + bu33))*rib + !if(zl .lt. -15 .or. zl .gt. 0.)print*,"violation rib<0:",zl + zl = max(zl,-15.) !limits set according to li et al (2010) + zl = min(zl,0.) !figure 1. + elseif (rib .gt. 0.0 .and. rib .le. 0.2) then + zl = ((aw11*beta + aw12)*alfa + & + & (aw21*beta + aw22))*rib**2 + & + & ((bw11*beta + bw12)*alfa + & + & (bw21*beta + bw22))*rib + !if(zl .lt. 0 .or. zl .gt. 4)print*,"violation 00.2:",zl + zl = min(zl,20.) !limits according to li et al (2010), thier + !figue 1c. + zl = max(zl,1.) + endif + + return + + end subroutine li_etal_2010 +!------------------------------------------------------------------- + real 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 + ! summarized in jimenez et al. (2012, mwr). this function was adapted + ! to input the thermal roughness length, zt, (as well as z0) and use initial + ! estimate of z/l. + + implicit none + real, intent(in) :: ri,za,z0,zt,zol1 + integer, intent(in) :: psi_opt + real :: x1,x2,fx1,fx2 + integer :: n + integer, parameter :: nmax = 20 + !real, dimension(nmax):: zlhux +! real :: zolri2 + + if (ri.lt.0.)then + x1=zol1 - 0.02 !-5. + x2=0. + else + x1=0. + x2=zol1 + 0.02 !5. + endif + + n=1 + fx1=zolri2(x1,ri,za,z0,zt,psi_opt) + fx2=zolri2(x2,ri,za,z0,zt,psi_opt) + + do while (abs(x1 - x2) > 0.01 .and. n < nmax) + if(abs(fx2).lt.abs(fx1))then + x1=x1-fx1/(fx2-fx1)*(x2-x1) + fx1=zolri2(x1,ri,za,z0,zt,psi_opt) + zolri=x1 + else + x2=x2-fx2/(fx2-fx1)*(x2-x1) + fx2=zolri2(x2,ri,za,z0,zt,psi_opt) + zolri=x2 + endif + n=n+1 + !print*," n=",n," x1=",x1," x2=",x2 + !zlhux(n)=zolri + enddo + + if (n==nmax .and. abs(x1 - x2) >= 0.01) then + !if convergence fails, use approximate values: + call li_etal_2010(zolri, ri, za/z0, z0/zt) + !zlhux(n)=zolri + !print*,"iter fail, n=",n," ri=",ri," z0=",z0 + else + !print*,"success,n=",n," ri=",ri," z0=",z0 + endif + + return + end function +!------------------------------------------------------------------- + real function zolri2(zol2,ri2,za,z0,zt,psi_opt) + + ! input: ================================= + ! zol2 - estimated z/l + ! ri2 - calculated bulk richardson number + ! za - 1/2 depth of first model layer + ! z0 - aerodynamic roughness length + ! zt - thermal roughness length + ! output: ================================ + ! zolri2 - delta ri + + implicit none + integer, intent(in) :: psi_opt + real, intent(in) :: ri2,za,z0,zt + real, intent(inout) :: zol2 + real :: zol20,zol3,psim1,psih1,psix2,psit2,zolt + +! real :: psih_unstable,psim_unstable,psih_stable, psim_stable + + if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 + + zol20=zol2*z0/za ! z0/l + zol3=zol2+zol20 ! (z+z0)/l + zolt=zol2*zt/za ! zt/l + + if (ri2.lt.0) then + !psix2=log((za+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) + !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) + psit2=max(log((za+z0)/zt)-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) + psix2=max(log((za+z0)/z0)-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)),1.0) + else + !psix2=log((za+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) + !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) + psit2=max(log((za+z0)/zt)-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) + psix2=max(log((za+z0)/z0)-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)),1.0) + endif + + zolri2=zol2*psit2/psix2**2 - ri2 + !print*," target ri=",ri2," est ri=",zol2*psit2/psix2**2 + + return + end function +!==================================================================== + + real 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 + integer, intent(in) :: psi_opt + real, intent(inout) :: zol1 + real :: zol20,zol3,zolt,zolold + integer :: n + integer, parameter :: nmax = 20 + real, dimension(nmax):: zlhux + real :: psit2,psix2 + +! real :: psim_unstable, psim_stable +! real :: psih_unstable, psih_stable + + !print*,"+++++++incoming: z/l=",zol1," ri=",ri + if (zol1*ri .lt. 0.) then + !print*,"begin: wrong quadrants: z/l=",zol1," ri=",ri + zol1=0. + endif + + if (ri .lt. 0.) then + zolold=-99999. + zolrib=-66666. + else + zolold=99999. + zolrib=66666. + endif + n=1 + + do while (abs(zolold - zolrib) > 0.01 .and. n < nmax) + + if(n==1)then + zolold=zol1 + else + zolold=zolrib + endif + zol20=zolold*z0/za ! z0/l + zol3=zolold+zol20 ! (z+z0)/l + zolt=zolold*zt/za ! zt/l + !print*,"z0/l=",zol20," (z+z0)/l=",zol3," zt/l=",zolt + if (ri.lt.0) then + !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) + !psit2=log((za+z0)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) + psit2=max(logzt-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) + psix2=max(logz0-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)), 1.0) + else + !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) + !psit2=log((za+z0)/zt)-(psih_stable(zol3)-psih_stable(zol20)) + psit2=max(logzt-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) + psix2=max(logz0-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)), 1.0) + endif + !print*,"n=",n," psit2=",psit2," psix2=",psix2 + zolrib=ri*psix2**2/psit2 + zlhux(n)=zolrib + n=n+1 + enddo + + if (n==nmax .and. abs(zolold - zolrib) > 0.01 ) then + !print*,"iter fail, n=",n," ri=",ri," z/l=",zolri + !if convergence fails, use approximate values: + call li_etal_2010(zolrib, ri, za/z0, z0/zt) + zlhux(n)=zolrib + !print*,"failed, n=",n," ri=",ri," z0=",z0 + !print*,"z/l=",zlhux(1:nmax) + else + !if(zolrib*ri .lt. 0.) then + ! !print*,"end: wrong quadrants: z/l=",zolrib," ri=",ri + ! !call li_etal_2010(zolrib, ri, za/z0, z0/zt) + !endif + !print*,"success,n=",n," ri=",ri," z0=",z0 + endif + + return + end function +!==================================================================== + + subroutine psi_init(psi_opt,errmsg,errflg) + + integer :: n,psi_opt + real :: zolf + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + if (psi_opt == 0) then + do n=0,1000 + ! stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full(zolf) + psih_stab(n)=psih_stable_full(zolf) + + ! unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full(zolf) + psih_unstab(n)=psih_unstable_full(zolf) + enddo + else + do n=0,1000 + ! stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full_gfs(zolf) + psih_stab(n)=psih_stable_full_gfs(zolf) + + ! unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full_gfs(zolf) + psih_unstab(n)=psih_unstable_full_gfs(zolf) + enddo + endif + + !simple test to see if initialization worked: + if (psim_stab(1) < 0. .and. psih_stab(1) < 0. .and. & + psim_unstab(1) > 0. .and. psih_unstab(1) > 0.) then + errmsg = 'in mynn sfc, psi tables have been initialized' + errflg = 0 + else + errmsg = 'error in mynn sfc: problem initializing psi tables' + errflg = 1 + endif + + end subroutine psi_init +! ================================================================== +! ... integrated similarity functions from mynn... +! +!>\ingroup mynn_sfc + real function psim_stable_full(zolf) + real :: zolf + + !psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) + psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**0.4) + + return + end function + +!>\ingroup mynn_sfc + real function psih_stable_full(zolf) + real :: zolf + + !psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) + psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**0.9090909090909090909) + + return + end function + +!>\ingroup mynn_sfc + real function psim_unstable_full(zolf) + real :: zolf,x,ym,psimc,psimk + + x=(1.-16.*zolf)**.25 + !psimk=2*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan(1.) + psimk=2.*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan1 + + ym=(1.-10.*zolf)**onethird + !psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*atan((2.*ym+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.) + psimc=1.5*log((ym**2 + ym+1.)*onethird)-sqrt3*atan((2.*ym+1)/sqrt3)+4.*atan1/sqrt3 + + psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.) + + return + end function + +!>\ingroup mynn_sfc + real function psih_unstable_full(zolf) + real :: zolf,y,yh,psihc,psihk + + y=(1.-16.*zolf)**.5 + !psihk=2.*log((1+y)/2.) + psihk=2.*log((1+y)*0.5) + + yh=(1.-34.*zolf)**onethird + !psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*atan((2.*yh+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.) + psihc=1.5*log((yh**2.+yh+1.)*onethird)-sqrt3*atan((2.*yh+1)/sqrt3)+4.*atan1/sqrt3 + + psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2) + + return + end function + +! ================================================================== +! ... integrated similarity functions from gfs... +! + real function psim_stable_full_gfs(zolf) + real :: zolf + real, parameter :: alpha4 = 20. + real :: aa + + aa = sqrt(1. + alpha4 * zolf) + psim_stable_full_gfs = -1.*aa + log(aa + 1.) + + return + end function + + real function psih_stable_full_gfs(zolf) + real :: zolf + real, parameter :: alpha4 = 20. + real :: bb + + bb = sqrt(1. + alpha4 * zolf) + psih_stable_full_gfs = -1.*bb + log(bb + 1.) + + return + end function + + real function psim_unstable_full_gfs(zolf) + real :: zolf + real :: hl1,tem1 + real, parameter :: a0=-3.975, a1=12.32, & + b1=-7.755, b2=6.041 + + if (zolf .ge. -0.5) then + hl1 = zolf + psim_unstable_full_gfs = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) + else + hl1 = -zolf + tem1 = 1.0 / sqrt(hl1) + psim_unstable_full_gfs = log(hl1) + 2. * sqrt(tem1) - .8776 + end if + + return + end function + + real function psih_unstable_full_gfs(zolf) + real :: zolf + real :: hl1,tem1 + real, parameter :: a0p=-7.941, a1p=24.75, & + b1p=-8.705, b2p=7.899 + + if (zolf .ge. -0.5) then + hl1 = zolf + psih_unstable_full_gfs = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) + else + hl1 = -zolf + tem1 = 1.0 / sqrt(hl1) + psih_unstable_full_gfs = log(hl1) + .5 * tem1 + 1.386 + end if + + return + end function + +!================================================================= +! look-up table functions - or, if beyond -10 < z/l < 10, recalculate +!================================================================= + real function psim_stable(zolf,psi_opt) + integer :: nzol,psi_opt + real :: rzol,zolf + + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) + else + if (psi_opt == 0) then + psim_stable = psim_stable_full(zolf) + else + psim_stable = psim_stable_full_gfs(zolf) + endif + endif + + return + end function + + real function psih_stable(zolf,psi_opt) + integer :: nzol,psi_opt + real :: rzol,zolf + + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) + else + if (psi_opt == 0) then + psih_stable = psih_stable_full(zolf) + else + psih_stable = psih_stable_full_gfs(zolf) + endif + endif + + return + end function + + real function psim_unstable(zolf,psi_opt) + integer :: nzol,psi_opt + real :: rzol,zolf + + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) + else + if (psi_opt == 0) then + psim_unstable = psim_unstable_full(zolf) + else + psim_unstable = psim_unstable_full_gfs(zolf) + endif + endif + + return + end function + + real function psih_unstable(zolf,psi_opt) + integer :: nzol,psi_opt + real :: rzol,zolf + + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) + else + if (psi_opt == 0) then + psih_unstable = psih_unstable_full(zolf) + else + psih_unstable = psih_unstable_full_gfs(zolf) + endif + endif + + return + end function +!======================================================================== end module module_sf_noahmplsm From f3af80f1545f17e34e2499b5d50d04b8adef5304 Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Sun, 20 Mar 2022 14:05:25 +0000 Subject: [PATCH 25/35] tuning cd/lm parameter --- physics/module_sf_noahmplsm.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 6e59407bb..d2f766b31 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4695,7 +4695,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in ! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. - kh = max ( vkc*fv*(hcan-zpd)/fhgh, mpe ) + kh = max ( 0.5*vkc*fv*(hcan-zpd)/fhgh, mpe ) ramg = 0. rahg = tmprah2 / kh rawg = rahg From 96f58e021a1d5607a446dd0826982343929c72d5 Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Sun, 20 Mar 2022 14:07:49 +0000 Subject: [PATCH 26/35] tuning cd/lm parameter --- physics/module_sf_noahmplsm.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index d2f766b31..2f16dc331 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4686,7 +4686,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in fhgh = 0.5 * (fhgh+fhgnewh) endif - cwpc = (cwp * vai * hcan * fhg)**0.5 + cwpc = (0.5 * cwp * vai * hcan * fhg)**0.5 ! cwpc = (cwp*fhg)**0.5 tmp1 = exp( -cwpc*z0hg/hcan ) @@ -4695,7 +4695,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in ! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. - kh = max ( 0.5*vkc*fv*(hcan-zpd)/fhgh, mpe ) + kh = max ( vkc*fv*(hcan-zpd)/fhgh, mpe ) ramg = 0. rahg = tmprah2 / kh rawg = rahg From 7fa72235c60977756e5fe0bd2b5310da38434d7b Mon Sep 17 00:00:00 2001 From: helin wei Date: Sun, 20 Mar 2022 17:36:27 +0000 Subject: [PATCH 27/35] revert back to shdfac in gvfun calculation due to occasional model crash --- physics/module_sf_noahmplsm.f90 | 24 ++++-------------------- 1 file changed, 4 insertions(+), 20 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index ef022b4ee..5e6e19f14 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4032,7 +4032,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,.true. ,vaie ,vegtyp, & !in + zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp, & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out @@ -4492,7 +4492,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh,fveg ,garea1 ,.false. ,0.0,ivgtyp , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out @@ -5151,28 +5151,12 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur real (kind=kind_phys) :: czil1 ! canopy based czil real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output real (kind=kind_phys) :: sigmaa ! momentum partition parameter - real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx,slaifrac + real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 - real (kind=kind_phys) :: saimax !< monthly maximum stem area index, one-sided - real (kind=kind_phys) :: laimax !< monthly maximum leaf area index, one-sided ! ------------------------------------------------------------------------------------------------- fv = ustarx - laimax = maxval(parameters%laim) - saimax = maxval(parameters%saim) - if(dveg.eq.4 .or. dveg.eq.5) then - if(laimax+saimax .gt. 0 .and. fveg .gt. 0) then - slaifrac=vaie/(laimax+saimax) - slaifrac=min(slaifrac,1.) - slaifrac=fveg*slaifrac - else - slaifrac=0.1_kind_phys - endif - else - slaifrac=fveg - endif - ! fv = ur*vkc/log((zlvl-zpd)/z0m) if(vegetated) then @@ -5223,7 +5207,7 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur tem1 = (z0m - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys) - tem2 = max(slaifrac, 0.1_kind_phys) + tem2 = max(fveg, 0.1_kind_phys) zvfun1 = sqrt(tem1 * tem2) gdx = sqrt(garea1) From 779b323d2f39d74319c9ff24a07aa7b577e018d5 Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Mon, 21 Mar 2022 15:00:51 +0000 Subject: [PATCH 28/35] modify a table of cwp parameter --- physics/module_sf_noahmplsm.f90 | 4 ++-- physics/noahmp_tables.f90 | 10 +++++----- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 2f16dc331..f6ec7b79e 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4686,7 +4686,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in fhgh = 0.5 * (fhgh+fhgnewh) endif - cwpc = (0.5 * cwp * vai * hcan * fhg)**0.5 + cwpc = (cwp * vai * hcan * fhg)**0.5 ! cwpc = (cwp*fhg)**0.5 tmp1 = exp( -cwpc*z0hg/hcan ) @@ -4695,7 +4695,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in ! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. - kh = max ( vkc*fv*(hcan-zpd)/fhgh, mpe ) + kh = max ( vkc*fv*(hcan-zpd)/(max(fhgh,0.1), mpe ) ramg = 0. rahg = tmprah2 / kh rawg = rahg diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 9cb25b3f3..6666b2f67 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -510,11 +510,11 @@ module noahmp_tables ! real :: cwpvt_table(mvt) !< empirical canopy wind parameter - data ( cwpvt_table (i),i=1,mvt) / 0.18, 0.67, 0.18, 0.67, 0.29, 1.00, & - & 2.00, 1.30, 1.00, 5.00, 1.17, 1.67, & - & 1.67, 1.67, 0.18, 0.18, 0.18, 0.67, & - & 1.00, 0.18, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + data ( cwpvt_table (i),i=1,mvt) / 0.09, 0.335, 0.09, 0.335, 0.145, 0.50, & + & 1.00, 0.65, 0.50, 2.50, 0.585, 0.835, & + & 0.835, 0.835, 0.09, 0.09, 0.09, 0.335, & + & 0.835, 0.835, 0.09, 0.09, 0.09, 0.335, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / real :: wrrat_table(mvt) !< wood to non-wood ratio From 09e4f95feb79a9354c9fb3710567a3ec58a2da5d Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Mon, 21 Mar 2022 15:04:38 +0000 Subject: [PATCH 29/35] modify a table of cwp parameter --- physics/module_sf_noahmplsm.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index f6ec7b79e..217f4ce80 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4695,7 +4695,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in ! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. - kh = max ( vkc*fv*(hcan-zpd)/(max(fhgh,0.1), mpe ) + kh = max ( vkc*fv*(hcan-zpd)/(max(fhgh,0.1)), mpe ) ramg = 0. rahg = tmprah2 / kh rawg = rahg From 0b7879cffdbbe71fd7bba4d9e62e154b4cd5afb4 Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Mon, 21 Mar 2022 15:07:58 +0000 Subject: [PATCH 30/35] modify a table of cwp parameter --- physics/module_sf_noahmplsm.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 217f4ce80..e610cc214 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4672,18 +4672,18 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in if (mozg < 0.) then fhgnew = (1. - 15.*mozg)**(-0.25) - fhgnewh = 0.74 * (1. - 9.*mozg)**(-0.5) ! PHIh + fhgnewh = 0.74 * (1. - 9.*mozg)**(-0.5) ! PHIh else fhgnew = 1.+ 4.7*mozg - fhgnewh = 0.74 + 4.7*mozgh ! PHIh + fhgnewh = 0.74 + 4.7*mozgh ! PHIh endif if (iter == 1) then fhg = fhgnew - fhgh = fhgnewh + fhgh = fhgnewh else fhg = 0.5 * (fhg+fhgnew) - fhgh = 0.5 * (fhgh+fhgnewh) + fhgh = 0.5 * (fhgh+fhgnewh) endif cwpc = (cwp * vai * hcan * fhg)**0.5 From 109dcdfaf05e7b9b48b43d7545a54e895d67bd8a Mon Sep 17 00:00:00 2001 From: weizhong zheng Date: Mon, 21 Mar 2022 16:15:32 +0000 Subject: [PATCH 31/35] modify a table of cwp parameter --- physics/noahmp_tables.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 6666b2f67..2e3e2920e 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -513,7 +513,7 @@ module noahmp_tables data ( cwpvt_table (i),i=1,mvt) / 0.09, 0.335, 0.09, 0.335, 0.145, 0.50, & & 1.00, 0.65, 0.50, 2.50, 0.585, 0.835, & & 0.835, 0.835, 0.09, 0.09, 0.09, 0.335, & - & 0.835, 0.835, 0.09, 0.09, 0.09, 0.335, & + & 0.50, 0.09, 0.00, 0.00, 0.00, 0.00, & & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / From 726f4a6283c6bb7fb5a7bac4532889f49e63701a Mon Sep 17 00:00:00 2001 From: rongqian yang Date: Wed, 23 Mar 2022 18:45:52 +0000 Subject: [PATCH 32/35] Driver update, opt_trs=4 over vegetation, and z0hover bare soil etc. --- physics/module_sf_noahmplsm.f90 | 58 ++++++++++++++++++++++++++++----- physics/sfc_noahmp_drv.F90 | 10 +++++- 2 files changed, 59 insertions(+), 9 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 09faf0e05..7e3460ddf 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -3967,6 +3967,10 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity real (kind=kind_phys), intent( out) :: csigmaf1 ! real (kind=kind_phys) :: czil1 ! canopy based czil + real (kind=kind_phys) :: dlf ! leaf dimension + real(kind=kind_phys) :: kbsigmaf1 ! kb^-1 for fully convered by vegetation + real(kind=kind_phys) :: sigmaa ! kb^-1 for fully convered by vegetation + real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 @@ -4012,7 +4016,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & qsfc = 0.622*eair/(psfc-0.378*eair) ! canopy height - + dlf = parameters%dleaf !leaf dimension hcan = parameters%hvt uc = ur*log(hcan/z0m)/log(zlvl/z0m) uc = ur*log((hcan-zpd+z0m)/z0m)/log(zlvl/z0m) ! mb: add zpd v3.7 @@ -4058,8 +4062,11 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 cir = (2.-emv*(1.-emg))*emv*sb ! + if(opt_sfc == 4) then + gdx = sqrt(garea1) snwd = snowh * 1000.0 + fv = ustarx !inout in sfcdif4 if (snowh .gt. 0.1) then mnice = 1 @@ -4067,6 +4074,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & mnice = 0 endif + endif + ! --------------------------------------------------------------------------------------------- loop1: do iter = 1, niterc ! begin stability iteration @@ -4087,6 +4096,10 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & else z0h = z0m*0.01 endif + elseif (opt_trs == 4) then + sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) + kbsigmaf1 = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) + z0h = z0m/exp(kbsigmaf1) endif ! aerodyn resistances between heights zlvl and d+z0v @@ -4525,6 +4538,10 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: cev !coefficients for ev as function of esat[ts] real (kind=kind_phys) :: cgh !coefficients for st as function of ts + real(kind=kind_phys) :: kbsigmaf0 + real(kind=kind_phys) :: reynb + + !jref:start real (kind=kind_phys) :: rahb2 !aerodynamic resistance for sensible heat 2m (s/m) real (kind=kind_phys) :: rawb2 !aerodynamic resistance for water vapor 2m (s/m) @@ -4597,6 +4614,18 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & cir = emg*sb cgh = 2.*df(isnow+1)/dzsnso(isnow+1) + reynb = ustarx*z0m/(1.5e-05) + + if (reynb .gt. 2.0) then + kbsigmaf0 = 2.46*reynb**0.25 - log(7.4) + else + kbsigmaf0 = - log(0.397) + endif + + z0h = max(z0m/exp(kbsigmaf0),1.0e-6) + + if (opt_sfc == 4) then + fv = ustarx gdx = sqrt(garea1) snwd = snowh * 1000.0 @@ -4605,6 +4634,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & else mnice = 0 endif + endif ! ----------------------------------------------------------------- loop3: do iter = 1, niterb ! begin stability iteration @@ -4767,17 +4797,11 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !jref:start; errors in original equation corrected. ! 2m air temperature + if(opt_sfc == 1 .or. opt_sfc ==2 .or. opt_sfc == 3) then ehb2 = fv*vkc/log((2.+z0h)/z0h) ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) cq2b = ehb2 - endif - - if(opt_sfc == 4) then - ehb2 = 1. /(max(1.,1./ch2b*wspdb)) - cq2b = 1. /(max(1.,1./cq2b*wspdb)) - endif - if (ehb2.lt.1.e-5 ) then t2mb = tgb q2b = qsfc @@ -4785,6 +4809,24 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2 q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) endif + end if + + if(opt_sfc == 4) then ! consistent with veg + + rahb2 = max(1.,1./(ch2b*wspdb)) + ehb2 = 1./rahb2 + cq2b = 1./max(1.,1./(cq2b*wspdb)) ! + + if (ehb2.lt.1.e-5 ) then + t2mb = tgb + q2b = qsfc + else + t2mb = tgb - shb/(rhoair*cpair*ehb2) +! q2b = qsfc - qfx/(rhoair*cq2b) + q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) + end if + endif ! 4 + if (parameters%urban_flag) q2b = qsfc ! update ch diff --git a/physics/sfc_noahmp_drv.F90 b/physics/sfc_noahmp_drv.F90 index a16534364..ccd9f80f6 100644 --- a/physics/sfc_noahmp_drv.F90 +++ b/physics/sfc_noahmp_drv.F90 @@ -553,6 +553,7 @@ subroutine noahmpdrv_run & real (kind=kind_phys) :: qfx real (kind=kind_phys) :: wspd1 ! wind speed with all components real (kind=kind_phys) :: pblhx ! height of pbl + integer :: mnice real (kind=kind_phys) :: rah_total ! real (kind=kind_phys) :: cah_total ! @@ -737,6 +738,13 @@ subroutine noahmpdrv_run & snow_ice_frac_old(k) = snow_level_ice(k) /(snow_level_ice(k)+snow_level_liquid(k)) end do + + if (snow_depth .gt. 0.1 .or. vegetation_category == isice_table ) then + mnice = 1 + else + mnice = 0 + endif + ! ! --- some outputs for atm model? ! @@ -1067,7 +1075,7 @@ subroutine noahmpdrv_run & call sfcdif4(i_location ,j_location ,uwind_forcing ,vwind_forcing , & temperature_forcing, air_pressure_forcing ,air_pressure_surface , & - pblhx,gdx,z0_total,itime,snwdph(i),0,psi_opt,surface_temperature, & + pblhx,gdx,z0_total,itime,snwdph(i),mnice,psi_opt,surface_temperature, & spec_humidity_forcing,forcing_height,iz0tlnd,spec_humidity_surface,& sensible_heat_total,qfx,cm(i),ch(i),ch2,cq2,rmol1(i),ustar1(i), & rb1(i),fm1(i),fh1(i),stress1(i),fm101(i),fh21(i),wspd1,flhc1(i), & From 81a326afa210c402144e9dddc56a45f85c745a70 Mon Sep 17 00:00:00 2001 From: helin wei Date: Thu, 24 Mar 2022 20:18:12 +0000 Subject: [PATCH 33/35] put a upper/lower limit on cwpc --- physics/module_sf_noahmplsm.f90 | 1 + physics/sfcsub.F | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index cdc43635b..98364b19c 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -4688,6 +4688,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in cwpc = (cwp * vai * hcan * fhg)**0.5 ! cwpc = (cwp*fhg)**0.5 + cwpc = max(min(cwpc,5.0),1.0) tmp1 = exp( -cwpc*z0hg/hcan ) tmp2 = exp( -cwpc*(z0h+zpd)/hcan ) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index cdc91cca9..78e5201be 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -34,7 +34,6 @@ module sfccyc_module integer, parameter :: kpdalf(2)=(/214,217/) ! real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 -! integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata integer, parameter :: xdata=7200, ydata=3600, mdata=xdata*ydata integer :: veg_type_landice integer :: soil_type_landice From 7a16e21a3a0b9edb588c5fc644c6c1c7d819855f Mon Sep 17 00:00:00 2001 From: HelinWei-NOAA <48133472+HelinWei-NOAA@users.noreply.github.com> Date: Thu, 24 Mar 2022 17:17:54 -0400 Subject: [PATCH 34/35] Revert "Lsm upgrades mynn for p8c" --- physics/module_sf_noahmp_glacier.f90 | 101 +- physics/module_sf_noahmplsm.f90 | 1460 +------------------------- physics/sfc_noahmp_drv.F90 | 114 +- physics/sfc_noahmp_drv.meta | 53 - 4 files changed, 24 insertions(+), 1704 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index 997166744..c4c03aaf8 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -7,7 +7,6 @@ module noahmp_glacier_globals use machine , only : kind_phys use sfc_diff, only : stability - use module_sf_noahmplsm, only : sfcdif4 implicit none @@ -123,9 +122,7 @@ subroutine noahmp_glacier (& iloc ,jloc ,cosz ,nsnow ,nsoil ,dt , & ! in : time/space/model-related sfctmp ,sfcprs ,uu ,vv ,q2 ,soldn , & ! in : forcing prcp ,lwdn ,tbot ,zlvl ,ficeold ,zsoil , & ! in : forcing - thsfc_loc ,prslkix ,prsik1x ,prslk1x , & - psfc ,pblhx ,iz0tlnd ,itime , & - sigmaf1 ,garea1 ,psi_opt , & ! in : + thsfc_loc ,prslkix ,prsik1x ,prslk1x ,sigmaf1 ,garea1 , & ! in : qsnow ,sneqvo ,albold ,cm ,ch ,isnow , & ! in/out : sneqv ,smc ,zsnso ,snowh ,snice ,snliq , & ! in/out : tg ,stc ,sh2o ,tauss ,qsfc , & ! in/out : @@ -152,8 +149,6 @@ subroutine noahmp_glacier (& real (kind=kind_phys) , intent(in) :: cosz !< cosine solar zenith angle [0-1] integer , intent(in) :: nsnow !< maximum no. of snow layers integer , intent(in) :: nsoil !< no. of soil layers - integer , intent(in) :: psi_opt - real (kind=kind_phys) , intent(in) :: dt !< time step [sec] real (kind=kind_phys) , intent(in) :: sfctmp !< surface air temperature [k] real (kind=kind_phys) , intent(in) :: sfcprs !< pressure (pa) @@ -171,12 +166,6 @@ subroutine noahmp_glacier (& real (kind=kind_phys) , intent(in) :: prslkix !< pressure (pa) real (kind=kind_phys) , intent(in) :: prsik1x !< pressure (pa) real (kind=kind_phys) , intent(in) :: prslk1x !< pressure (pa) - - real (kind=kind_phys) , intent(in) :: psfc ! surface pressure - real (kind=kind_phys) , intent(in) :: pblhx ! pbl height - integer , intent(in) :: iz0tlnd ! - integer , intent(in) :: itime !< timestep - real (kind=kind_phys) , intent(in) :: sigmaf1 !< areal fractional cover of green vegetation real (kind=kind_phys) , intent(in) :: garea1 !< area of the grid cell @@ -285,7 +274,6 @@ subroutine noahmp_glacier (& vv ,solad ,solai ,cosz ,zlvl , & !in tbot ,zbot ,zsnso ,dzsnso ,sigmaf1 ,garea1 , & !in thsfc_loc ,prslkix ,prsik1x ,prslk1x , & !in - psfc ,pblhx ,iz0tlnd ,itime ,psi_opt , & tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout #ifdef CCPP @@ -417,7 +405,6 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair vv ,solad ,solai ,cosz ,zref , & !in tbot ,zbot ,zsnso ,dzsnso ,sigmaf1 ,garea1 , & !in thsfc_loc ,prslkix ,prsik1x ,prslk1x , & !in - psfc ,pblhx ,iz0tlnd ,itime ,psi_opt , & tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout #ifdef CCPP @@ -440,8 +427,6 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair ! inputs integer , intent(in) :: nsnow !< maximum no. of snow layers integer , intent(in) :: nsoil !< number of soil layers - integer , intent(in) :: psi_opt - integer , intent(in) :: isnow !< actual no. of snow layers real (kind=kind_phys) , intent(in) :: dt !< time step [sec] real (kind=kind_phys) , intent(in) :: qsnow !< snowfall on the ground (mm/s) @@ -466,12 +451,6 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair real (kind=kind_phys) , intent(in) :: prslkix ! in exner function real (kind=kind_phys) , intent(in) :: prsik1x ! in exner function real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function - - real (kind=kind_phys) , intent(in) :: pblhx !< PBL height (m) - real (kind=kind_phys) , intent(in) :: psfc !< surface pressure - integer , intent(in) :: iz0tlnd !< z0t option - integer , intent(in) :: itime !< integration time - real (kind=kind_phys) , intent(in) :: sigmaf1 !< areal fractional cover of green vegetation real (kind=kind_phys) , intent(in) :: garea1 !< area of the grid cell @@ -582,9 +561,7 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in - thsfc_loc ,prslkix ,prsik1x ,prslk1x , & - psfc ,pblhx ,iz0tlnd ,itime ,uu ,vv , & - sigmaf1 ,garea1 ,psi_opt , & !in + thsfc_loc ,prslkix ,prsik1x ,prslk1x ,sigmaf1 ,garea1 , & !in #ifdef CCPP cm ,ch ,tg ,qsfc ,errmsg ,errflg , & !inout #else @@ -1020,9 +997,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in - thsfc_loc ,prslkix ,prsik1x ,prslk1x , & - psfc ,pblhx ,iz0tlnd ,itime ,uu ,vv , & - sigmaf1 ,garea1 ,psi_opt , & !in + thsfc_loc ,prslkix ,prsik1x ,prslk1x ,sigmaf1 ,garea1 , & !in #ifdef CCPP cm ,ch ,tgb ,qsfc ,errmsg ,errflg , & !inout #else @@ -1045,8 +1020,6 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ! input integer, intent(in) :: nsnow !< maximum no. of snow layers integer, intent(in) :: nsoil !< number of soil layers - integer, intent(in) :: psi_opt - real (kind=kind_phys), intent(in) :: emg !< ground emissivity integer, intent(in) :: isnow !< actual no. of snow layers real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: df !< thermal conductivity of snow/soil (w/m/k) @@ -1075,14 +1048,6 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso real (kind=kind_phys), intent(in) :: prslkix ! in exner function real (kind=kind_phys), intent(in) :: prsik1x ! in exner function real (kind=kind_phys), intent(in) :: prslk1x ! in exner function - - real (kind=kind_phys) , intent(in) :: pblhx !< - real (kind=kind_phys) , intent(in) :: psfc !< - integer , intent(in) :: iz0tlnd !< - integer , intent(in) :: itime !< integration time - real (kind=kind_phys) , intent(in) :: uu !< - real (kind=kind_phys) , intent(in) :: vv !< - real (kind=kind_phys), intent(in) :: sigmaf1 ! real (kind=kind_phys), intent(in) :: garea1 ! @@ -1130,19 +1095,11 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso integer :: iter !< iteration index real (kind=kind_phys) :: z0h !< roughness length, sensible heat, ground (m) - real (kind=kind_phys) :: qfx - real (kind=kind_phys) :: cq2 !< surface exchange at 2m - - real(kind=kind_phys) :: rb1i ! bulk richardson # real(kind=kind_phys) :: fm10i ! fm10 over land ice real(kind=kind_phys) :: stress1i! wind stress m2 S-2 - real(kind=kind_phys) :: wspd1i - real(kind=kind_phys) :: flhc1i - real(kind=kind_phys) :: flqc1i - real(kind=kind_phys) :: tv1i ! virtual potential temp @ ref level real(kind=kind_phys) :: thv1i ! virtual potential temp @ ref level @@ -1192,10 +1149,6 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso h = 0. - fh2 = 0. - qfx = 0. - - ! the following only applies to opt_sfc =3, opt_sfc = 1 still done its old way snwd = snowh*1000.0 @@ -1241,10 +1194,8 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso tem2 = max(sigmaf1, 0.1_kind_phys) zvfun1= sqrt(tem1 * tem2) gdx=sqrt(garea1) - - if(opt_sfc == 1 .or. opt_sfc == 2 .or. opt_sfc == 4) then !Add option for sfc scheme,use '1' for both '1'/'2' + if(opt_sfc == 1 .or. opt_sfc == 2) then !Add option for sfc scheme,use '1' for both '1'/'2' loop3: do iter = 1, niterb ! begin stability iteration - if(opt_sfc == 1 .or. opt_sfc == 2) then ! for now, only allow sfcdif1 until others can be fixed @@ -1260,45 +1211,8 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso #ifdef CCPP if (errflg /= 0) return #endif - endif - - if(opt_sfc == 4) then - - call sfcdif4(1 ,1 ,uu ,vv ,sfctmp , & !allow location for use in the driver - sfcprs ,psfc ,pblhx ,gdx ,z0m , & - itime ,snwd ,1 ,psi_opt, & - tgb ,qair ,zlvl ,iz0tlnd,qsfc , & ! use zlvli? - h ,qfx ,cm ,ch ,ch2 , & ! ch2 = cq2 most of times - cq2 ,moz ,fv ,rb1i, fm, fh, & - stress1i,fm10i ,fh2 , wspd1i ,flhc1i ,flqc1i) ! some are for use in the driver call - - - ! Undo the multiplication by windspeed that SFCDIF4 - ! applies to exchange coefficients CH and CM: - - ch = ch / wspd1i - cm = cm / wspd1i - ch2 = ch2 / wspd1i - cq2 = cq2 / wspd1i - - if(snwd > 0.) then - cm = min(0.01,cm) - ch = min(0.01,ch) - ch2 = min(0.01,ch2) - cq2 = min(0.01,cq2) - end if - - endif ! 4 - - ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) - - if(opt_sfc == 4) then - ramb = max(1.,1./(cm*wspd1i) ) - rahb = max(1.,1./(ch*wspd1i) ) - endif - rawb = rahb ! es and d(es)/dt evaluated at tg @@ -1350,7 +1264,6 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso estg = esati end if qsfc = 0.622*(estg*rhsur)/(sfcprs-0.378*(estg*rhsur)) - qfx = (qsfc-qair)*cev*gamma/cpair end do loop3 ! end stability iteration end if @@ -1449,12 +1362,6 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ! 2m air temperature ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) cq2b = ehb2 - - if (opt_sfc == 4) then - ehb2 = ch2 * wspd1i ! need conductance,z0h from sfcdif4 - cq2b = cq2 * wspd1i ! conductance - endif - if (ehb2.lt.1.e-5 ) then t2mb = tgb q2b = qsfc diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 345864f2e..98364b19c 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -10,22 +10,10 @@ module module_sf_noahmplsm use machine , only : kind_phys use sfc_diff, only : stability - use physcons, only : rcp => con_rocp, & - & ep_1 => con_fvirt, & - & ep_2 => con_eps, & - & r_d => con_rd, & - & cp => con_cp, & - & g => con_g, & - & xlv => con_hvap - - implicit none public :: noahmp_options public :: noahmp_sflx - public :: sfcdif4 - public :: psi_init - private :: atm private :: phenology @@ -385,32 +373,6 @@ module module_sf_noahmplsm end type noahmp_parameters -! -! for sfcdif4 -! - real, parameter :: prt=1. !prandtl number - real, parameter :: p1000mb = 100000. - - real, parameter :: svp1 = 0.6112 - real, parameter :: svp2 = 17.67 - real, parameter :: svp3 = 29.65 - real, parameter :: svpt0 = 273.15 - real, parameter :: ep_3=1.-ep_2 - real, parameter :: ep2=ep_2 - real, parameter :: onethird = 1./3. - real, parameter :: sqrt3 = 1.7320508075688773 - real, parameter :: atan1 = 0.785398163397 !in radians - - real, parameter :: karman = 0.4 - real, parameter :: vconvc=1.25 - - real, parameter :: snowz0 = 0.011 - real, parameter :: wmin = 0.1 - - real, dimension(0:1000 ),save :: psim_stab,psim_unstab, & - psih_stab,psih_unstab - - contains ! !== begin noahmp_sflx ============================================================================== @@ -423,7 +385,6 @@ subroutine noahmp_sflx (parameters, & smceq , & ! in : vegetation/soil characteristics sfctmp , sfcprs , psfc , uu , vv , q2, garea1 , & ! in : forcing qc , soldn , lwdn,thsfc_loc, prslkix,prsik1x,prslk1x,& ! in : forcing - pblhx , iz0tlnd , itime ,psi_opt ,& prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing tbot , co2air , o2air , foln , ficeold , zlvl , & ! in : forcing albold , sneqvo , & ! in/out : @@ -487,11 +448,6 @@ subroutine noahmp_sflx (parameters, & real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function real (kind=kind_phys) , intent(in) :: garea1 ! in exner function - real (kind=kind_phys) , intent(in) :: pblhx ! pbl height - integer , intent(in) :: iz0tlnd !< z0t option - integer , intent(in) :: itime !< - integer , intent(in) :: psi_opt !< - real (kind=kind_phys) , intent(inout) :: zlvl !< reference height (m) real (kind=kind_phys) , intent(in) :: cosz !< cosine solar zenith angle [0-1] real (kind=kind_phys) , intent(in) :: tbot !< bottom condition for soil temp. [k] @@ -726,6 +682,8 @@ subroutine noahmp_sflx (parameters, & logical :: crop_active !< flag to run crop model ! add canopy heat storage (C.He added based on GY Niu's communication) real :: canhs ! canopy heat storage change w/m2 +! maximum lai/sai used for some parameterizations based on plant growthi + ! intent (out) variables need to be assigned a value. these normally get assigned values ! only if dveg == 2. @@ -776,7 +734,7 @@ subroutine noahmp_sflx (parameters, & ! vegetation phenology call phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai ,igs, pgs) + lai , sai , troot , elai , esai ,igs, pgs) !input gvf should be consistent with lai if(dveg == 1 .or. dveg == 6 .or. dveg == 7) then @@ -820,11 +778,10 @@ subroutine noahmp_sflx (parameters, & sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in + elai ,esai ,fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in - pblhx ,iz0tlnd, itime ,psi_opt, & z0wrf ,z0hwrf , & !out imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out @@ -1100,7 +1057,7 @@ end subroutine atm !!vegetation phenology considering vegetation canopy being buried by snow and !!evolution in time. subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in - lai , sai , troot , elai , esai , igs, pgs) + lai , sai , troot , elai , esai , igs, pgs) ! -------------------------------------------------------------------------------------------------- ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time @@ -1659,11 +1616,10 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in - elai ,esai ,fwet ,foln , & !in + elai ,esai ,fwet ,foln , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in - pblhx , iz0tlnd, itime,psi_opt, & z0wrf ,z0hwrf , & !out imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out @@ -1744,11 +1700,6 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(in) :: prslk1x ! in exner function real (kind=kind_phys) , intent(in) :: garea1 - real (kind=kind_phys) , intent(in) :: pblhx ! pbl height - integer , intent(in) :: iz0tlnd - integer , intent(in) :: itime - integer , intent(in) :: psi_opt - real (kind=kind_phys) , intent(in) :: qair !specific humidity (kg/kg) real (kind=kind_phys) , intent(in) :: sfctmp !air temperature (k) real (kind=kind_phys) , intent(in) :: thair !potential temperature (k) @@ -2090,7 +2041,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , fveg, & !in + lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out @@ -2222,7 +2173,6 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in - pblhx ,iz0tlnd ,itime ,psi_opt , & eah ,tah ,tv ,tgv ,cmv, ustarx , & !inout #ifdef CCPP chv ,dx ,dz8w ,errmsg ,errflg , & !inout @@ -2259,7 +2209,6 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in emg ,stc ,df ,rsurf ,latheag , & !in gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in - pblhx ,iz0tlnd ,itime ,psi_opt , & #ifdef CCPP tgb ,cmb ,chb, ustarx,errmsg ,errflg , & !inout #else @@ -2312,11 +2261,6 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc q2e = fveg * q2v + (1.0 - fveg) * q2b -! effectibe skin temperature - - ts = (fveg*chv*tah + (1.0-fveg)*chb*tgb ) / ch - - ! new coupling code if (opt_trs == 1) then @@ -2487,7 +2431,7 @@ end subroutine energy subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in dt ,snowh ,snice ,snliq , & !in smc ,sh2o ,tg ,stc ,ur , & !in - lat ,z0m ,zlvl ,vegtyp , fveg,& !in + lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out fact ) !out ! ------------------------------------------------------------------------------------------------- @@ -2512,8 +2456,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys), intent(in) :: lat !latitude (radians) real (kind=kind_phys), intent(in) :: z0m !roughness length (m) real (kind=kind_phys), intent(in) :: zlvl !reference height (m) - integer , intent(in) :: vegtyp !vegtyp type - real (kind=kind_phys), intent(in) :: fveg !green vegetation fraction [0.0-1.0] + integer , intent(in) :: vegtyp !vegtyp type ! outputs real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] @@ -2562,7 +2505,6 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) - df(1) = df(1) * exp (sbeta * fveg) ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) @@ -3708,7 +3650,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in - fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in zlvl ,zpd ,z0m ,fveg ,shdfac, & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in @@ -3716,7 +3658,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in - pblhx ,iz0tlnd ,itime ,psi_opt , & eah ,tah ,tv ,tg ,cm,ustarx,& !inout #ifdef CCPP ch ,dx ,dz8w ,errmsg ,errflg , & !inout @@ -3764,12 +3705,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(in) :: dt !time step (s) real (kind=kind_phys), intent(in) :: fsno !snow fraction - real (kind=kind_phys) , intent(in) :: pblhx ! pbl height - integer , intent(in) :: iz0tlnd - integer , intent(in) :: itime - integer , intent(in) :: psi_opt - - real (kind=kind_phys), intent(in) :: snowh !actual snow depth [m] real (kind=kind_phys), intent(in) :: fwet !wetted fraction of canopy real (kind=kind_phys), intent(in) :: cwp !canopy wind parameter @@ -3853,10 +3788,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: wspd ! ------------------------ local variables ---------------------------------------------------- - real (kind=kind_phys) :: gdx !grid dx - real (kind=kind_phys) :: snwd ! snowdepth in mm - integer :: mnice ! MYNN ice flag - real (kind=kind_phys) :: cw !water vapor exchange coefficient real (kind=kind_phys) :: fv !friction velocity (m/s) real (kind=kind_phys) :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2) @@ -3920,15 +3851,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: ch2 !surface exchange at 2m real (kind=kind_phys) :: thstar !surface exchange at 2m - real (kind=kind_phys) :: fm10 - real (kind=kind_phys) :: rb1v - real (kind=kind_phys) :: stress1v - - - real (kind=kind_phys) :: flhcv ! for MYNN - real (kind=kind_phys) :: flqcv ! for MYNN - real (kind=kind_phys) :: wspdv ! for MYNN - real (kind=kind_phys) :: thvair real (kind=kind_phys) :: thah real (kind=kind_phys) :: rahc2 !aerodynamic resistance for sensible heat (s/m) @@ -3968,10 +3890,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity real (kind=kind_phys), intent( out) :: csigmaf1 ! real (kind=kind_phys) :: czil1 ! canopy based czil - real (kind=kind_phys) :: dlf ! leaf dimension - real(kind=kind_phys) :: kbsigmaf1 ! kb^-1 for fully convered by vegetation - real(kind=kind_phys) :: sigmaa ! kb^-1 for fully convered by vegetation - real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 @@ -4017,7 +3935,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & qsfc = 0.622*eair/(psfc-0.378*eair) ! canopy height - dlf = parameters%dleaf !leaf dimension + hcan = parameters%hvt uc = ur*log(hcan/z0m)/log(zlvl/z0m) uc = ur*log((hcan-zpd+z0m)/z0m)/log(zlvl/z0m) ! mb: add zpd v3.7 @@ -4062,21 +3980,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 cir = (2.-emv*(1.-emg))*emv*sb -! - if(opt_sfc == 4) then - - gdx = sqrt(garea1) - snwd = snowh * 1000.0 - fv = ustarx !inout in sfcdif4 - - if (snowh .gt. 0.1) then - mnice = 1 - else - mnice = 0 - endif - - endif - ! --------------------------------------------------------------------------------------------- loop1: do iter = 1, niterc ! begin stability iteration @@ -4097,10 +4000,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & else z0h = z0m*0.01 endif - elseif (opt_trs == 4) then - sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) - kbsigmaf1 = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(dlf*ur/log((zlvl-zpd)/z0m)) - z0h = z0m/exp(kbsigmaf1) endif ! aerodyn resistances between heights zlvl and d+z0v @@ -4134,43 +4033,14 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.true. ,vaie ,vegtyp, & !in - ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf1,cm ,ch ) !out endif - if(opt_sfc == 4) then - - call sfcdif4(iloc ,jloc ,uu ,vv ,sfctmp , & - sfcprs ,psfc ,pblhx ,gdx ,z0m , & - itime ,snwd ,mnice ,psi_opt, & - tah ,qair ,zlvl ,iz0tlnd,qsfc , & - h ,qfx ,cm ,ch ,ch2v , & - cq2v ,moz ,fv ,rb1v, fm, fh, & - stress1v,fm10 ,fh2 ,wspdv ,flhcv ,flqcv) - - - ! Undo the multiplication by windspeed that SFCDIF4 - ! applies to exchange coefficients CH and CM - - ch = ch / wspdv - cm = cm / wspdv - ch2v = ch2v / wspdv - - endif - - ramc = max(1.,1./(cm*ur)) rahc = max(1.,1./(ch*ur)) - - if (opt_sfc == 4 ) then - ramc = max(1.,1./(cm*wspdv) ) - rahc = max(1.,1./(ch*wspdv) ) - endif - rawc = rahc ! aerodyn resistance between heights z0g and d+z0v, rag, and leaf @@ -4280,11 +4150,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! consistent specific humidity from canopy air vapor pressure qsfc = (0.622*eah)/(sfcprs-0.378*eah) - if ( opt_sfc == 4 ) then - qfx = (qsfc-qair)*rhoair*caw - endif - - if (liter == 1) then exit loop1 endif @@ -4364,15 +4229,6 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & cah2 = fv*vkc/log((2.+z0h)/z0h) cah2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) cq2v = cah2 - endif - - if (opt_sfc == 4 ) then - rahc2 = max(1.,1./(ch2v*wspdv)) - rawc2 = rahc2 - cah2 = 1./rahc2 - cq2v = 1./max(1.,1./(cq2v*wspdv)) - endif - if (cah2 .lt. 1.e-5 ) then t2mv = tah ! q2v = (eah*0.622/(sfcprs - 0.378*eah)) @@ -4382,6 +4238,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! q2v = (eah*0.622/(sfcprs - 0.378*eah))- qfx/(rhoair*fv)* 1./vkc * log((2.+z0h)/z0h) q2v = qsfc - ((evc+tr)/fveg+evg)/(latheav*rhoair) * 1./cq2v endif + endif ! update ch for output ch = cah @@ -4402,7 +4259,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & emg ,stc ,df ,rsurf ,lathea , & !in gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in thsfc_loc, prslkix,prsik1x,prslk1x,fveg,shdfac,garea1, & !in - pblhx , iz0tlnd , itime ,psi_opt ,& #ifdef CCPP tgb ,cm ,ch,ustarx,errmsg ,errflg , & !inout #else @@ -4455,12 +4311,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) real (kind=kind_phys), intent(in) :: fsno !snow fraction - real (kind=kind_phys), intent(in) :: pblhx !pbl height (m) - integer, intent(in) :: iz0tlnd - integer, intent(in) :: itime - integer, intent(in) :: psi_opt - - !jref:start; in integer , intent(in) :: ivgtyp real (kind=kind_phys) , intent(in) :: qc !cloud water mixing ratio @@ -4502,19 +4352,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! local variables - real (kind=kind_phys) :: gdx !grid dx - real (kind=kind_phys) :: snwd ! snowdepth in mm - integer :: mnice ! MYNN ice flag - - real (kind=kind_phys) :: fm10 - real (kind=kind_phys) :: rb1b - real (kind=kind_phys) :: stress1b - - real (kind=kind_phys) :: wspdb - real (kind=kind_phys) :: flhcb - real (kind=kind_phys) :: flqcb -! - real (kind=kind_phys) :: taux !wind stress: e-w (n/m2) real (kind=kind_phys) :: tauy !wind stress: n-s (n/m2) real (kind=kind_phys) :: fira !total net longwave rad (w/m2) [+ to atm] @@ -4541,10 +4378,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: cev !coefficients for ev as function of esat[ts] real (kind=kind_phys) :: cgh !coefficients for st as function of ts - real(kind=kind_phys) :: kbsigmaf0 - real(kind=kind_phys) :: reynb - - !jref:start real (kind=kind_phys) :: rahb2 !aerodynamic resistance for sensible heat 2m (s/m) real (kind=kind_phys) :: rawb2 !aerodynamic resistance for water vapor 2m (s/m) @@ -4617,28 +4450,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & cir = emg*sb cgh = 2.*df(isnow+1)/dzsnso(isnow+1) - reynb = ustarx*z0m/(1.5e-05) - - if (reynb .gt. 2.0) then - kbsigmaf0 = 2.46*reynb**0.25 - log(7.4) - else - kbsigmaf0 = - log(0.397) - endif - - z0h = max(z0m/exp(kbsigmaf0),1.0e-6) - - if (opt_sfc == 4) then - fv = ustarx - gdx = sqrt(garea1) - snwd = snowh * 1000.0 - - if (snowh .gt. 0.1) then - mnice = 1 - else - mnice = 0 - endif - endif - ! ----------------------------------------------------------------- loop3: do iter = 1, niterb ! begin stability iteration @@ -4682,47 +4493,14 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,shdfac ,garea1 ,.false. ,0.0 ,ivgtyp , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out endif - if(opt_sfc == 4) then - - call sfcdif4(iloc ,jloc ,uu ,vv ,sfctmp , & - sfcprs ,psfc ,pblhx ,gdx ,z0m , & - itime ,snwd ,mnice ,psi_opt , & - tgb ,qair ,zlvl ,iz0tlnd,qsfc , & - h ,qfx ,cm ,ch ,ch2b , & - cq2b ,moz ,fv ,rb1b, fm, fh , & - stress1b,fm10 ,fh2 , wspdb ,flhcb ,flqcb) - - ! Undo the multiplication by windspeed that SFCDIF4 - ! applies to exchange coefficients CH and CM: - - ch = ch / wspdb - cm = cm / wspdb - ch2b = ch2b / wspdb - cq2b = cq2b / wspdb - - if(snwd > 0.) then - cm = min(0.01,cm) - ch = min(0.01,ch) - ch2b = min(0.01,ch2b) - cq2b = min(0.01,cq2b) - end if - - endif ! 4 - ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) - - if(opt_sfc == 4) then - ramb = max(1.,1./(cm*wspdb) ) - rahb = max(1.,1./(ch*wspdb) ) - endif - rawb = rahb !jref - variables for diagnostics @@ -4800,7 +4578,6 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !jref:start; errors in original equation corrected. ! 2m air temperature - if(opt_sfc == 1 .or. opt_sfc ==2 .or. opt_sfc == 3) then ehb2 = fv*vkc/log((2.+z0h)/z0h) ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) @@ -4812,25 +4589,8 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2 q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) endif - end if - - if(opt_sfc == 4) then ! consistent with veg - - rahb2 = max(1.,1./(ch2b*wspdb)) - ehb2 = 1./rahb2 - cq2b = 1./max(1.,1./(cq2b*wspdb)) ! - - if (ehb2.lt.1.e-5 ) then - t2mb = tgb - q2b = qsfc - else - t2mb = tgb - shb/(rhoair*cpair*ehb2) -! q2b = qsfc - qfx/(rhoair*cq2b) - q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) - end if - endif ! 4 - if (parameters%urban_flag) q2b = qsfc + end if ! update ch ch = ehb @@ -5345,7 +5105,7 @@ end subroutine sfcdif2 !! compute surface drag coefficient cm for momentum and ch for heat. subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh ,fveg ,garea1 ,vegetated,vaie ,vegtyp , & !in + zpd ,snowh ,fveg ,garea1 ,vegetated,vaie,vegtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf ,cm ,ch ) !out @@ -9991,1195 +9751,5 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc end subroutine noahmp_options - subroutine sfcdif4(iloc ,jloc ,ux ,vx ,t1d , & - p1d ,psfcpa,pblhx ,dx ,znt , & - itime ,snwh ,isice ,psi_opt, & - tsk ,qx ,zlvl ,iz0tlnd,qsfc , & - hfx ,qfx ,cm ,chs ,chs2 , & - cqs2 , & - rmolx ,ust , rbx, fmx, fhx,stressx,& - fm10x, fh2x, wspdx,flhcx,flqcx) - - - -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------- - -! input - - integer,intent(in ) :: iloc - integer,intent(in ) :: jloc - integer, intent(in) :: itime - - integer, intent(in) :: psi_opt - - integer, intent(in) :: isice ! for the glacier/snowh > 0.1m - - real, intent(in ) :: pblhx ! planetary boundary layer height - real, intent(in ) :: tsk ! skin temperature - real, intent(in ) :: psfcpa ! pressure in pascal - real, intent(in ) :: p1d !lowest model layer pressure (pa) - real, intent(in ) :: t1d !lowest model layer temperature - real, intent(in ) :: qx !water vapor specific humidity (kg/kg) from input - real, intent(in ) :: zlvl ! thickness of lowest full level layer - real, intent(in ) :: hfx ! sensible heat flux - real, intent(in ) :: qfx ! moisture flux - real, intent(in ) :: dx ! horisontal grid spacing - real, intent(in ) :: ux ! u and v winds - real, intent(in ) :: vx - real, intent(in ) :: znt ! z0m in m or inout - real, intent(in ) :: snwh ! in mm - -! optional vars - - integer,optional,intent(in ) :: iz0tlnd - - real, intent(inout) :: qsfc - real, intent(inout) :: ust - real, intent(inout) :: chs - real, intent(inout) :: chs2 - real, intent(inout) :: cqs2 - real, intent(inout) :: cm - - real, intent(inout) :: rmolx - real, intent(inout) :: rbx - real, intent(inout) :: fmx - real, intent(inout) :: fhx - real, intent(inout) :: stressx - real, intent(inout) :: fm10x - real, intent(inout) :: fh2x - - real, intent(inout) :: wspdx - real, intent(inout) :: flhcx - real, intent(inout) :: flqcx - - real :: zolx - real :: molx - -! diagnostics out -! real, intent(out) :: u10 -! real, intent(out) :: v10 -! real, intent(out) :: th2 -! real, intent(out) :: t2 -! real, intent(out) :: q2 -! real, intent(out) :: qsfc - - -! local - - real :: za ! height of full-sigma level - real :: thvx ! virtual potential temperature - real :: zqkl ! height of upper half level - real :: zqklp1 ! height of lower half level (surface) - real :: thx ! potential temperature - real :: psih ! similarity function for heat - real :: psih2 ! similarity function for heat 2m - real :: psih10 ! similarity function for heat 10m - real :: psim ! similarity function for momentum - real :: psim2 ! similarity function for momentum 2m - real :: psim10 ! similarity function for momentum 10m - - real :: gz1oz0 ! log(za/z0) - real :: gz2oz0 ! log(z2/z0) - real :: gz10oz0 ! log(z10/z0) - - real :: rhox ! density - real :: govrth ! g/theta for stability l - real :: tgdsa ! tsk - real :: tvir ! temporal variable src4 -> tvir - real :: thgb ! potential temperature ground - real :: psfcx ! surface pressure - real :: cpm - real :: qgh - - integer :: n,i,k,kk,l,nzol,nk,nzol2,nzol10 - - real :: zolzt, zolz0, zolza - real :: gz1ozt,gz2ozt,gz10ozt - - - real :: pl,thcon,tvcon,e1 - real :: zl,tskv,dthvdz,dthvm,vconv,rzol,rzol2,rzol10,zol2,zol10 - real :: dtg,psix,dtthx,psix10,psit,psit2,psiq,psiq2,psiq10 - real :: fluxc,vsgd,z0q,visc,restar,czil,restar2 - - real :: dqg - real :: tabs - real :: qsfcmr - real :: t1dc - real :: zt - real :: zq - real :: zratio - real :: qstar -!------------------------------------------------------------------- - - psfcx=psfcpa/1000. ! to kPa for saturation check - - if (itime == 1) then !init SP, MR - if (isice == 0) then - tabs = 0.5*(tsk + t1d) - if (tabs .lt. 273.15) then - !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) - e1=svp1*exp(4648*(1./273.15 - 1./tabs) - & - & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs)) - else - !saturation vapor pressure wrt water (bolton 1980) - e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3)) - endif - - qsfc =ep2*e1/(psfcx-ep_3*e1) !avg with the input? - qsfcmr =qsfc/(1.-qsfc) !to mixing ratio - endif - - if (isice == 1) then - if (tsk .lt. 273.15) then - !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) - e1=svp1*exp(4648*(1./273.15 - 1./tsk) - & - & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk)) - else - !saturation vapor pressure wrt water (bolton 1980) - e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3)) - endif - - qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity - qsfcmr=ep2*e1/(psfcx-e1) !mixing ratio - - endif - - else - ! use what comes out of the lsm - if (isice == 0) then - tabs = 0.5*(tsk + t1d) - if (tabs .lt. 273.15) then - !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) - e1=svp1*exp(4648*(1./273.15 - 1./tabs) - & - & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs)) - else - !saturation vapor pressure wrt water (bolton 1980) - e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3)) - endif - - qsfc =ep2*e1/(psfcx-ep_3*e1) ! avg with previous qsfc? - qsfcmr=qsfc/(1.-qsfc) - - endif - - if (isice == 1) then - if (tsk .lt. 273.15) then - !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) - e1=svp1*exp(4648*(1./273.15 - 1./tsk) - & - & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk)) - else - !saturation vapor pressure wrt water (bolton 1980) - e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3)) - endif - - qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity - qsfcmr=qsfc/(1.-qsfc) - - endif - - endif !done INIT if itime=1 -! convert (tah or tgb = tsk) temperature to potential temperature. - tgdsa = tsk - thgb = tsk*(p1000mb/psfcpa)**rcp !psfcpa is pa - -! store virtual, virtual potential and potential temperature - - pl = p1d/1000. - thx = t1d*(p1000mb*0.001/pl)**rcp - t1dc = t1d - 273.15 - - thvx = thx*(1.+ep_1*qx) !qx is SH from input - tvir = t1d*(1.+ep_1*qx) - - rhox=psfcx*1000./(r_d*tvir) - govrth=g/thx - za = zlvl - - !za=0.5*dz8w - - -! directly from input; check units - -! qfx = qflx * rhox -! hfx = hflx * rhox * cp - - - -! q2sat = qgh in lsm -!jref: canres and esat is calculated in the loop so should that be changed?? -! qgh=ep_2*e1/(pl-e1) -! cpm=cp*(1.+0.8*qx) - - -! qgh changed to use lowest-level air temp - - if (t1d .lt. 273.15) then - !saturation vapor pressure wrt ice - e1=svp1*exp(4648.*(1./273.15 - 1./t1d) - & - & 11.64*log(273.15/t1d) + 0.02265*(273.15 - t1d)) - else - !saturation vapor pressure wrt water (bolton 1980) - e1=svp1*exp(svp2*(t1d-svpt0)/(t1d-svp3)) - endif - - - !qgh=ep2*e1/(pl-ep_3*e1) !specific humidity - - qgh=ep2*e1/(pl-e1) !sat. mixing ratio ? - -! cpm=cp*(1.+0.84*qx) ! qx is SH - cpm=cp*(1.+0.84*qx/(1.0-qx) ) - - wspdx=sqrt(ux*ux+vx*vx) - - tskv=thgb*(1.+ep_1*qsfc) !avg with tsurf not used - dthvdz=(thvx-tskv) - - fluxc = max(hfx/rhox/cp + ep_1*tskv*qfx/rhox,0.) !hfx + qfx are fluxes units: wm^-2 and kg m^-2 s^-1 -! vconv = vconvc*(g/tgdsa*pblh*fluxc)**.33 - - vconv = vconvc*(g/tgdsa*min(1.5*pblhx,4000.0)*fluxc)**.33 !wstar -! vsgd = 0.32 * (max(dx/5000.-1.,0.))**.33 - - vsgd = min(0.32 * (max(dx/5000.-1.,0.))**.33,0.5) - wspdx=sqrt(wspdx*wspdx+vconv*vconv+vsgd*vsgd) - wspdx=max(wspdx,0.1) !0.1 is wmin - rbx=govrth*za*dthvdz/(wspdx*wspdx) !buld rich # - - if (itime == 1) then - rbx=max(rbx,-2.0) - rbx=min(rbx, 2.0) - else - rbx=max(rbx,-4.0) - rbx=min(rbx, 4.0) - endif - - -! visc=(1.32+0.009*(t1d-273.15))*1.e-5 -! kinematic viscosity - - - visc=1.326e-5*(1. + 6.542e-3*t1dc + 8.301e-6*t1dc*t1dc & - - 4.84e-9*t1dc*t1dc*t1dc) - -!compute roughness reynolds number (restar) using default znt -!the GFS option has been removed - - restar=max(ust*znt/visc,0.1) - -! get zt, zq based on the input -! the GFS roughness option and spp_pbl have been removed - - if (snwh > 50. .or. isice == 1) then ! (mm) treat as snow cover - use andreas cover isice =1 - call andreas_2002(znt,visc,ust,zt,zq) - else - if ( present(iz0tlnd) ) then - if ( iz0tlnd .le. 1 ) then - call zilitinkevich_1995(znt,zt,zq,restar,& - ust,karman,1.0,iz0tlnd,0,0.0) - elseif ( iz0tlnd .eq. 2 ) then - call yang_2008(znt,zt,zq,ust,molx,& - qstar,restar,visc) - elseif ( iz0tlnd .eq. 3 ) then - !original mynn in wrf-arw used this form: - call garratt_1992(zt,zq,znt,restar,1.0) - endif - -! the GFS option is removed along with gfs_z0_lnd - - else - - !default to zilitinkevich - call zilitinkevich_1995(znt,zt,zq,restar,& - ust,karman,1.0,0,0,0.0) - endif - endif - - -! --------- -! calculate bulk richardson no. of surface layer, -! according to akb(1976), eq(12). - - gz1oz0= log((za+znt)/znt) - gz1ozt= log((za+znt)/zt) - gz2oz0= log((2.0+znt)/znt) - gz2ozt= log((2.0+znt)/zt) - gz10oz0=log((10.+znt)/znt) -! gz10ozt=log((10.+znt)/zt) - - zratio=znt/zt !need estimate for li et al. - - -! vconv = 0.25*sqrt(g/tskv*pblh(i)*dthvm) -! if(mol.lt.0.) br=amin1(br,0.0) -> check the input mol later -! rmol=-govrth*dthvdz*za*karman - - if (rbx .gt. 0.0) then - - !compute z/l first guess: - call li_etal_2010(zolx,rbx,za/znt,zratio) - !zol=za*karman*g*mol/(thx*max(ust*ust,0.0001)) - zolx=max(zolx,0.0) - zolx=min(zolx,20.) - - - !use pedros iterative function to find z/l - !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt) - !use brute-force method - - zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt) - zolx=max(zolx,0.0) - zolx=min(zolx,20.) - - zolzt = zolx*zt/za ! zt/l - zolz0 = zolx*znt/za ! z0/l - zolza = zolx*(za+znt)/za ! (z+z0/l - zol10 = zolx*(10.+znt)/za ! (10+z0)/l - zol2 = zolx*(2.+znt)/za ! (2+z0)/l - - !compute psim and psih - !call psi_beljaars_holtslag_1991(psim,psih,zol) - !call psi_businger_1971(psim,psih,zol) - !call psi_zilitinkevich_esau_2007(psim,psih,zol) - !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za) - !call psi_cb2005(psim,psih,zolza,zolz0) - - psim=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) - psih=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) - psim10=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) -! psih10=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) - psih2=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt) - - ! 1.0 over monin-obukhov length - - rmolx= zolx/za - - elseif(rbx .eq. 0.) then - !========================================================= - !-----class 3; forced convection/neutral: - !========================================================= - - psim=0.0 - psih=psim - psim10=0. -! psih10=0. - psih2=0. - - zolx =0. - rmolx =0. - - elseif(rbx .lt. 0.)then - !========================================================== - !-----class 4; free convection: - !========================================================== - - !compute z/l first guess: - - call li_etal_2010(zolx,rbx,za/znt,zratio) - - !zol=za*karman*g*mol/(th1d*max(ust_lnd*ust_lnd,0.001)) - - zolx=max(zolx,-20.0) - zolx=min(zolx,0.0) - - - !use pedros iterative function to find z/l - !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt) - !use brute-force method - - zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt) - zolx=max(zolx,-20.0) - zolx=min(zolx,0.0) - - zolzt = zolx*zt/za ! zt/l - zolz0 = zolx*znt/za ! z0/l - zolza = zolx*(za+znt)/za ! (z+z0/l - zol10 = zolx*(10.+znt)/za ! (10+z0)/l - zol2 = zolx*(2.+znt)/za ! (2+z0)/l - - !compute psim and psih - !call psi_hogstrom_1996(psim,psih,zol, zt_lnd, zntstoch_lnd, za) - !call psi_businger_1971(psim,psih,zol) - !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za) - ! use tables - - psim=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) - psih=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) - psim10=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) -! psih10=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) - psih2=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt) - - !---limit psih and psim in the case of thin layers and - !---high roughness. this prevents denominator in fluxes - !---from getting too small - - psih=min(psih,0.9*gz1ozt) - psim=min(psim,0.9*gz1oz0) - psih2=min(psih2,0.9*gz2ozt) - psim10=min(psim10,0.9*gz10oz0) -! psih10=min(psih10,0.9*gz10ozt) - - rmolx = zolx/za - - endif - - ! calculate the resistance: - - psix =max(gz1oz0-psim, 1.0) - psix10=max(gz10oz0-psim10, 1.0) - psit =max(gz1ozt-psih , 1.0) - psit2 =max(gz2ozt-psih2, 1.0) - psiq =max(log((za+zq)/zq)-psih ,1.0) - psiq2 =max(log((2.0+zq)/zq)-psih2 ,1.0) - - !------------------------------------------------------------ - !-----compute the frictional velocity: - !------------------------------------------------------------ - - - ! to prevent oscillations average with old value - -! oldust = ust - - ust=0.5*ust+0.5*karman*wspdx/psix - ust=max(ust,0.005) - -! stress=ust**2 - - !set ustm = ust over land. - -! ustmx=ust - - - !---------------------------------------------------- - !----compute the temperature scale (a.k.a. friction temperature, t*, or mol) - !----and compute the moisture scale (or q*) - !---------------------------------------------------- - - dtg=thvx-tskv - -! oldtst=mol - - molx=karman*dtg/psit/prt !T* - - !t_star = -hfx/(ust*cpm*rho1d) - !t_star = mol - !---------------------------------------------------- - ! dqg=(qvsh-qsfc)*1000. !(kg/kg -> g/kg) - - dqg=(qx-qsfc)*1000. !(kg/kg -> g/kg) - qstar=karman*dqg/psiq/prt - - cm = (karman/psix)*(karman/psix)*wspdx - -! cm = (karman/psix)*(karman/psix) -! ch = (karman/psix)*(karman/psit) - - chs=ust*karman/psit - cqs2=ust*karman/psiq2 - chs2=ust*karman/psit2 - -! u10=ux*psix10/psix -! v10=vx*psix10/psix - - flhcx = rhox*cpm*ust*karman/psit - flqcx = rhox*1.0*ust*karman/psiq - -! ch = flhcx/(cpm*rhox) !same chs - - fmx = psix - fhx = psit - fm10x = psix10 - fh2x =psit2 - -! ustmx = ust - - stressx = ust**2 ! or cm*wind*wind - - end subroutine sfcdif4 - - subroutine zilitinkevich_1995(z_0,zt,zq,restar,ustar,karman,& - & landsea,iz0tlnd2,spp_pbl,rstoch) - - implicit none - real, intent(in) :: z_0,restar,ustar,karman,landsea - integer, optional, intent(in):: iz0tlnd2 - real, intent(out) :: zt,zq - real :: czil !=0.100 in chen et al. (1997) - !=0.075 in zilitinkevich (1995) - !=0.500 in lemone et al. (2008) - integer, intent(in) :: spp_pbl - real, intent(in) :: rstoch - - - if (landsea-1.5 .gt. 0) then !water - - !this is based on zilitinkevich, grachev, and fairall (2001; - !their equations 15 and 16). - if (restar .lt. 0.1) then - zt = z_0*exp(karman*2.0) - zt = min( zt, 6.0e-5) - zt = max( zt, 2.0e-9) - zq = z_0*exp(karman*3.0) - zq = min( zq, 6.0e-5) - zq = max( zq, 2.0e-9) - else - zt = z_0*exp(-karman*(4.0*sqrt(restar)-3.2)) - zt = min( zt, 6.0e-5) - zt = max( zt, 2.0e-9) - zq = z_0*exp(-karman*(4.0*sqrt(restar)-4.2)) - zq = min( zt, 6.0e-5) - zq = max( zt, 2.0e-9) - endif - - else !land - - !option to modify czil according to chen & zhang, 2009 - if ( iz0tlnd2 .eq. 1 ) then - czil = 10.0 ** ( -0.40 * ( z_0 / 0.07 ) ) - else - czil = 0.085 !0.075 !0.10 - end if - - zt = z_0*exp(-karman*czil*sqrt(restar)) - zt = min( zt, 0.75*z_0) - - zq = z_0*exp(-karman*czil*sqrt(restar)) - zq = min( zq, 0.75*z_0) - -! stochastically perturb thermal and moisture roughness length. -! currently set to half the amplitude: - if (spp_pbl==1) then - zt = zt + zt * 0.5 * rstoch - zt = max(zt, 0.0001) - zq = zt - endif - - endif - - return - - end subroutine zilitinkevich_1995 - -!!data. the formula for land uses a constant ratio (z_0/7.4) taken -!!from garratt (1992). - subroutine garratt_1992(zt,zq,z_0,ren,landsea) - - implicit none - real, intent(in) :: ren, z_0,landsea - real, intent(out) :: zt,zq - real :: rq - real, parameter :: e=2.71828183 - - if (landsea-1.5 .gt. 0) then !water - - zt = z_0*exp(2.0 - (2.48*(ren**0.25))) - zq = z_0*exp(2.0 - (2.28*(ren**0.25))) - - zq = min( zq, 5.5e-5) - zq = max( zq, 2.0e-9) - zt = min( zt, 5.5e-5) - zt = max( zt, 2.0e-9) !same lower limit as ecmwf - else !land - zq = z_0/(e**2.) !taken from garratt (1980,1992) - zt = zq - endif - - return - - end subroutine garratt_1992 -!-------------------------------------------------------------------- -!>\ingroup mynn_sfc -!> this is a modified version of yang et al (2002 qjrms, 2008 jamc) -!! and chen et al (2010, j of hydromet). although it was originally -!! designed for arid regions with bare soil, it is modified -!! here to perform over a broader spectrum of vegetation. -!! -!!the original formulation relates the thermal roughness length (zt) -!!to u* and t*: -!! -!! zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar)**0.25)) -!! -!!where ht = renc*visc/ustar and the critical reynolds number -!!(renc) = 70. beta was originally = 10 (2002 paper) but was revised -!!to 7.2 (in 2008 paper). their form typically varies the -!!ratio z0/zt by a few orders of magnitude (1-1e4). -!! -!!this modified form uses beta = 1.5 and a variable renc (function of z_0), -!!so zt generally varies similarly to the zilitinkevich form (with czil = 0.1) -!!for very small or negative surface heat fluxes but can become close to the -!!zilitinkevich with czil = 0.2 for very large hfx (large negative t*). -!!also, the exponent (0.25) on tstar was changed to 1.0, since we found -!!zt was reduced too much for low-moderate positive heat fluxes. -!! -!!this should only be used over land! - 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 :: ht, &! roughness height at critical reynolds number - tstar2, &! bounded t*, forced to be non-positive - qstar2, &! bounded q*, forced to be non-positive - z_02, &! bounded z_0 for variable renc2 calc - renc2 ! variable renc, function of z_0 - real, intent(out) :: zt,zq - real, parameter :: renc=300., & !old constant renc - beta=1.5, & !important for diurnal variation - m=170., & !slope for renc2 function - b=691. !y-intercept for renc2 function - - z_02 = min(z_0,0.5) - z_02 = max(z_02,0.04) - renc2= b + m*log(z_02) - ht = renc2*visc/max(ustar,0.01) - tstar2 = min(tstar, 0.0) - qstar2 = min(qst,0.0) - - zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar2)**1.0)) - zq = ht * exp(-beta*(ustar**0.5)*(abs(qstar2)**1.0)) - !zq = zt - - zt = min(zt, z_0/2.0) - zq = min(zq, z_0/2.0) - - return - - end subroutine yang_2008 - -!>\ingroup mynn_sfc -!> this is taken from andreas (2002; j. of hydromet) and -!! andreas et al. (2005; blm). -!! -!! this should only be used over snow/ice! - subroutine andreas_2002(z_0,bvisc,ustar,zt,zq) - - implicit none - real, intent(in) :: z_0, bvisc, ustar - real, intent(out) :: zt, zq - real :: ren2, zntsno - - real, parameter :: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, & - bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, & - bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183 - - real, parameter :: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, & - bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, & - bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180 - - !calculate zo for snow (andreas et al. 2005, blm) - zntsno = 0.135*bvisc/ustar + & - (0.035*(ustar*ustar)/9.8) * & - (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.) - ren2 = ustar*zntsno/bvisc - - ! make sure that re is not outside of the range of validity - ! for using their equations - if (ren2 .gt. 1000.) ren2 = 1000. - - if (ren2 .le. 0.135) then - - zt = zntsno*exp(bt0_s + bt1_s*log(ren2) + bt2_s*log(ren2)**2) - zq = zntsno*exp(bq0_s + bq1_s*log(ren2) + bq2_s*log(ren2)**2) - - else if (ren2 .gt. 0.135 .and. ren2 .lt. 2.5) then - - zt = zntsno*exp(bt0_t + bt1_t*log(ren2) + bt2_t*log(ren2)**2) - zq = zntsno*exp(bq0_t + bq1_t*log(ren2) + bq2_t*log(ren2)**2) - - else - - zt = zntsno*exp(bt0_r + bt1_r*log(ren2) + bt2_r*log(ren2)**2) - zq = zntsno*exp(bq0_r + bq1_r*log(ren2) + bq2_r*log(ren2)**2) - - endif - - return - - end subroutine andreas_2002 -!-------------------------------------------------------------------- -!>\ingroup mynn_sfc -!! this subroutine returns a more robust z/l that best matches -!! the z/l from hogstrom (1996) for unstable conditions and beljaars -!! and holtslag (1991) for stable conditions. - subroutine li_etal_2010(zl, rib, zaz0, z0zt) - - implicit none - real, intent(out) :: zl - real, intent(in) :: rib, 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, & - &bu32=-0.9213, bu33=-0.1057 - real, parameter :: aw11=0.5738, aw12=-0.4399, aw21=-4.901,& - &aw22=52.50, bw11=-0.0539, bw12=1.540, & - &bw21=-0.669, bw22=-3.282 - real, parameter :: as11=0.7529, as21=14.94, bs11=0.1569,& - &bs21=-0.3091, bs22=-1.303 - - !set limits according to li et al (2010), p 157. - zaz02=zaz0 - if (zaz0 .lt. 100.0) zaz02=100. - if (zaz0 .gt. 100000.0) zaz02=100000. - - !set more limits according to li et al (2010) - z0zt2=z0zt - if (z0zt .lt. 0.5) z0zt2=0.5 - if (z0zt .gt. 100.0) z0zt2=100. - - alfa = log(zaz02) - beta = log(z0zt2) - - if (rib .le. 0.0) then - zl = au11*alfa*rib**2 + ( & - & (bu11*beta + bu12)*alfa**2 + & - & (bu21*beta + bu22)*alfa + & - & (bu31*beta**2 + bu32*beta + bu33))*rib - !if(zl .lt. -15 .or. zl .gt. 0.)print*,"violation rib<0:",zl - zl = max(zl,-15.) !limits set according to li et al (2010) - zl = min(zl,0.) !figure 1. - elseif (rib .gt. 0.0 .and. rib .le. 0.2) then - zl = ((aw11*beta + aw12)*alfa + & - & (aw21*beta + aw22))*rib**2 + & - & ((bw11*beta + bw12)*alfa + & - & (bw21*beta + bw22))*rib - !if(zl .lt. 0 .or. zl .gt. 4)print*,"violation 00.2:",zl - zl = min(zl,20.) !limits according to li et al (2010), thier - !figue 1c. - zl = max(zl,1.) - endif - - return - - end subroutine li_etal_2010 -!------------------------------------------------------------------- - real 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 - ! summarized in jimenez et al. (2012, mwr). this function was adapted - ! to input the thermal roughness length, zt, (as well as z0) and use initial - ! estimate of z/l. - - implicit none - real, intent(in) :: ri,za,z0,zt,zol1 - integer, intent(in) :: psi_opt - real :: x1,x2,fx1,fx2 - integer :: n - integer, parameter :: nmax = 20 - !real, dimension(nmax):: zlhux -! real :: zolri2 - - if (ri.lt.0.)then - x1=zol1 - 0.02 !-5. - x2=0. - else - x1=0. - x2=zol1 + 0.02 !5. - endif - - n=1 - fx1=zolri2(x1,ri,za,z0,zt,psi_opt) - fx2=zolri2(x2,ri,za,z0,zt,psi_opt) - - do while (abs(x1 - x2) > 0.01 .and. n < nmax) - if(abs(fx2).lt.abs(fx1))then - x1=x1-fx1/(fx2-fx1)*(x2-x1) - fx1=zolri2(x1,ri,za,z0,zt,psi_opt) - zolri=x1 - else - x2=x2-fx2/(fx2-fx1)*(x2-x1) - fx2=zolri2(x2,ri,za,z0,zt,psi_opt) - zolri=x2 - endif - n=n+1 - !print*," n=",n," x1=",x1," x2=",x2 - !zlhux(n)=zolri - enddo - - if (n==nmax .and. abs(x1 - x2) >= 0.01) then - !if convergence fails, use approximate values: - call li_etal_2010(zolri, ri, za/z0, z0/zt) - !zlhux(n)=zolri - !print*,"iter fail, n=",n," ri=",ri," z0=",z0 - else - !print*,"success,n=",n," ri=",ri," z0=",z0 - endif - - return - end function -!------------------------------------------------------------------- - real function zolri2(zol2,ri2,za,z0,zt,psi_opt) - - ! input: ================================= - ! zol2 - estimated z/l - ! ri2 - calculated bulk richardson number - ! za - 1/2 depth of first model layer - ! z0 - aerodynamic roughness length - ! zt - thermal roughness length - ! output: ================================ - ! zolri2 - delta ri - - implicit none - integer, intent(in) :: psi_opt - real, intent(in) :: ri2,za,z0,zt - real, intent(inout) :: zol2 - real :: zol20,zol3,psim1,psih1,psix2,psit2,zolt - -! real :: psih_unstable,psim_unstable,psih_stable, psim_stable - - if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 - - zol20=zol2*z0/za ! z0/l - zol3=zol2+zol20 ! (z+z0)/l - zolt=zol2*zt/za ! zt/l - - if (ri2.lt.0) then - !psix2=log((za+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) - !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) - psit2=max(log((za+z0)/zt)-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) - psix2=max(log((za+z0)/z0)-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)),1.0) - else - !psix2=log((za+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) - !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) - psit2=max(log((za+z0)/zt)-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) - psix2=max(log((za+z0)/z0)-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)),1.0) - endif - - zolri2=zol2*psit2/psix2**2 - ri2 - !print*," target ri=",ri2," est ri=",zol2*psit2/psix2**2 - - return - end function -!==================================================================== - - real 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 - integer, intent(in) :: psi_opt - real, intent(inout) :: zol1 - real :: zol20,zol3,zolt,zolold - integer :: n - integer, parameter :: nmax = 20 - real, dimension(nmax):: zlhux - real :: psit2,psix2 - -! real :: psim_unstable, psim_stable -! real :: psih_unstable, psih_stable - - !print*,"+++++++incoming: z/l=",zol1," ri=",ri - if (zol1*ri .lt. 0.) then - !print*,"begin: wrong quadrants: z/l=",zol1," ri=",ri - zol1=0. - endif - - if (ri .lt. 0.) then - zolold=-99999. - zolrib=-66666. - else - zolold=99999. - zolrib=66666. - endif - n=1 - - do while (abs(zolold - zolrib) > 0.01 .and. n < nmax) - - if(n==1)then - zolold=zol1 - else - zolold=zolrib - endif - zol20=zolold*z0/za ! z0/l - zol3=zolold+zol20 ! (z+z0)/l - zolt=zolold*zt/za ! zt/l - !print*,"z0/l=",zol20," (z+z0)/l=",zol3," zt/l=",zolt - if (ri.lt.0) then - !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) - !psit2=log((za+z0)/zt)-(psih_unstable(zol3)-psih_unstable(zol20)) - psit2=max(logzt-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) - psix2=max(logz0-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)), 1.0) - else - !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20)) - !psit2=log((za+z0)/zt)-(psih_stable(zol3)-psih_stable(zol20)) - psit2=max(logzt-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) - psix2=max(logz0-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)), 1.0) - endif - !print*,"n=",n," psit2=",psit2," psix2=",psix2 - zolrib=ri*psix2**2/psit2 - zlhux(n)=zolrib - n=n+1 - enddo - - if (n==nmax .and. abs(zolold - zolrib) > 0.01 ) then - !print*,"iter fail, n=",n," ri=",ri," z/l=",zolri - !if convergence fails, use approximate values: - call li_etal_2010(zolrib, ri, za/z0, z0/zt) - zlhux(n)=zolrib - !print*,"failed, n=",n," ri=",ri," z0=",z0 - !print*,"z/l=",zlhux(1:nmax) - else - !if(zolrib*ri .lt. 0.) then - ! !print*,"end: wrong quadrants: z/l=",zolrib," ri=",ri - ! !call li_etal_2010(zolrib, ri, za/z0, z0/zt) - !endif - !print*,"success,n=",n," ri=",ri," z0=",z0 - endif - - return - end function -!==================================================================== - - subroutine psi_init(psi_opt,errmsg,errflg) - - integer :: n,psi_opt - real :: zolf - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - if (psi_opt == 0) then - do n=0,1000 - ! stable function tables - zolf = float(n)*0.01 - psim_stab(n)=psim_stable_full(zolf) - psih_stab(n)=psih_stable_full(zolf) - - ! unstable function tables - zolf = -float(n)*0.01 - psim_unstab(n)=psim_unstable_full(zolf) - psih_unstab(n)=psih_unstable_full(zolf) - enddo - else - do n=0,1000 - ! stable function tables - zolf = float(n)*0.01 - psim_stab(n)=psim_stable_full_gfs(zolf) - psih_stab(n)=psih_stable_full_gfs(zolf) - - ! unstable function tables - zolf = -float(n)*0.01 - psim_unstab(n)=psim_unstable_full_gfs(zolf) - psih_unstab(n)=psih_unstable_full_gfs(zolf) - enddo - endif - - !simple test to see if initialization worked: - if (psim_stab(1) < 0. .and. psih_stab(1) < 0. .and. & - psim_unstab(1) > 0. .and. psih_unstab(1) > 0.) then - errmsg = 'in mynn sfc, psi tables have been initialized' - errflg = 0 - else - errmsg = 'error in mynn sfc: problem initializing psi tables' - errflg = 1 - endif - - end subroutine psi_init -! ================================================================== -! ... integrated similarity functions from mynn... -! -!>\ingroup mynn_sfc - real function psim_stable_full(zolf) - real :: zolf - - !psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) - psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**0.4) - - return - end function - -!>\ingroup mynn_sfc - real function psih_stable_full(zolf) - real :: zolf - - !psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) - psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**0.9090909090909090909) - - return - end function - -!>\ingroup mynn_sfc - real function psim_unstable_full(zolf) - real :: zolf,x,ym,psimc,psimk - - x=(1.-16.*zolf)**.25 - !psimk=2*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan(1.) - psimk=2.*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan1 - - ym=(1.-10.*zolf)**onethird - !psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*atan((2.*ym+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.) - psimc=1.5*log((ym**2 + ym+1.)*onethird)-sqrt3*atan((2.*ym+1)/sqrt3)+4.*atan1/sqrt3 - - psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.) - - return - end function - -!>\ingroup mynn_sfc - real function psih_unstable_full(zolf) - real :: zolf,y,yh,psihc,psihk - - y=(1.-16.*zolf)**.5 - !psihk=2.*log((1+y)/2.) - psihk=2.*log((1+y)*0.5) - - yh=(1.-34.*zolf)**onethird - !psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*atan((2.*yh+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.) - psihc=1.5*log((yh**2.+yh+1.)*onethird)-sqrt3*atan((2.*yh+1)/sqrt3)+4.*atan1/sqrt3 - - psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2) - - return - end function - -! ================================================================== -! ... integrated similarity functions from gfs... -! - real function psim_stable_full_gfs(zolf) - real :: zolf - real, parameter :: alpha4 = 20. - real :: aa - - aa = sqrt(1. + alpha4 * zolf) - psim_stable_full_gfs = -1.*aa + log(aa + 1.) - - return - end function - - real function psih_stable_full_gfs(zolf) - real :: zolf - real, parameter :: alpha4 = 20. - real :: bb - - bb = sqrt(1. + alpha4 * zolf) - psih_stable_full_gfs = -1.*bb + log(bb + 1.) - - return - end function - - real function psim_unstable_full_gfs(zolf) - real :: zolf - real :: hl1,tem1 - real, parameter :: a0=-3.975, a1=12.32, & - b1=-7.755, b2=6.041 - - if (zolf .ge. -0.5) then - hl1 = zolf - psim_unstable_full_gfs = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) - else - hl1 = -zolf - tem1 = 1.0 / sqrt(hl1) - psim_unstable_full_gfs = log(hl1) + 2. * sqrt(tem1) - .8776 - end if - - return - end function - - real function psih_unstable_full_gfs(zolf) - real :: zolf - real :: hl1,tem1 - real, parameter :: a0p=-7.941, a1p=24.75, & - b1p=-8.705, b2p=7.899 - - if (zolf .ge. -0.5) then - hl1 = zolf - psih_unstable_full_gfs = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) - else - hl1 = -zolf - tem1 = 1.0 / sqrt(hl1) - psih_unstable_full_gfs = log(hl1) + .5 * tem1 + 1.386 - end if - - return - end function - -!================================================================= -! look-up table functions - or, if beyond -10 < z/l < 10, recalculate -!================================================================= - real function psim_stable(zolf,psi_opt) - integer :: nzol,psi_opt - real :: rzol,zolf - - nzol = int(zolf*100.) - rzol = zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) - else - if (psi_opt == 0) then - psim_stable = psim_stable_full(zolf) - else - psim_stable = psim_stable_full_gfs(zolf) - endif - endif - - return - end function - - real function psih_stable(zolf,psi_opt) - integer :: nzol,psi_opt - real :: rzol,zolf - - nzol = int(zolf*100.) - rzol = zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) - else - if (psi_opt == 0) then - psih_stable = psih_stable_full(zolf) - else - psih_stable = psih_stable_full_gfs(zolf) - endif - endif - - return - end function - - real function psim_unstable(zolf,psi_opt) - integer :: nzol,psi_opt - real :: rzol,zolf - - nzol = int(-zolf*100.) - rzol = -zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) - else - if (psi_opt == 0) then - psim_unstable = psim_unstable_full(zolf) - else - psim_unstable = psim_unstable_full_gfs(zolf) - endif - endif - - return - end function - - real function psih_unstable(zolf,psi_opt) - integer :: nzol,psi_opt - real :: rzol,zolf - - nzol = int(-zolf*100.) - rzol = -zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) - else - if (psi_opt == 0) then - psih_unstable = psih_unstable_full(zolf) - else - psih_unstable = psih_unstable_full_gfs(zolf) - endif - endif - - return - end function -!======================================================================== end module module_sf_noahmplsm diff --git a/physics/sfc_noahmp_drv.F90 b/physics/sfc_noahmp_drv.F90 index ccd9f80f6..0ebcbd615 100644 --- a/physics/sfc_noahmp_drv.F90 +++ b/physics/sfc_noahmp_drv.F90 @@ -11,12 +11,8 @@ !> This module contains the CCPP-compliant NoahMP land surface model driver. module noahmpdrv - use module_sf_noahmplsm - implicit none - integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS - private public :: noahmpdrv_init, noahmpdrv_run, noahmpdrv_finalize @@ -31,7 +27,6 @@ module noahmpdrv !! subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & nlunit, pores, resid, & - do_mynnsfclay,do_mynnedmf, & errmsg, errflg) use machine, only: kind_phys @@ -45,10 +40,6 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & real (kind=kind_phys), dimension(:), intent(out) :: pores, resid - logical, intent(in) :: do_mynnsfclay - logical, intent(in) :: do_mynnedmf - - character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -77,31 +68,9 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & return end if - if (.not. do_mynnsfclay .and. do_mynnedmf) then - errmsg = 'Problem : do_mynnsfclay = .false.' // & - 'but mynnpbl is .true.. Exiting ...' - errflg = 1 - return - end if - - if ( do_mynnsfclay .and. .not. do_mynnedmf) then - errmsg = 'Problem : do_mynnsfclay = .true.' // & - 'but mynnpbl is .false.. Exiting ...' - errflg = 1 - return - end if - - !--- initialize soil vegetation call set_soilveg(me, isot, ivegsrc, nlunit) - - ! initialize psih and psim - - if ( do_mynnsfclay ) then - call psi_init(psi_opt,errmsg,errflg) - endif - pores (:) = maxsmc (:) resid (:) = drysmc (:) @@ -138,7 +107,7 @@ subroutine noahmpdrv_run & ! --- inputs: ( im, km, lsnowl, itime, ps, u1, v1, t1, q1, soiltyp, & vegtype, sigmaf, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & - prsl1, prslk1, prslki, prsik1, zf,pblh, dry, wind, slopetyp, & + prsl1, prslk1, prslki, prsik1, zf, dry, wind, slopetyp, & shdmin, shdmax, snoalb, sfalb, flag_iter,con_g, & idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & @@ -151,7 +120,6 @@ subroutine noahmpdrv_run & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & canopy, trans, tsurf, zorl, & rb1, fm1, fh1, ustar1, stress1, fm101, fh21, & - rmol1,flhc1,flqc1,do_mynnsfclay, & ! --- Noah MP specific @@ -172,7 +140,7 @@ subroutine noahmpdrv_run & use funcphys, only : fpvs use sfc_diff, only : stability -! use module_sf_noahmplsm + use module_sf_noahmplsm use module_sf_noahmp_glacier use noahmp_tables, only : isice_table, co2_table, o2_table, & isurban_table, smcref_table, smcdry_table, & @@ -192,8 +160,6 @@ subroutine noahmpdrv_run & integer, parameter :: nsoil = 4 ! hardwired to Noah integer, parameter :: nsnow = 3 ! max. snow layers - integer, parameter :: iz0tlnd = 0 ! z0t treatment option - real(kind=kind_phys), save :: zsoil(nsoil) data zsoil / -0.1, -0.4, -1.0, -2.0 / @@ -227,15 +193,6 @@ subroutine noahmpdrv_run & real(kind=kind_phys), dimension(:) , intent(in) :: prsik1 ! Exner function at the ground surfac real(kind=kind_phys), dimension(:) , intent(in) :: zf ! height of bottom layer [m] - - logical , intent(in) :: do_mynnsfclay !flag for MYNN sfc layer scheme - - real(kind=kind_phys), dimension(:) , intent(in) :: pblh ! height of pbl - real(kind=kind_phys), dimension(:) , intent(inout) :: rmol1 ! - real(kind=kind_phys), dimension(:) , intent(inout) :: flhc1 ! - real(kind=kind_phys), dimension(:) , intent(inout) :: flqc1 ! - - logical , dimension(:) , intent(in) :: dry ! = T if a point with any land real(kind=kind_phys), dimension(:) , intent(in) :: wind ! wind speed [m/s] integer , dimension(:) , intent(in) :: slopetyp ! surface slope classification @@ -548,17 +505,6 @@ subroutine noahmpdrv_run & real (kind=kind_phys) :: prsik1x ! in exner function real (kind=kind_phys) :: prslk1x ! in exner function - real (kind=kind_phys) :: ch2 - real (kind=kind_phys) :: cq2 - real (kind=kind_phys) :: qfx - real (kind=kind_phys) :: wspd1 ! wind speed with all components - real (kind=kind_phys) :: pblhx ! height of pbl - integer :: mnice - - real (kind=kind_phys) :: rah_total ! - real (kind=kind_phys) :: cah_total ! - - ! ! --- local variable ! @@ -648,8 +594,6 @@ subroutine noahmpdrv_run & vwind_forcing = v1(i) area_grid = garea(i) - pblhx = pblh(i) - prslkix = prslki(i) prsik1x = prsik1(i) prslk1x = prslk1(i) @@ -738,13 +682,6 @@ subroutine noahmpdrv_run & snow_ice_frac_old(k) = snow_level_ice(k) /(snow_level_ice(k)+snow_level_liquid(k)) end do - - if (snow_depth .gt. 0.1 .or. vegetation_category == isice_table ) then - mnice = 1 - else - mnice = 0 - endif - ! ! --- some outputs for atm model? ! @@ -788,8 +725,7 @@ subroutine noahmpdrv_run & spec_humidity_forcing,sw_radiation_forcing ,precipitation_forcing,radiation_lw_forcing , & temperature_soil_bot ,forcing_height ,snow_ice_frac_old ,zsoil , & thsfc_loc ,prslkix ,prsik1x ,prslk1x , & - air_pressure_surface ,pblhx ,iz0tlnd ,itime , & - vegetation_frac ,area_grid ,psi_opt , & + vegetation_frac ,area_grid , & snowfall ,snow_water_equiv_old ,snow_albedo_old , & cm_noahmp ,ch_noahmp ,snow_levels ,snow_water_equiv , & soil_moisture_vol ,interface_depth ,snow_depth ,snow_level_ice , & @@ -868,8 +804,6 @@ subroutine noahmpdrv_run & spec_humidity_forcing ,area_grid ,cloud_water_forcing , & sw_radiation_forcing ,radiation_lw_forcing ,thsfc_loc , & prslkix ,prsik1x ,prslk1x , & - pblhx ,iz0tlnd ,itime , & - psi_opt , & precip_convective , & precip_non_convective ,precip_sh_convective ,precip_snow , & precip_graupel ,precip_hail ,temperature_soil_bot , & @@ -989,7 +923,7 @@ subroutine noahmpdrv_run & snowc (i) = snow_cover_fraction sncovr1 (i) = snow_cover_fraction -! qsurf (i) = spec_humidity_surface + qsurf (i) = spec_humidity_surface tsurf (i) = tskin(i) tvxy (i) = temperature_leaf @@ -1052,49 +986,11 @@ subroutine noahmpdrv_run & zvfun(i) = sqrt(tem1 * tem2) gdx=sqrt(garea(i)) - if ( .not. do_mynnsfclay) then !GFS sfcdiff - call stability & (zf(i), zvfun(i), gdx, virtual_temperature, vptemp,wind(i), z0_total, z0h_total, & tvs1, con_g, thsfc_loc, & rb1(i), fm1(i), fh1(i), fm101(i), fh21(i), cm(i), ch(i), stress1(i), ustar1(i)) - rmol1(i) = undefined !not used in GFS sfcdif -> to satsify output - flhc1(i) = undefined - flqc1(i) = undefined - - rah_total = max(1.0,1.0/( ch(i)*wind(i)) ) - cah_total = density * con_cp /rah_total -! tskin(i) = sensible_heat_total/cah_total + temperature_forcing ! test to use combined ch and SH to backout Ts - - ch(i) = ch_vegetated * vegetation_frac + ch_bare_ground*(1.0-vegetation_frac) - - else ! MYNN - note the GFS option is the same as sfcdif3; so removed. - - qfx = evap(i) / con_hvap ! use flux from output - - call sfcdif4(i_location ,j_location ,uwind_forcing ,vwind_forcing , & - temperature_forcing, air_pressure_forcing ,air_pressure_surface , & - pblhx,gdx,z0_total,itime,snwdph(i),mnice,psi_opt,surface_temperature, & - spec_humidity_forcing,forcing_height,iz0tlnd,spec_humidity_surface,& - sensible_heat_total,qfx,cm(i),ch(i),ch2,cq2,rmol1(i),ustar1(i), & - rb1(i),fm1(i),fh1(i),stress1(i),fm101(i),fh21(i),wspd1,flhc1(i), & - flqc1(i) ) - - ch(i)=ch(i)/wspd1 - cm(i)=cm(i)/wspd1 - - ch(i) = ch_vegetated * vegetation_frac + ch_bare_ground*(1.0-vegetation_frac) - - rah_total = max(1.0,1.0/( ch(i)*wind(i)) ) - cah_total = density * con_cp /rah_total - -! tskin(i) = sensible_heat_total/cah_total + temperature_forcing ! - - endif - - - cmxy(i) = cm(i) chxy(i) = ch(i) @@ -1102,7 +998,7 @@ subroutine noahmpdrv_run & cmm (i) = cmxy(i) * wind(i) snwdph (i) = snow_depth * 1000.0 ! convert from m to mm; wait after the stability call - qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) +! qsurf (i) = q1(i) + evap(i)/(con_hvap*density*ch(i)*wind(i)) ! ! --- change units for output diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 9ad9092ec..1246fa1b0 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -65,20 +65,6 @@ type = real intent = out kind = kind_phys -[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 -[do_mynnedmf] - standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme - long_name = flag to activate MYNN-EDMF - units = flag - dimensions = () - type = logical - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -285,14 +271,6 @@ type = real kind = kind_phys intent = in -[pblh] - standard_name = atmosphere_boundary_layer_thickness - long_name = PBL thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [dry] standard_name = flag_nonzero_land_surface_fraction long_name = flag indicating presence of some land surface area fraction @@ -763,37 +741,6 @@ type = real kind = kind_phys intent = inout -[rmol1] - standard_name = reciprocal_of_obukhov_length - long_name = one over obukhov length - units = m-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[flhc1] - standard_name = surface_exchange_coefficient_for_heat - long_name = surface exchange coefficient for heat - units = W m-2 K-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[flqc1] - standard_name = surface_exchange_coefficient_for_moisture - long_name = surface exchange coefficient for moisture - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[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 [snowxy] standard_name = number_of_snow_layers long_name = number of snow layers From 8f3c084264d49da54b7f4a7e0e202d966232e22a Mon Sep 17 00:00:00 2001 From: helin wei Date: Sat, 26 Mar 2022 03:19:48 +0000 Subject: [PATCH 35/35] fix the missing value of fv in vege_flux --- physics/module_sf_noahmplsm.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 98364b19c..1c899e4bd 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -3901,6 +3901,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & mpe = 1e-6 liter = 0 + fv = ustarx ! --------------------------------------------------------------------------------------------- ! initialization variables that do not depend on stability iteration ! ---------------------------------------------------------------------------------------------