From fab541616e776489e306721445cd3f82abdceb82 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 8 Mar 2023 21:02:53 +0000 Subject: [PATCH 01/28] Merged latestest version of RUC LSM into community develop. --- physics/lsm_ruc.F90 | 557 ++++++------ physics/lsm_ruc.meta | 103 ++- physics/module_sf_ruclsm.F90 | 1356 ++++++++++++++++++++---------- physics/namelist_soilveg_ruc.F90 | 3 + physics/set_soilveg_ruc.F90 | 39 +- 5 files changed, 1355 insertions(+), 703 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 9a1f2ca21..9215a0ae1 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -300,15 +300,15 @@ end subroutine lsm_ruc_finalize ! sncovr1 - real, snow cover over land (fractional) im ! ! qsurf - real, specific humidity at sfc im ! ! gflux - real, soil heat flux (w/m**2) im ! -! drain - real, subsurface runoff (m/s) im ! +! drain - real, subsurface runoff (mm/s) im ! ! evap - real, latent heat flux in kg kg-1 m s-1 im ! -! runof - real, surface runoff (m/s) im ! -! evbs - real, direct soil evaporation (m/s) im ! -! evcw - real, canopy water evaporation (m/s) im ! -! sbsno - real, sublimation/deposit from snopack (m/s) im ! +! runof - real, surface runoff (mm/s) im ! +! evbs - real, direct soil evaporation (W m-2) im ! +! evcw - real, canopy water evaporation (W m-2) im ! +! sbsno - real, sublimation/deposit from snopack (W m-2) im ! ! stm - real, total soil column moisture content (m) im ! -! trans - real, total plant transpiration (m/s) im ! -! zorl - real, surface roughness im ! +! trans - real, total plant transpiration (W m-2) im ! +! zorl - real, surface roughness (cm) im ! ! wetness - real, normalized soil wetness im ! ! ! ! ==================== end of description ===================== ! @@ -323,18 +323,20 @@ end subroutine lsm_ruc_finalize subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & - & imp_physics_nssl, do_mynnsfclay, exticeden, & - & lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, zs, & - & t1, q1, qc, stype, vtype, sigmaf, laixy, & + & imp_physics_nssl, do_mynnsfclay, & + & exticeden, lsoil_ruc, lsoil, nlcat, nscat, & + & rdlai, xlat_d, xlon_d, & + & oro, sigma, zs, t1, q1, qc, stype, vtype, vegtype_frac, & + & soiltype_frac, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, use_lake, & - & rainnc, rainc, ice, snow, graupel, & - & prsl1, zf, wind, shdmin, shdmax, & + & rainnc, rainc, ice, snow, graupel, prsl1, zf, & + & wind, shdmin, shdmax, & & srflag, sfalb_lnd_bck, snoalb, & & isot, ivegsrc, fice, smcwlt2, smcref2, & & min_lakeice, min_seaice, oceanfrac, rhonewsn1, & ! --- constants & con_cp, con_rd, con_rv, con_g, con_pi, con_hvap, & - & con_fvirt, & + & con_hfus, con_fvirt, & ! --- in/outs for ice and land & semisbase, semis_lnd, semis_ice, sfalb_lnd, sfalb_ice, & & sncovr1_lnd, weasd_lnd, snwdph_lnd, tskin_lnd, & @@ -346,13 +348,13 @@ subroutine lsm_ruc_run & ! inputs & qsurf_lnd, gflux_lnd, evap_lnd, hflx_lnd, & & runof, runoff, srunoff, drain, & & cm_lnd, ch_lnd, evbs, evcw, stm, wetness, & - & snowfallac_lnd, & + & snowfallac_lnd, acsnow_lnd, snowmt_lnd, snohf, & & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & ! for ice & sfcqc_ice, sfcqv_ice, & & tsurf_ice, tsnow_ice, z0rl_ice, & & qsurf_ice, gflux_ice, evap_ice, ep1d_ice, hflx_ice, & - & cm_ice, ch_ice, snowfallac_ice, & + & cm_ice, ch_ice, snowfallac_ice, acsnow_ice, snowmt_ice, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & ! --- out & rhosnf, sbsno, & @@ -371,10 +373,12 @@ subroutine lsm_ruc_run & ! inputs ! --- input: integer, intent(in) :: me, master integer, intent(in) :: im, nlev, iter, lsoil_ruc, lsoil, kdt, isot, ivegsrc + integer, intent(in) :: nlcat, nscat integer, intent(in) :: lsm_ruc, lsm integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_nssl real (kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlon_d + real (kind=kind_phys), dimension(:), intent(in) :: oro, sigma real (kind=kind_phys), dimension(:), intent(in) :: & & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & @@ -390,7 +394,7 @@ subroutine lsm_ruc_run & ! inputs real (kind=kind_phys), intent(in) :: delt, min_seaice, min_lakeice real (kind=kind_phys), intent(in) :: con_cp, con_rv, con_g, & con_pi, con_rd, & - con_hvap, con_fvirt + con_hvap, con_hfus, con_fvirt logical, dimension(:), intent(in) :: flag_iter, flag_guess logical, dimension(:), intent(in) :: land, icy, use_lake @@ -404,6 +408,10 @@ subroutine lsm_ruc_run & ! inputs ! --- in/out: integer, dimension(:), intent(inout) :: stype integer, dimension(:), intent(in) :: vtype + + real (kind=kind_phys), dimension(:,:), intent(in) :: vegtype_frac + real (kind=kind_phys), dimension(:,:), intent(in) :: soiltype_frac + real (kind=kind_phys), dimension(:), intent(in) :: zs real (kind=kind_phys), dimension(:), intent(in) :: srflag real (kind=kind_phys), dimension(:), intent(inout) :: & @@ -433,10 +441,11 @@ subroutine lsm_ruc_run & ! inputs ! for land & sncovr1_lnd, qsurf_lnd, gflux_lnd, evap_lnd, & & cmm_lnd, chh_lnd, hflx_lnd, sbsno, & - & snowfallac_lnd, & + & snowfallac_lnd, acsnow_lnd, snowmt_lnd, snohf, & ! for ice & sncovr1_ice, qsurf_ice, gflux_ice, evap_ice, ep1d_ice, & - & cmm_ice, chh_ice, hflx_ice, snowfallac_ice + & cmm_ice, chh_ice, hflx_ice, & + & snowfallac_ice, acsnow_ice, snowmt_ice real (kind=kind_phys), dimension(:), intent( out) :: & & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & @@ -451,19 +460,19 @@ subroutine lsm_ruc_run & ! inputs real(kind=kind_phys), dimension(im,nlev) :: pattern_spp ! --- locals: - real (kind=kind_phys), dimension(im) :: rho, & - & q0, qs1, albbcksol, & + real (kind=kind_phys), dimension(im) :: rho, rhonewsn_ex, & + & q0, qs1, albbcksol, srunoff_old, runoff_old, & & tprcp_old, srflag_old, sr_old, canopy_old, wetness_old, & ! for land & weasd_lnd_old, snwdph_lnd_old, tskin_lnd_old, & - & tsnow_lnd_old, snowfallac_lnd_old, & + & tsnow_lnd_old, snowfallac_lnd_old, acsnow_lnd_old, & & sfcqv_lnd_old, sfcqc_lnd_old, z0rl_lnd_old, & - & sncovr1_lnd_old, & + & sncovr1_lnd_old,snowmt_lnd_old, & ! for ice & weasd_ice_old, snwdph_ice_old, tskin_ice_old, & - & tsnow_ice_old, snowfallac_ice_old, & + & tsnow_ice_old, snowfallac_ice_old, acsnow_ice_old, & & sfcqv_ice_old, sfcqc_ice_old, z0rl_ice_old, & - & sncovr1_ice_old + & sncovr1_ice_old,snowmt_ice_old !-- local spp pattern array real (kind=kind_phys), dimension(im,lsoil_ruc,1) :: pattern_spp_lsm @@ -479,8 +488,12 @@ subroutine lsm_ruc_run & ! inputs & tsice_old, tslb_old, sh2o_old, & & keepfr_old, smfrkeep_old + real (kind=kind_phys), dimension(im,nlcat,1) :: landusef + real (kind=kind_phys), dimension(im,nscat,1) :: soilctop + real (kind=kind_phys),dimension (im,1,1) :: & & conflx2, sfcprs, sfctmp, q2, qcatm, rho2 + real (kind=kind_phys),dimension (im,1) :: orog, stdev real (kind=kind_phys),dimension (im,1) :: & & albbck_lnd, alb_lnd, chs_lnd, flhc_lnd, flqc_lnd, & & wet, wet_ice, smmax, cmc, drip, ec, edir, ett, & @@ -494,9 +507,8 @@ subroutine lsm_ruc_run & ! inputs & snomlt_lnd, sncovr_lnd, soilw, soilm, ssoil_lnd, & & soilt_lnd, tbot, & & xlai, swdn, z0_lnd, znt_lnd, rhosnfr, infiltr, & - & precipfr, snfallac_lnd, acsn, & - & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq, & - & rhonewsn + & precipfr, snfallac_lnd, acsn_lnd, & + & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq ! ice real (kind=kind_phys),dimension (im,1) :: & & albbck_ice, alb_ice, chs_ice, flhc_ice, flqc_ice, & @@ -504,7 +516,7 @@ subroutine lsm_ruc_run & ! inputs & solnet_ice, sfcems_ice, hfx_ice, & & sneqv_ice, snoalb1d_ice, snowh_ice, snoh_ice, tsnav_ice, & & snomlt_ice, sncovr_ice, ssoil_ice, soilt_ice, & - & z0_ice, znt_ice, snfallac_ice, & + & z0_ice, znt_ice, snfallac_ice, acsn_ice, & & qsfc_ice, qsg_ice, qvg_ice, qcg_ice, soilt1_ice @@ -515,10 +527,6 @@ subroutine lsm_ruc_run & ! inputs !! "USGS" (USGS 24/27 category dataset) and !! "MODIFIED_IGBP_MODIS_NOAH" (MODIS 20-category dataset) - integer :: nscat, nlcat - real (kind=kind_phys), dimension(:,:,:), allocatable :: landusef !< fractional landuse - real (kind=kind_phys), dimension(:,:,:), allocatable :: soilctop !< fractional soil type - integer :: nsoil, iswater, isice integer, dimension (1:im,1:1) :: stype_wat, vtype_wat integer, dimension (1:im,1:1) :: stype_lnd, vtype_lnd @@ -543,8 +551,8 @@ subroutine lsm_ruc_run & ! inputs ipr = 10 !-- - testptlat = 74.12 !29.5 - testptlon = 164.0 !283.0 + testptlat = 68.6 !41.02 !42.05 !39.0 !74.12 !29.5 + testptlon = 298.6 !284.50 !286.75 !280.6 !164.0 !283.0 !-- debug_print=.false. @@ -573,20 +581,6 @@ subroutine lsm_ruc_run & ! inputs flag(i) = land(i) .or. flag_ice_uncoupled(i) enddo - if (isot == 1) then - nscat = 19 ! stasgo - else - nscat = 9 ! zobler - endif - allocate(soilctop(im,nscat,1)) - - if(ivegsrc == 1) then - nlcat = 20 ! IGBP - "MODI-RUC" - else - nlcat = 13 - endif - allocate(landusef(im,nlcat,1)) - if(debug_print) then write (0,*)'RUC LSM run' write (0,*)'stype=',ipr,stype(ipr) @@ -615,8 +609,6 @@ subroutine lsm_ruc_run & ! inputs ! for now set fractions of differnet landuse and soil types ! in the grid cell to zero - landusef (:,:,:) = 0.0 - soilctop (:,:,:) = 0.0 !-- spp spp_lsm = 0 ! so far (10May2021) @@ -634,7 +626,7 @@ subroutine lsm_ruc_run & ! inputs if(ivegsrc == 1) then llanduse = 'MODI-RUC' ! IGBP iswater = 17 - isice = 15 + isice = glacier else write(errmsg, '(a,i0)') 'Logic error in sfc_drv_ruc_run: iswater/isice not configured for ivegsrc=', ivegsrc errflg = 1 @@ -671,27 +663,32 @@ subroutine lsm_ruc_run & ! inputs wetness_old(i) = wetness(i) canopy_old(i) = canopy(i) !srflag_old(i) = srflag(i) - !acsnow_old(i) = acsnow(i) ! for land weasd_lnd_old(i) = weasd_lnd(i) snwdph_lnd_old(i) = snwdph_lnd(i) tskin_lnd_old(i) = tskin_lnd(i) tsnow_lnd_old(i) = tsnow_lnd(i) - snowfallac_lnd_old(i) = snowfallac_lnd(i) sfcqv_lnd_old(i) = sfcqv_lnd(i) sfcqc_lnd_old(i) = sfcqc_lnd(i) z0rl_lnd_old(i) = z0rl_lnd(i) sncovr1_lnd_old(i) = sncovr1_lnd(i) + snowmt_lnd_old(i) = snowmt_lnd(i) + acsnow_lnd_old(i) = acsnow_lnd(i) + snowfallac_lnd_old(i) = snowfallac_lnd(i) + srunoff_old(i) = srunoff(i) + runoff_old(i) = runoff(i) ! for ice weasd_ice_old(i) = weasd_ice(i) snwdph_ice_old(i) = snwdph_ice(i) tskin_ice_old(i) = tskin_ice(i) tsnow_ice_old(i) = tsnow_ice(i) - snowfallac_ice_old(i) = snowfallac_ice(i) sfcqv_ice_old(i) = sfcqv_ice(i) sfcqc_ice_old(i) = sfcqc_ice(i) z0rl_ice_old(i) = z0rl_ice(i) sncovr1_ice_old(i) = sncovr1_ice(i) + snowmt_ice_old(i) = snowmt_ice(i) + acsnow_ice_old(i) = acsnow_ice(i) + snowfallac_ice_old(i) = snowfallac_ice(i) do k = 1, lsoil_ruc smois_old(i,k) = smois(i,k) @@ -725,6 +722,8 @@ subroutine lsm_ruc_run & ! inputs sbsno(i) = 0.0 !local i,j arrays + snoh_lnd(i,j) = 0.0 + snoh_ice(i,j) = 0.0 dew_lnd(i,j) = 0.0 dew_ice(i,j) = 0.0 soilm(i,j) = 0.0 @@ -735,22 +734,26 @@ subroutine lsm_ruc_run & ! inputs qfx_ice(i,j) = 0.0 lh_lnd(i,j) = 0.0 lh_ice(i,j) = 0.0 - acsn(i,j) = 0.0 + esnow_lnd(i,j) = 0.0 + esnow_ice(i,j) = 0.0 sfcexc(i,j) = 0.0 acceta(i,j) = 0.0 ssoil_lnd(i,j) = 0.0 ssoil_ice(i,j) = 0.0 - snomlt_lnd(i,j) = 0.0 - snomlt_ice(i,j) = 0.0 infiltr(i,j) = 0.0 + precipfr(i,j) = 0.0 + rhosnfr(i,j) = -1.e3 runoff1(i,j) = 0.0 runoff2(i,j) = 0.0 - acrunoff(i,j) = 0.0 - snfallac_lnd(i,j) = 0.0 - snfallac_ice(i,j) = 0.0 - rhosnfr(i,j) = -1.e3 - precipfr(i,j) = 0.0 - + if(kdt == 1) then + acrunoff(i,j) = 0.0 + snfallac_lnd(i,j) = 0.0 + acsn_lnd(i,j) = 0.0 + snfallac_ice(i,j) = 0.0 + acsn_ice(i,j) = 0.0 + snomlt_lnd(i,j) = 0.0 + snomlt_ice(i,j) = 0.0 + endif endif enddo ! i=1,im enddo @@ -787,6 +790,19 @@ subroutine lsm_ruc_run & ! inputs frpcpn = .false. endif + do j = 1, 1 ! 1:1 + do i = 1, im ! i - horizontal loop + orog(i,j) = oro(i) !topography + stdev(i,j) = sigma(i) ! st. deviation (m) + do k=1,nlcat + landusef(i,k,j) = vegtype_frac(i,k) + enddo + do k=1,nscat + soilctop(i,k,j) = soiltype_frac(i,k) + enddo + enddo + enddo + do j = 1, 1 ! 1:1 do i = 1, im ! i - horizontal loop xice(i,j) = 0. @@ -810,9 +826,9 @@ subroutine lsm_ruc_run & ! inputs !> - 2. forcing data (f): !!\n \a sfcprs - pressure at height zf above ground (pascals) !!\n \a sfctmp - air temperature (\f$K\f$) at height zf above ground -!!\n \a q2 - pressure at height zf above ground (pascals) -!!\n \a qcatm - cloud water mising ration at height zf above ground (\f$kg !kg^{-1}\f$) -!!\n \a rho2 - air density at height zf above ground (pascals) +!!\n \a q2 - water vapor mix. ratio at height zf above ground (\f$kg kg^{-1}\f$) +!!\n \a qcatm - cloud water mixing ratio at height zf above ground (\f$kg kg^{-1}\f$) +!!\n \a rho2 - air density at height zf above ground ((\f$kg m^{-3}\f$)) sfcprs(i,1,j) = prsl1(i) sfctmp(i,1,j) = t1(i) @@ -827,7 +843,7 @@ subroutine lsm_ruc_run & ! inputs !!\n \a rainncv - time-step non-convective precip (\f$kg m^{-2} \f$) !!\n \a graupelncv - time-step graupel (\f$kg m^{-2} \f$) !!\n \a snowncv - time-step snow (\f$kg m^{-2} \f$) -!!\n \a precipfr - time-step precipitation in solod form (\f$kg m^{-2} \f$) +!!\n \a precipfr - time-step precipitation in solid form (\f$kg m^{-2} \f$) !!\n \a shdfac - areal fractional coverage of green vegetation (0.0-1.0) !!\n \a shdmin - minimum areal fractional coverage of green vegetation -> !shdmin1d !!\n \a shdmax - maximum areal fractional coverage of green vegetation -> !shdmax1d @@ -842,17 +858,17 @@ subroutine lsm_ruc_run & ! inputs !rainncv(i,j) = rhoh2o * max(rain(i)-rainc(i),0.0) ! total time-step explicit precip !graupelncv(i,j) = rhoh2o * graupel(i) !snowncv(i,j) = rhoh2o * snow(i) - prcp(i,j) = rhoh2o * (rainc(i)+rainnc(i)) ! tprcp in [m] - convective plus explicit - raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip - rainncv(i,j) = rhoh2o * rainnc(i) ! total time-step explicit precip + prcp(i,j) = rhoh2o * (rainc(i)+rainnc(i)) ! total time-step convective plus explicit [mm] + raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip [mm] + rainncv(i,j) = rhoh2o * rainnc(i) ! total time-step explicit precip [mm] graupelncv(i,j) = rhoh2o * graupel(i) snowncv(i,j) = rhoh2o * snow(i) - rhonewsn(i,j) = rhonewsn1(i) + rhonewsn_ex(i) = rhonewsn1(i) if (debug_print) then !-- diagnostics for a test point with known lat/lon - if (abs(xlat_d(i)-testptlat).lt.2.5 .and. & - abs(xlon_d(i)-testptlon).lt.6.5)then - if(weasd_lnd(i) > 0.) & + if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & + abs(xlon_d(i)-testptlon).lt.0.2)then + !if(weasd_lnd(i) > 0.) & print 100,'(ruc_lsm_drv) i=',i, & ' lat,lon=',xlat_d(i),xlon_d(i), & 'rainc',rainc(i),'rainnc',rainnc(i), & @@ -861,11 +877,12 @@ subroutine lsm_ruc_run & ! inputs 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& 'prsl1',prsl1(i),'t1',t1(i), & !'snow',snow(i), 'snowncv',snowncv(i,j), & - 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & + 'srflag',srflag(i),'weasd mm ',weasd_lnd(i), & + 'tsnow_lnd',tsnow_lnd(i),'snwdph mm',snwdph_lnd(i), & 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) endif endif - 100 format (";;; ",a,i4,a,2f9.2/(4(a10,'='es9.2))) + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es9.2))) !-- ! ice precipitation is not used @@ -873,8 +890,6 @@ subroutine lsm_ruc_run & ! inputs ! ice not used ! precipfr(i,j) = rainncv(i,j) * ffrozp(i,j) - !acsn(i,j) = acsnow(i) - acsn(i,j) = 0.0 tbot(i,j) = tg3(i) @@ -969,7 +984,7 @@ subroutine lsm_ruc_run & ! inputs endif ! coszen > 0. snoalb1d_lnd(i,j) = snoalb(i) - albbck_lnd(i,j) = albbcksol(i) !sfalb_lnd_bck(i) + albbck_lnd(i,j) = min(0.9,albbcksol(i)) !sfalb_lnd_bck(i) !-- spp_lsm @@ -995,14 +1010,14 @@ subroutine lsm_ruc_run & ! inputs solnet_lnd(i,j) = dswsfc(i)*(1.-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 cmc(i,j) = canopy(i) ! [mm] - soilt_lnd(i,j) = tsurf_lnd(i) ! clu_q2m_iter + soilt_lnd(i,j) = tsurf_lnd(i) ! sanity check for snow temperature tsnow - if (tsnow_lnd(i) > 0. .and. tsnow_lnd(i) < 273.15) then + if (tsnow_lnd(i) > 200. .and. tsnow_lnd(i) < 273.15) then soilt1_lnd(i,j) = tsnow_lnd(i) else soilt1_lnd(i,j) = tsurf_lnd(i) endif - tsnav_lnd(i,j) = 0.5*(soilt_lnd(i,j) + soilt1_lnd(i,j)) - 273.15 + tsnav_lnd(i,j) = min(0.,0.5*(soilt_lnd(i,j) + soilt1_lnd(i,j)) - 273.15) do k = 1, lsoil_ruc smsoil (i,k,j) = smois(i,k) slsoil (i,k,j) = sh2o(i,k) @@ -1018,27 +1033,79 @@ subroutine lsm_ruc_run & ! inputs endif chs_lnd (i,j) = ch_lnd(i) * wind(i) ! compute conductance - flhc_lnd(i,j) = chs_lnd(i,j) * rho(i) * con_cp ! * (1. + 0.84*q2(i,1,j)) + flhc_lnd(i,j) = chs_lnd(i,j) * rho(i) * con_cp * (1.+0.84*q2(i,1,j)) flqc_lnd(i,j) = chs_lnd(i,j) * rho(i) * wet(i,j) + ! for output cmm_lnd(i) = cm_lnd(i) * wind(i) chh_lnd(i) = chs_lnd(i,j) * rho(i) ! - snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m - sneqv_lnd(i,j) = weasd_lnd(i) ! [mm] - snfallac_lnd(i,j) = snowfallac_lnd(i) - !> -- sanity checks on sneqv and snowh - if (sneqv_lnd(i,j) /= 0.0 .and. snowh_lnd(i,j) == 0.0) then - snowh_lnd(i,j) = 0.003 * sneqv_lnd(i,j) ! snow density ~300 kg m-3 + sneqv_lnd(i,j) = weasd_lnd(i) + snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m + + if(kdt > 1) then + !-- run-total accumulation + snfallac_lnd(i,j) = snowfallac_lnd(i) + acsn_lnd(i,j) = acsnow_lnd(i) + snomlt_lnd(i,j) = snowmt_lnd(i) endif - if (snowh_lnd(i,j) /= 0.0 .and. sneqv_lnd(i,j) == 0.0) then - sneqv_lnd(i,j) = 300. * snowh_lnd(i,j) ! snow density ~300 kg m-3 - endif - - if (sneqv_lnd(i,j) > 0. .and. snowh_lnd(i,j) > 0.) then - if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 950.) then - sneqv_lnd(i,j) = 300. * snowh_lnd(i,j) + !> -- sanity checks on sneqv and snowh + if (sneqv_lnd(i,j) /= 0.0d0 .and. snowh_lnd(i,j) == 0.0d0) then + if (debug_print) print *,'bad sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) + if(sneqv_lnd(i,j) < 1.e-7.or.soilt_lnd(i,j)>273.15d0) then + sneqv_lnd(i,j) = 0.d0 + snowh_lnd(i,j) = 0.d0 + else + sneqv_lnd(i,j) = 300.d0 * snowh_lnd(i,j) ! snow density ~300 kg m-3 + endif + if (debug_print) print *,'fixed sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) + elseif (snowh_lnd(i,j) /= 0.0d0 .and. sneqv_lnd(i,j) == 0.0d0) then + if (debug_print) print *,'bad snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) + if(snowh_lnd(i,j) < 3.d-10.or.soilt_lnd(i,j)>273.15d0) then + snowh_lnd(i,j) = 0.d0 + sneqv_lnd(i,j) = 0.d0 + else + snowh_lnd(i,j) = 0.003d0 * sneqv_lnd(i,j) ! snow density ~300 kg m-3 + endif + if (debug_print) print *,'fixed snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) + elseif (sneqv_lnd(i,j) > 0.d0 .and. snowh_lnd(i,j) > 0.d0) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.2.5 .and. & + abs(xlon_d(i)-testptlon).lt.2.5)then + print *,'sneqv_lnd(i,j)/snowh_lnd(i,j)',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + endif + if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 500.d0) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + print *,'large snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) + endif + if(soilt_lnd(i,j)>273.15d0) then + snowh_lnd(i,j) = 0.d0 + sneqv_lnd(i,j) = 0.d0 + else + snowh_lnd(i,j) = 0.002d0 * sneqv_lnd(i,j) + endif + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'fixed large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + endif + elseif(sneqv_lnd(i,j)/snowh_lnd(i,j) < 58.d0) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'small snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + print *,'small snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) + endif + if(soilt_lnd(i,j)>273.15d0) then + snowh_lnd(i,j) = 0.d0 + sneqv_lnd(i,j) = 0.d0 + else + sneqv_lnd(i,j) = 58.d0 * snowh_lnd(i,j) + endif + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'fixed small snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + endif endif endif @@ -1060,64 +1127,35 @@ subroutine lsm_ruc_run & ! inputs sneqv_lnd(i,j)=0 endif - if(debug_print) then - if(me==0 ) then - write (0,*)'before LSMRUC for land' - write (0,*)'sfcems(i,j) =',i,j,sfcems_lnd(i,j) - write (0,*)'chklowq(i,j) =',i,j,chklowq(i,j) - write (0,*)'chs(i,j) =',i,j,chs_lnd(i,j) - write (0,*)'flqc(i,j) =',i,j,flqc_lnd(i,j) - write (0,*)'flhc(i,j) =',i,j,flhc_lnd(i,j) - write (0,*)'wet(i,j) =',i,j,wet(i,j) - write (0,*)'cmc(i,j) =',i,j,cmc(i,j) - write (0,*)'shdfac(i,j) =',i,j,shdfac(i,j) - write (0,*)'alb(i,j) =',i,j,alb_lnd(i,j) - write (0,*)'znt(i,j) =',i,j,znt_lnd(i,j) - write (0,*)'z0(i,j) =',i,j,z0_lnd(i,j) - write (0,*)'snoalb1d(i,j) =',i,j,snoalb1d_lnd(i,j) - write (0,*)'landusef(i,:,j) =',i,j,landusef(i,:,j) - write (0,*)'soilctop(i,:,j) =',i,j,soilctop(i,:,j) - write (0,*)'nlcat=',nlcat - write (0,*)'nscat=',nscat - write (0,*)'qsfc(i,j) =',i,j,qsfc_lnd(i,j) - write (0,*)'qvg(i,j) =',i,j,qvg_lnd(i,j) - write (0,*)'qsg(i,j) =',i,j,qsg_lnd(i,j) - write (0,*)'qcg(i,j) =',i,j,qcg_lnd(i,j) - write (0,*)'dew(i,j) =',i,j,dew_lnd(i,j) - write (0,*)'soilt(i,j) =',i,j,soilt_lnd(i,j) - write (0,*)'tskin(i) =',i,j,tskin_lnd(i) - write (0,*)'soilt1(i,j) =',i,j,soilt1_lnd(i,j) - write (0,*)'tsnav(i,j) =',i,j,tsnav_lnd(i,j) - write (0,*)'tbot(i,j) =',i,j,tbot(i,j) - write (0,*)'vtype(i,j) =',i,j,vtype_lnd(i,j) - write (0,*)'stype(i,j) =',i,j,stype_lnd(i,j) - write (0,*)'xland(i,j) =',i,j,xland(i,j) - write (0,*)'xice(i,j) =',i,j,xice(i,j) - write (0,*)'iswater=',iswater - write (0,*)'isice=',isice - write (0,*)'xice_threshold=',xice_threshold - write (0,*)'con_cp=',con_cp - write (0,*)'con_rv=',con_rv - write (0,*)'con_rd=',con_rd - write (0,*)'con_g=',con_g - write (0,*)'con_pi=',con_pi - write (0,*)'con_hvap=',con_hvap - write (0,*)'stbolt=',stbolt - write (0,*)'smsoil(i,:,j)=',i,j,smsoil(i,:,j) - write (0,*)'slsoil(i,:,j)=',i,j,slsoil(i,:,j) - write (0,*)'stsoil(i,:,j)=',i,j,stsoil(i,:,j) - write (0,*)'smfrsoil(i,:,j)=',i,j,smfrsoil(i,:,j) - write (0,*)'keepfrsoil(i,:,j)=',i,j,keepfrsoil(i,:,j) - write (0,*)'acrunoff(i,j) =',i,j,acrunoff(i,j) - write (0,*)'acsn(i,j) =',i,j,acsn(i,j) - write (0,*)'shdmin1d(i,j) =',i,j,shdmin1d(i,j) - write (0,*)'shdmax1d(i,j) =',i,j,shdmax1d(i,j) - write (0,*)'rdlai2d =',rdlai2d - endif + !if (debug_print) then + !-- diagnostics for a land test point with known lat/lon + if (kdt < 10) then + if (abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + !if(weasd_lnd(i) > 0.) & + print 100,'(ruc_lsm_drv before RUC land call) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'rainc',rainc(i),'rainnc',rainnc(i),'prcp',prcp(i,j), & + 'graupel',graupel(i),'qc',qc(i),'sfcqv_lnd',sfcqv_lnd(i),& + !'snow',snow(i), 'snowncv',snowncv(i,j), & + 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & + 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& + 'albbcksol',albbcksol(i),'alb_lnd',alb_lnd(i,j), & + 'solnet_lnd',solnet_lnd(i,j),'t1',t1(i), & + 'sfcems_lnd',sfcems_lnd(i,j),'flhc_lnd',flhc_lnd(i,j), & + 'flqc_lnd',flqc_lnd(i,j),'wet',wet(i,j),'cmc',cmc(i,j),& + 'qcg_lnd',qcg_lnd(i,j),'dew',dew_lnd(i,j), & + 'znt_lnd',znt_lnd(i,j),'shdfac',shdfac(i,j), & + 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & + 'smsoil1',smsoil(i,1,j),'slsoil',slsoil(i,1,j), & + 'keepfrsoil',keepfrsoil(i,1,j), & + 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) endif + endif ! debug_print + !-- !> - Call RUC LSM lsmruc() for land. - call lsmruc( & + call lsmruc(xlat_d(i),xlon_d(i), & & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & & zs, prcp(i,j), sneqv_lnd(i,j), snowh_lnd(i,j), & @@ -1125,16 +1163,15 @@ subroutine lsm_ruc_run & ! inputs & ffrozp(i,j), frpcpn, & & rhosnfr(i,j), precipfr(i,j), exticeden, & ! --- inputs: + & orog(i,j), stdev(i,j), & & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_lnd(i,j), sfcems_lnd(i,j), chklowq(i,j), & - & chs_lnd(i,j), flqc_lnd(i,j), flhc_lnd(i,j), rhonewsn(i,j), & + & chs_lnd(i,j), flqc_lnd(i,j), flhc_lnd(i,j), rhonewsn_ex(i), & ! --- input/outputs: & wet(i,j), cmc(i,j), shdfac(i,j), alb_lnd(i,j), znt_lnd(i,j), & & z0_lnd(i,j), snoalb1d_lnd(i,j), albbck_lnd(i,j), & & xlai(i,j), landusef(i,:,j), nlcat, & -! --- mosaic_lu and mosaic_soil are moved to the namelist -! & mosaic_lu, mosaic_soil, & & soilctop(i,:,j), nscat, & & qsfc_lnd(i,j), qsg_lnd(i,j), qvg_lnd(i,j), qcg_lnd(i,j), & & dew_lnd(i,j), soilt1_lnd(i,j), & @@ -1145,51 +1182,54 @@ subroutine lsm_ruc_run & ! inputs ! --- input/outputs: & smsoil(i,:,j), slsoil(i,:,j), soilm(i,j), smmax(i,j), & & stsoil(i,:,j), soilt_lnd(i,j), & + & edir(i,j), ec(i,j), ett(i,j), esnow_lnd(i,j), snoh_lnd(i,j), & & hfx_lnd(i,j), qfx_lnd(i,j), lh_lnd(i,j), & & infiltr(i,j), runoff1(i,j), runoff2(i,j), acrunoff(i,j), & & sfcexc(i,j), acceta(i,j), ssoil_lnd(i,j), & - & snfallac_lnd(i,j), acsn(i,j), snomlt_lnd(i,j), & + & snfallac_lnd(i,j), acsn_lnd(i,j), snomlt_lnd(i,j), & & smfrsoil(i,:,j),keepfrsoil(i,:,j), .false., & & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte, & - & errmsg, errflg) - if(debug_print) then - write (0,*)'after LSMRUC for land' - write (0,*)'after sneqv(i,j) =',i,j,sneqv_lnd(i,j) - write (0,*)'after snowh(i,j) =',i,j,snowh_lnd(i,j) - write (0,*)'after sncovr(i,j) =',i,j,sncovr_lnd(i,j) - write (0,*)'after vtype(i,j) =',i,j,vtype_lnd(i,j) - write (0,*)'after stype(i,j) =',i,j,stype_lnd(i,j) - write (0,*)'after wet(i,j) =',i,j,wet(i,j) - write (0,*)'after cmc(i,j) =',i,j,cmc(i,j) - write (0,*)'after qsfc(i,j) =',i,j,qsfc_lnd(i,j) - write (0,*)'after qvg(i,j) =',i,j,qvg_lnd(i,j) - write (0,*)'after qsg(i,j) =',i,j,qsg_lnd(i,j) - write (0,*)'after qcg(i,j) =',i,j,qcg_lnd(i,j) - write (0,*)'after dew(i,j) =',i,j,dew_lnd(i,j) - write (0,*)'after soilt(i,j) =',i,j,soilt_lnd(i,j) - write (0,*)'after tskin(i) =',i,j,tskin_lnd(i) - write (0,*)'after soilt1(i,j) =',i,j,soilt1_lnd(i,j) - write (0,*)'after tsnav(i,j) =',i,j,tsnav_lnd(i,j) - write (0,*)'after smsoil(i,:,j)=',i,j,smsoil(i,:,j) - write (0,*)'after slsoil(i,:,j)=',i,j,slsoil(i,:,j) - write (0,*)'after stsoil(i,:,j)=',i,j,stsoil(i,:,j) - write (0,*)'after smfrsoil(i,:,j)=',i,j,smfrsoil(i,:,j) - write (0,*)'after keepfrsoil(i,:,j)=',i,j,keepfrsoil(i,:,j) - write (0,*)'after soilm(i,j) =',i,j,soilm(i,j) - write (0,*)'after smmax(i,j) =',i,j,smmax(i,j) - write (0,*)'after hfx(i,j) =',i,j,hfx_lnd(i,j) - write (0,*)'after qfx(i,j) =',i,j,qfx_lnd(i,j) - write (0,*)'after lh(i,j) =',i,j,lh_lnd(i,j) - write (0,*)'after infiltr(i,j) =',i,j,infiltr(i,j) - write (0,*)'after runoff1(i,j) =',i,j,runoff1(i,j) - write (0,*)'after runoff2(i,j) =',i,j,runoff2(i,j) - write (0,*)'after ssoil(i,j) =',i,j,ssoil_lnd(i,j) - write (0,*)'after snfallac(i,j) =',i,j,snfallac_lnd(i,j) - write (0,*)'after acsn(i,j) =',i,j,acsn(i,j) - write (0,*)'after snomlt(i,j) =',i,j,snomlt_lnd(i,j) - endif + & its,ite, jts,jte, kts,kte, errmsg, errflg ) + if(debug_print) then + if (abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print 100,'(ruc_lsm_drv after RUC land call) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'sneqv(i,j) =',sneqv_lnd(i,j), & + 'snowh(i,j) =',snowh_lnd(i,j), & + 'sncovr(i,j) =',sncovr_lnd(i,j), & + 'vtype(i,j) =',vtype_lnd(i,j), & + 'stype(i,j) =',stype_lnd(i,j), & + 'wet(i,j) =',wet(i,j), & + 'cmc(i,j) =',cmc(i,j), & + 'qsfc(i,j) =',qsfc_lnd(i,j), & + 'qvg(i,j) =',qvg_lnd(i,j), & + 'qsg(i,j) =',qsg_lnd(i,j), & + 'qcg(i,j) =',qcg_lnd(i,j), & + 'dew(i,j) =',dew_lnd(i,j), & + 'soilt(i,j) =',soilt_lnd(i,j), & + 'tskin(i) =',tskin_lnd(i), & + 'soilt1(i,j) =',soilt1_lnd(i,j), & + 'tsnav(i,j) =',tsnav_lnd(i,j), & + 'smsoil(i,:,j)=',smsoil(i,:,j), & + 'slsoil(i,:,j)=',slsoil(i,:,j), & + 'stsoil(i,:,j)=',stsoil(i,:,j), & + 'smfrsoil(i,:,j)=',smfrsoil(i,:,j), & + 'keepfrsoil(i,:,j)=',keepfrsoil(i,:,j), & + 'soilm(i,j) =',soilm(i,j), & + 'smmax(i,j) =',smmax(i,j), & + 'hfx(i,j) =',hfx_lnd(i,j), & + 'lh(i,j) =',lh_lnd(i,j), & + 'infiltr(i,j) =',infiltr(i,j), & + 'runoff1(i,j) =',runoff1(i,j), & + 'runoff2(i,j) =',runoff2(i,j), & + 'ssoil(i,j) =',ssoil_lnd(i,j), & + 'snfallac(i,j) =',snfallac_lnd(i,j), & + 'acsn_lnd(i,j) =',acsn_lnd(i,j), & + 'snomlt(i,j) =',snomlt_lnd(i,j) + endif + endif !> - RUC LSM: prepare variables for return to parent model and unit conversion. @@ -1199,23 +1239,22 @@ subroutine lsm_ruc_run & ! inputs !!\n \a ssoil - soil heat flux (\f$W m^{-2}\f$: negative if downward from surface) !!\n \a runoff1 - surface runoff (\f$m s^{-1}\f$), not infiltrating the surface !!\n \a runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom -!!\n \a snoh - phase-change heat flux from snowmelt (w m-2) -!!\n \a lh - actual latent heat flux (\f$W m^{-2}\f$: positive, if upward from sfc) -!!\n \a hfx - sensible heat flux (\f$W m^{-2}\f$: positive, if upward from sfc) -!!\n \a ssoil - soil heat flux (\f$W m^{-2}\f$: negative if downward from surface) -!!\n \a runoff1 - surface runoff (\f$m s^{-1}\f$), not infiltrating the surface -!!\n \a runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom -!!\n \a snoh - phase-change heat flux from snowmelt (w m-2) +!!\n \a snoh - phase-change heat flux from snowmelt (\f$W m^{-2}\f$) ! -! --- ... do not return the following output fields to parent model -! ec - canopy water evaporation (m s-1) -! edir - direct soil evaporation (m s-1) +! --- ... units [m/s] = [g m-2 s-1] +! evcw (W m-2) - canopy water evaporation flux +! evbs (W m-2) - direct soil evaporation flux +! trans (W m-2) - total plant transpiration +! edir, ec, ett - direct evaporation, evaporation of +! canopy water and transpiration (kg m-2 s-1) ! et(nsoil)-plant transpiration from a particular root layer (m s-1) -! ett - total plant transpiration (m s-1) -! esnow - sublimation from (or deposition to if <0) snowpack (m s-1) +! esnow - sublimation from (or deposition to if <0) snowpack (kg m-2 s-1) +! sbsno - sublimation from (or deposition to if <0) snowpack (W m-2) +! hfx - upward heat flux at the surface (W/m^2) +! qfx - upward moisture flux at the surface (kg kg-1 kg m-2 s-1) ! drip - through-fall of precip and/or dew in excess of canopy ! water-holding capacity (m) -! snomlt - snow melt (m) (water equivalent) +! snomlt - snow melt (kg m-2) (water equivalent) ! xlai - leaf area index (dimensionless) ! soilw - available soil moisture in root zone (unitless fraction ! between smcwlt and smcmax) @@ -1223,40 +1262,39 @@ subroutine lsm_ruc_run & ! inputs ! nroot - number of root layers, a function of veg type, determined ! in subroutine redprm. - - !evbs(i) = edir(i,j) - !evcw(i) = ec(i,j) - !trans(i) = ett(i,j) - !sbsno(i) = esnow(i,j) - !snohf(i) = snoh(i,j) + evbs(i) = edir(i,j) * rhoh2o * con_hvap + evcw(i) = ec(i,j) * rhoh2o * con_hvap + trans(i) = ett(i,j) * rhoh2o * con_hvap + sbsno(i) = esnow_lnd(i,j) * con_hfus + snohf(i) = snoh_lnd(i,j) ! Interstitial - evap_lnd(i) = qfx_lnd(i,j) / rho(i) ! kinematic - hflx_lnd(i) = hfx_lnd(i,j) / (con_cp*rho(i)) ! kinematic + evap_lnd(i) = qfx_lnd(i,j) / rho(i) ! kg kg-1 m s-1 kinematic + hflx_lnd(i) = hfx_lnd(i,j) / (con_cp*rho(i)) ! K m s-1 kinematic gflux_lnd(i) = ssoil_lnd(i,j) qsurf_lnd(i) = qsfc_lnd(i,j) tsurf_lnd(i) = soilt_lnd(i,j) tsnow_lnd(i) = soilt1_lnd(i,j) stm(i) = soilm(i,j) * 1.e-3 ! convert to [m] - runof (i) = runoff1(i,j) - drain (i) = runoff2(i,j) + runof (i) = runoff1(i,j) * rhoh2o ! surface kg m-2 s-1 + drain (i) = runoff2(i,j) * rhoh2o ! kg m-2 s-1 wetness(i) = wet(i,j) - - ! tsnow(i) = soilt1(i,j) sfcqv_lnd(i) = qvg_lnd(i,j) sfcqc_lnd(i) = qcg_lnd(i,j) - ! --- ... units [m/s] = [g m-2 s-1] - rhosnf(i) = rhosnfr(i,j) - !acsnow(i) = acsn(i,j) ! kg m-2 + + rhosnf(i) = rhosnfr(i,j) ! kg m-3 + acsnow_lnd(i) = acsn_lnd(i,j) ! accum kg m-2 + snowmt_lnd(i) = snomlt_lnd(i,j) ! accum kg m-2 ! --- ... accumulated total runoff and surface runoff - runoff(i) = runoff(i) + (drain(i)+runof(i)) * delt * 0.001 ! kg m-2 - srunoff(i) = srunoff(i) + runof(i) * delt * 0.001 ! kg m-2 + runoff(i) = runoff(i) + (drain(i)+runof(i)) * delt ! accum total kg m-2 + !srunoff(i) = srunoff(i) + runof(i) * delt ! accum surface kg m-2 + srunoff(i) = acrunoff(i,j) ! accum surface kg m-2 ! --- ... accumulated frozen precipitation (accumulation in lsmruc) - snowfallac_lnd(i) = snfallac_lnd(i,j) ! kg m-2 + snowfallac_lnd(i) = snfallac_lnd(i,j) ! accum kg m-2 ! --- ... unit conversion (from m to mm) snwdph_lnd(i) = snowh_lnd(i,j) * 1000.0 @@ -1275,7 +1313,7 @@ subroutine lsm_ruc_run & ! inputs !-- fill in albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_lnd(i) = sfalb_lnd(i) albdnir_lnd(i) = sfalb_lnd(i) - albinir_lnd(i) = sfalb_lnd(i) + albivis_lnd(i) = sfalb_lnd(i) albinir_lnd(i) = sfalb_lnd(i) do k = 1, lsoil_ruc @@ -1296,23 +1334,26 @@ subroutine lsm_ruc_run & ! inputs !-- ice point if (debug_print) then - if (abs(xlat_d(i)-testptlat).lt.2.5 .and. & - abs(xlon_d(i)-testptlon).lt.6.5)then - if(weasd_lnd(i) > 0.) & - print 101,'(ruc_lsm_drv ice) i=',i, & - ' lat,lon=',xlat_d(i),xlon_d(i),'flag_ice',flag_ice(i),& + if (abs(xlat_d(i)-testptlat).lt.0.1 .and. & + abs(xlon_d(i)-testptlon).lt.0.1)then + !if(weasd_ice(i) > 0.) & + print 101,'(ruc_lsm_drv_ice) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & !'rainc',rainc(i),'rainnc',rainnc(i), & 'sfcqv_ice',sfcqv_ice(i),& !'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & 'sncovr1_ice',sncovr1_ice(i),'sfalb_ice',sfalb_ice(i),& 'sfcqc_ice',sfcqc_ice(i),'tsnow_ice',tsnow_ice(i), & - 'prsl1',prsl1(i),'t1',t1(i), & - !'snow',snow(i), 'snowncv',snowncv(i,j), & + 'prsl1',prsl1(i),'t1',t1(i),'snwdph_ice ',snwdph_ice(i), & 'srflag',srflag(i),'weasd_ice',weasd_ice(i), & 'tsurf_ice',tsurf_ice(i),'tslb(i,1)',tslb(i,1) endif endif - 101 format (";;; ",a,i4,a,2f9.2/(4(a10,'='es9.2))) + 101 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es9.2))) + + edir (i,j) = 0.0 + ec (i,j) = 0.0 + ett (i,j) = 0.0 sncovr_ice(i,j) = sncovr1_ice(i) !-- alb_ice* is computed in setalb called from rrtmg_sw_pre. @@ -1331,13 +1372,13 @@ subroutine lsm_ruc_run & ! inputs sfcems_ice(i,j) = semis_ice(i) endif cmc(i,j) = canopy(i) ! [mm] - soilt_ice(i,j) = tsurf_ice(i) ! clu_q2m_iter - if (tsnow_ice(i) > 0. .and. tsnow_ice(i) < 273.15) then + soilt_ice(i,j) = tsurf_ice(i) + if (tsnow_ice(i) > 150. .and. tsnow_ice(i) < 273.15) then soilt1_ice(i,j) = tsnow_ice(i) else soilt1_ice(i,j) = tsurf_ice(i) endif - tsnav_ice(i,j) = 0.5*(soilt_ice(i,j) + soilt1_ice(i,j)) - 273.15 + tsnav_ice(i,j) = min(0.,0.5*(soilt_ice(i,j) + soilt1_ice(i,j)) - 273.15) do k = 1, lsoil_ruc stsice (i,k,j) = tsice(i,k) smice (i,k,j) = 1. @@ -1349,8 +1390,9 @@ subroutine lsm_ruc_run & ! inputs wet_ice(i,j) = 1. chs_ice (i,j) = ch_ice(i) * wind(i) ! compute conductance - flhc_ice(i,j) = chs_ice(i,j) * rho(i) * con_cp ! * (1. + 0.84*q2(i,1,j)) + flhc_ice(i,j) = chs_ice(i,j) * rho(i) * con_cp * (1. + 0.84*q2(i,1,j)) flqc_ice(i,j) = chs_ice(i,j) * rho(i) * wet_ice(i,j) + ! for output cmm_ice(i) = cm_ice (i) * wind(i) chh_ice(i) = chs_ice(i,j) * rho(i) @@ -1358,7 +1400,11 @@ subroutine lsm_ruc_run & ! inputs snowh_ice(i,j) = snwdph_ice(i) * 0.001 ! convert from mm to m sneqv_ice(i,j) = weasd_ice(i) ! [mm] - snfallac_ice(i,j) = snowfallac_ice(i) + if(kdt > 1) then + snfallac_ice(i,j) = snowfallac_ice(i) + acsn_ice(i,j) = acsnow_ice(i) + snomlt_ice(i,j) = snowmt_ice(i) + endif !> -- sanity checks on sneqv and snowh if (sneqv_ice(i,j) /= 0.0 .and. snowh_ice(i,j) == 0.0) then @@ -1378,6 +1424,9 @@ subroutine lsm_ruc_run & ! inputs z0_ice(i,j) = z0rl_ice(i)/100. znt_ice(i,j) = z0rl_ice(i)/100. + runoff1(i,j) = 0. + runoff2(i,j) = 0. + ! Workaround needed for subnormal numbers. This should be ! done after all other sanity checks, in case a sanity check ! results in subnormal numbers. @@ -1392,7 +1441,7 @@ subroutine lsm_ruc_run & ! inputs endif !> - Call RUC LSM lsmruc() for ice. - call lsmruc( & + call lsmruc(xlat_d(i),xlon_d(i), & & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & & zs, prcp(i,j), sneqv_ice(i,j), snowh_ice(i,j), & @@ -1400,16 +1449,15 @@ subroutine lsm_ruc_run & ! inputs & ffrozp(i,j), frpcpn, & & rhosnfr(i,j), precipfr(i,j), exticeden, & ! --- inputs: + & orog(i,j), stdev(i,j), & & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_ice(i,j), sfcems_ice(i,j), chklowq(i,j), & - & chs_ice(i,j), flqc_ice(i,j), flhc_ice(i,j), rhonewsn(i,j), & + & chs_ice(i,j), flqc_ice(i,j), flhc_ice(i,j), rhonewsn_ex(i), & ! --- input/outputs: & wet_ice(i,j), cmc(i,j), shdfac(i,j), alb_ice(i,j), & & znt_ice(i,j), z0_ice(i,j), snoalb1d_ice(i,j), & & albbck_ice(i,j), xlai(i,j),landusef(i,:,j), nlcat, & -! --- mosaic_lu and mosaic_soil are moved to the namelist -! & mosaic_lu, mosaic_soil, & & soilctop(i,:,j), nscat, & & qsfc_ice(i,j), qsg_ice(i,j), qvg_ice(i,j), qcg_ice(i,j), & & dew_ice(i,j), soilt1_ice(i,j), & @@ -1420,10 +1468,11 @@ subroutine lsm_ruc_run & ! inputs ! --- input/outputs: & smice(i,:,j), slice(i,:,j), soilm(i,j), smmax(i,j), & & stsice(i,:,j), soilt_ice(i,j), & + & edir(i,j), ec(i,j), ett(i,j), esnow_ice(i,j), snoh_ice(i,j), & & hfx_ice(i,j), qfx_ice(i,j), lh_ice(i,j), & & infiltr(i,j), runoff1(i,j), runoff2(i,j), acrunoff(i,j), & & sfcexc(i,j), acceta(i,j), ssoil_ice(i,j), & - & snfallac_ice(i,j), acsn(i,j), snomlt_ice(i,j), & + & snfallac_ice(i,j), acsn_ice(i,j), snomlt_ice(i,j), & & smfrice(i,:,j),keepfrice(i,:,j), .false., & & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & & ims,ime, jms,jme, kms,kme, & @@ -1443,19 +1492,23 @@ subroutine lsm_ruc_run & ! inputs sfcqv_ice(i) = qvg_ice(i,j) sfcqc_ice(i) = qcg_ice(i,j) + rhosnf(i) = rhosnfr(i,j) ! kg m-3 snowfallac_ice(i) = snfallac_ice(i,j) ! kg m-2 + acsnow_ice(i) = acsn_ice(i,j) ! kg m-2 + snowmt_ice(i) = snomlt_ice(i,j) ! kg m-2 ! --- ... unit conversion (from m to mm) - snwdph_ice(i) = snowh_ice(i,j) * 1000.0 - weasd_ice(i) = sneqv_ice(i,j) ! mm + snwdph_ice(i) = snowh_ice(i,j) * rhoh2o + weasd_ice(i) = sneqv_ice(i,j) ! kg m-2 sncovr1_ice(i) = sncovr_ice(i,j) - z0rl_ice(i) = znt_ice(i,j)*100. + z0rl_ice(i) = znt_ice(i,j)*100. ! cm !-- semis_ice is with snow effect semis_ice(i) = sfcems_ice(i,j) !-- sfalb_ice is with snow effect sfalb_ice(i) = alb_ice(i,j) + !-- albdvis_ice,albdnir_ice,albivis_ice,albinir_ice albdvis_ice(i) = sfalb_ice(i) albdnir_ice(i) = sfalb_ice(i) - albinir_ice(i) = sfalb_ice(i) + albivis_ice(i) = sfalb_ice(i) albinir_ice(i) = sfalb_ice(i) @@ -1497,22 +1550,27 @@ subroutine lsm_ruc_run & ! inputs !srflag(i) = srflag_old(i) tsnow_lnd(i) = tsnow_lnd_old(i) snowfallac_lnd(i) = snowfallac_lnd_old(i) - !acsnow(i) = acsnow_old(i) + acsnow_lnd(i) = acsnow_lnd_old(i) sfcqv_lnd(i) = sfcqv_lnd_old(i) sfcqc_lnd(i) = sfcqc_lnd_old(i) wetness(i) = wetness_old(i) z0rl_lnd(i) = z0rl_lnd_old(i) sncovr1_lnd(i) = sncovr1_lnd_old(i) + snowmt_lnd(i) = snowmt_lnd_old(i) !ice weasd_ice(i) = weasd_ice_old(i) snwdph_ice(i) = snwdph_ice_old(i) tskin_ice(i) = tskin_ice_old(i) tsnow_ice(i) = tsnow_ice_old(i) snowfallac_ice(i) = snowfallac_ice_old(i) + acsnow_ice(i) = acsnow_ice_old(i) sfcqv_ice(i) = sfcqv_ice_old(i) sfcqc_ice(i) = sfcqc_ice_old(i) z0rl_ice(i) = z0rl_ice_old(i) sncovr1_ice(i) = sncovr1_ice_old(i) + snowmt_ice(i) = snowmt_ice_old(i) + srunoff(i) = srunoff_old(i) + runoff(i) = runoff_old(i) do k = 1, lsoil_ruc smois(i,k) = smois_old(i,k) @@ -1530,9 +1588,6 @@ subroutine lsm_ruc_run & ! inputs endif ! flag enddo ! i enddo ! j -! - deallocate(soilctop) - deallocate(landusef) ! return !................................... diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 0d22f8d4a..3ff016f85 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -655,6 +655,20 @@ dimensions = () type = integer intent = in +[nlcat] + standard_name = number_of_vegetation_categories + long_name = number of vegetation categories + units = count + dimensions = () + type = integer + intent = in +[nscat] + standard_name = number_of_soil_categories + long_name = number of soil categories + units = count + dimensions = () + type = integer + intent = in [rdlai] standard_name = flag_for_reading_leaf_area_index_from_input long_name = flag for reading leaf area index from initial conditions for RUC LSM @@ -678,6 +692,22 @@ type = real kind = kind_phys intent = in +[oro] + standard_name = height_above_mean_sea_level + long_name = height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sigma] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [zs] standard_name = depth_of_soil_layers long_name = depth of soil levels for land surface model @@ -724,6 +754,22 @@ dimensions = (horizontal_loop_extent) type = integer intent = in +[vegtype_frac] + standard_name = fraction_of_vegetation_category + long_name = fraction of horizontal grid area occupied by given vegetation category + units = frac + dimensions = (horizontal_loop_extent,number_of_vegetation_categories) + type = real + kind = kind_phys + intent = in +[soiltype_frac] + standard_name = fraction_of_soil_category + long_name = fraction of horizontal grid area occupied by given soil category + units = frac + dimensions = (horizontal_loop_extent,number_of_soil_categories) + type = real + kind = kind_phys + intent = in [sigmaf] standard_name = vegetation_area_fraction long_name = areal fractional cover of green vegetation @@ -1015,6 +1061,14 @@ type = real kind = kind_phys intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in [con_fvirt] standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) @@ -1344,13 +1398,37 @@ kind = kind_phys intent = inout [snowfallac_lnd] - standard_name = surface_snow_amount_over_land - long_name = run-total snow accumulation on the ground over land + standard_name = surface_snow_amount_vardens_over_land + long_name = run-total snow accumulation on the ground with variable snow density over land + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acsnow_lnd] + standard_name = surface_snow_lwe_thickness_amount_over_land + long_name = run-total snowfall water equivalent over land units = kg m-2 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout +[snowmt_lnd] + standard_name = surface_snow_melt_over_land + long_name = snow melt during timestep over land + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snohf] + standard_name = snow_freezing_rain_upward_latent_heat_flux + long_name = latent heat flux due to snow and frz rain + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [albdvis_lnd] standard_name = surface_albedo_direct_visible_over_land long_name = direct surface albedo visible band over land @@ -1480,8 +1558,24 @@ kind = kind_phys intent = in [snowfallac_ice] - standard_name = surface_snow_amount_over_ice - long_name = run-total snow accumulation on the ground over ice + standard_name = surface_snow_amount_vardens_over_ice + long_name = run-total snow accumulation on the ground with variable snow density over ice + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acsnow_ice] + standard_name = surface_snow_lwe_thickness_amount_over_ice + long_name = run-total snowfall water equivalent over ice + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snowmt_ice] + standard_name = surface_snow_melt_over_ice + long_name = snow melt during timestep over ice units = kg m-2 dimensions = (horizontal_loop_extent) type = real @@ -1527,6 +1621,7 @@ type = real kind = kind_phys intent = inout + active = (control_for_land_surface_scheme == identifier_for_ruc_land_surface_scheme) [sbsno] standard_name = snow_deposition_sublimation_upward_latent_heat_flux long_name = latent heat flux from snow depo/subl diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 3090c0c11..744e321ef 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -19,28 +19,53 @@ MODULE module_sf_ruclsm public :: lsmruc, ruclsminit, rslf !> CONSTANT PARAMETERS +!! @{ real (kind=kind_phys), parameter :: P1000mb = 100000. real (kind=kind_phys), parameter :: xls = 2.85E6 real (kind=kind_phys), parameter :: rhowater= 1000. real (kind=kind_phys), parameter :: piconst = 3.1415926535897931 real (kind=kind_phys), parameter :: r_v = 4.6150e+2 + !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 + integer, parameter :: isncond_opt = 2 + + !-- Snow fraction options + !-- option 1: original formulation using threshold snow depth to compute snow fraction + !integer, parameter :: isncovr_opt = 1 + !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L., 2007,JGR,DOI:10.1029/2007JD008674. + !integer, parameter :: isncovr_opt = 2 + !-- option 3: the tanh formulation from Niu,G.-Y.,and Yang,Z with + ! vegetation-dependent parameters from Noah MP (personal communication with + ! Mike Barlage) + integer, parameter :: isncovr_opt = 3 + + !-- Mosaic_lu and mosaic_soil are defined in set_soilveg_ruc.F90 and + ! passes to RUC LSM via namelist_soilveg_ruc.F90. + +!! @} + !> VEGETATION PARAMETERS +!! @{ INTEGER :: LUCATS integer, PARAMETER :: NLUS=50 CHARACTER*8 LUTYPE +!! @} !> SOIL PARAMETERS +!! @{ INTEGER :: SLCATS INTEGER, PARAMETER :: NSLTYPE=30 CHARACTER*8 SLTYPE +!! @} !> LSM GENERAL PARAMETERS +!! @{ INTEGER :: SLPCATS INTEGER, PARAMETER :: NSLOPE=30 REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & CZIL_DATA +!! @} CONTAINS @@ -49,24 +74,25 @@ MODULE module_sf_ruclsm !>\ingroup lsm_ruc_group !> The RUN LSM model is described in Smirnova et al.(1997) !! \cite Smirnova_1997 and Smirnova et al.(2000) \cite Smirnova_2000 -!>\section gen_lsmruc_ga RUC LSM General Algorithm - SUBROUTINE LSMRUC( & +!>\section gen_lsmruc GSD RUC LSM General Algorithm +!! @{ + SUBROUTINE LSMRUC(xlat,xlon, & DT,init,lsm_cold_start,KTAU,iter,NSL, & graupelncv,snowncv,rainncv,raincv, & ZS,RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & - rhosnf,precipfr,exticeden, & + rhosnf,precipfr,exticeden, hgt,stdev, & Z3D,P8W,T3D,QV3D,QC3D,RHO3D,EMISBCK, & GLW,GSWdn,GSW,EMISS,CHKLOWQ, CHS, & FLQC,FLHC,rhonewsn_ex,MAVAIL,CANWAT,VEGFRA, & - ALB, ZNT,Z0,SNOALB,ALBBCK,LAI, & - landusef, nlcat, & ! mosaic_lu, mosaic_soil, & - soilctop, nscat, & + ALB,ZNT,Z0,SNOALB,ALBBCK,LAI, & + landusef, nlcat, soilctop, nscat, & QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, & TBOT,IVGTYP,ISLTYP,XLAND, & ISWATER,ISICE,XICE,XICE_THRESHOLD, & CP,RV,RD,G0,PI,LV,STBOLT, & SOILMOIS,SH2O,SMAVAIL,SMMAX, & - TSO,SOILT,HFX,QFX,LH,INFILTR, & + TSO,SOILT,EDIR,EC,ETT,SUBLIM,SNOH, & + HFX,QFX,LH,INFILTR, & RUNOFF1,RUNOFF2,ACRUNOFF,SFCEXC, & SFCEVP,GRDFLX,SNOWFALLAC,ACSNOW,SNOM, & SMFR3D,KEEPFR3DFLAG, & @@ -125,7 +151,7 @@ SUBROUTINE LSMRUC( & !-- XLAND land mask (1 for land, 2 for water) !-- CP heat capacity at constant pressure for dry air (J/kg/K) !-- G0 acceleration due to gravity (m/s^2) -!-- LV latent heat of melting (J/kg) +!-- LV latent heat of evaporation (J/kg) !-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4) ! SOILMOIS - soil moisture content (volumetric fraction) ! TSO - soil temp (K) @@ -136,9 +162,9 @@ SUBROUTINE LSMRUC( & ! SFCRUNOFF - ground surface runoff [mm] ! UDRUNOFF - underground runoff [mm] ! ACRUNOFF - run-total surface runoff [mm] -! SFCEVP - total evaporation in [kg/m^2] +! SFCEVP - total time-step evaporation in [kg/m^2] ! GRDFLX - soil heat flux (W/m^2: negative, if downward from surface) -! SNOWFALLAC - run-total snowfall accumulation [m] +! SNOWFALLAC - run-total snowfall accumulation [mm] ! ACSNOW - run-toral SWE of snowfall [mm] !-- CHKLOWQ - is either 0 or 1 (so far set equal to 1). !-- used only in MYJPBL. @@ -157,9 +183,10 @@ SUBROUTINE LSMRUC( & ! INTEGER, PARAMETER :: nzss=5 ! INTEGER, PARAMETER :: nddzs=2*(nzss-2) + REAL, INTENT(IN ) :: xlat,xlon REAL, INTENT(IN ) :: DT LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden - INTEGER, INTENT(IN ) :: NLCAT, NSCAT ! , mosaic_lu, mosaic_soil + INTEGER, INTENT(IN ) :: NLCAT, NSCAT INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte @@ -192,14 +219,13 @@ SUBROUTINE LSMRUC( & INTENT(IN ) :: GRAUPELNCV, & SNOWNCV, & RAINCV, & - RAINNCV, & - RHONEWSN_ex !externally-calculated srf frz precip density -! REAL, DIMENSION( ims:ime , jms:jme ), & -! INTENT(IN ) :: lakemask -! INTEGER, INTENT(IN ) :: LakeModel + RAINNCV + REAL, DIMENSION( ims:ime), INTENT(IN ) :: RHONEWSN_ex !externally-calculated srf frz precip density REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev LOGICAL, intent(in) :: rdlai2d REAL, DIMENSION( 1:nsl), INTENT(IN ) :: ZS @@ -241,6 +267,11 @@ SUBROUTINE LSMRUC( & HFX, & QFX, & LH, & + EDIR, & + EC, & + ETT, & + SUBLIM, & + SNOH, & SFCEVP, & RUNOFF1, & RUNOFF2, & @@ -266,15 +297,12 @@ SUBROUTINE LSMRUC( & SFCRUNOFF, & UDRUNOFF, & EMISSL, & + MSNF, & + FACSNF, & ZNTL, & LMAVAIL, & SMELT, & - SNOH, & SNFLX, & - EDIR, & - EC, & - ETT, & - SUBLIM, & sflx, & smf, & EVAPL, & @@ -327,6 +355,7 @@ SUBROUTINE LSMRUC( & KICE, & KWT + REAL, DIMENSION(1:NSL) :: ZSMAIN, & ZSHALF, & DTDZS2 @@ -382,8 +411,13 @@ SUBROUTINE LSMRUC( & INTEGER :: I,J,K,NZS,NZS1,NDDZS INTEGER :: k1,k2 logical :: debug_print - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + + !-- diagnostic point + real (kind=kind_phys) :: testptlat, testptlon + + character(len=*),intent(out) :: errmsg + integer, intent(out) :: errflg + !----------------------------------------------------------------- ! ! Initialize error-handling @@ -397,6 +431,12 @@ SUBROUTINE LSMRUC( & NZS=NSL NDDZS=2*(nzs-2) + !-- + testptlat = 48.7074 !39.958 !42.05 !39.0 !74.12 !29.5 + testptlon = 289.03 !271.622 !286.75 !280.6 !164.0 !283.0 + !-- + + !> - Table TBQ is for resolution of balance equation in vilka() CQ=173.15-.05 R273=1./273.15 @@ -420,44 +460,50 @@ SUBROUTINE LSMRUC( & !> - Initialize soil/vegetation parameters !--- This is temporary until SI is added to mass coordinate ---!!!!! - if(init .and. (lsm_cold_start) .and. iter == 1) then - DO J=jts,jte + if(init .and. iter == 1) then + + if( lsm_cold_start ) then + !-- beginning of cold-start + DO J=jts,jte DO i=its,ite -! do k=1,nsl -! keepfr3dflag(i,k,j)=0. -! enddo -!> - Initializing snow fraction, thereshold = 32 mm of snow water -!! or ~100 mm of snow height ! -! snowc(i,j) = min(1.,snow(i,j)/32.) -! soilt1(i,j)=soilt(i,j) -! if(snow(i,j).le.32.) soilt1(i,j)=tso(i,1,j) -!> - Initializing inside snow temp if it is not defined - IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN - IF(snow(i,j).gt.32.) THEN - soilt1(i,j)=0.5*(soilt(i,j)+tso(i,1,j)) - IF (debug_print ) THEN - print *, & - 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,j - ENDIF - ELSE - soilt1(i,j) = tso(i,1,j) - ENDIF - ENDIF - tsnav(i,j) =0.5*(soilt(i,j)+tso(i,1,j))-273.15 - qcg (i,j) =0. +!> - Initializing inside-snow temp if it is not defined + IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN + IF(snowc(i,j).gt.0.) THEN + soilt1(i,j)=min(273.15,0.5*(soilt(i,j)+tso(i,1,j)) ) + IF (debug_print ) THEN + print *, & + 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,xlat,xlon + ENDIF + ELSE + soilt1(i,j) = tso(i,1,j) + ENDIF + ENDIF + tsnav(i,j) =min(0.,0.5*(soilt(i,j)+tso(i,1,j))-273.15) + !- 10feb22 - limit snow albedo at high elevations + !- based on Roesch et al., Climate Dynamics (2001),17:933-946 + if(hgt(i,j) > 2500.) then + snoalb(i,j) = min(0.65,snoalb(i,j)) + endif + patmb=P8w(i,kms,j)*1.e-2 QSG (i,j) = QSN(SOILT(i,j),TBQ)/PATMB - IF((qvg(i,j) .LE. 0.) .or. (qvg(i,j) .GT.0.1)) THEN - !17sept19 - bad approximation with very low mavail. - !qvg(i,j) = QSG(i,j)*mavail(i,j) - qvg (i,j) = qv3d(i,1,j) - IF (debug_print ) THEN - print *, & - 'QVG is initialized in RUCLSM ', qvg(i,j),mavail(i,j),qsg(i,j),i,j - ENDIF - ENDIF -! qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) + + if((qcg(i,j) < 0.) .or. (qcg(i,j) > 0.1)) then + qcg (i,j) = qc3d(i,1,j) + if (debug_print ) then + print *, 'QCG is initialized in RUCLSM ', qcg(i,j),qc3d(i,1,j),i,xlat,xlon + endif + endif + + if((qvg(i,j) .LE. 0.) .or. (qvg(i,j) .GT.0.1)) then + qvg (i,j) = qv3d(i,1,j) + if (debug_print ) then + print *, 'QVG is initialized in RUCLSM ', qvg(i,j),mavail(i,j),qsg(i,j),i,xlat,xlon + endif + endif + qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) + SMELT(i,j) = 0. SNOM (i,j) = 0. ACSNOW(i,j) = 0. @@ -474,14 +520,14 @@ SUBROUTINE LSMRUC( & UDRUNOFF(i,j) = 0. ACRUNOFF(i,j) = 0. emissl (i,j) = 0. + msnf (i,j) = 0. + facsnf (i,j) = 0. budget(i,j) = 0. acbudget(i,j) = 0. waterbudget(i,j) = 0. acwaterbudget(i,j) = 0. smtotold(i,j)=0. canwatold(i,j)=0. -! Temporarily!!! -! canwat(i,j)=0. !> - For RUC LSM CHKLOWQ needed for MYJPBL should !! 1 because is actual specific humidity at the surface, and @@ -498,20 +544,14 @@ SUBROUTINE LSMRUC( & evapl (i,j) = 0. prcpl (i,j) = 0. ENDDO - ENDDO - - infiltrp = 0. - do k=1,nsl - soilice(k)=0. - soiliqw(k)=0. - enddo - else ! .not. init==true. - DO J=jts,jte - DO i=its,ite - SFCRUNOFF(i,j) = 0. - UDRUNOFF(i,j) = 0. - ENDDO ENDDO + + infiltrp = 0. + do k=1,nsl + soilice(k)=0. + soiliqw(k)=0. + enddo + endif ! cold start endif ! init==.true. !----------------------------------------------------------------- @@ -528,22 +568,16 @@ SUBROUTINE LSMRUC( & DO i=its,ite IF (debug_print ) THEN -! if(j==10) then - print *,' IN LSMRUC ','ims,ime,jms,jme,its,ite,jts,jte,nzs', & - ims,ime,jms,jme,its,ite,jts,jte,nzs - print *,' IVGTYP, ISLTYP ', ivgtyp(i,j),isltyp(i,j) - print *,' MAVAIL ', mavail(i,j) - print *,' SOILT,QVG,P8w',soilt(i,j),qvg(i,j),p8w(i,1,j) - print *, 'LSMRUC, I,J,xland, QFX,HFX from SFCLAY',i,j,xland(i,j), & - qfx(i,j),hfx(i,j) - print *, ' GSW, GLW =',gsw(i,j),glw(i,j) - print *, 'SOILT, TSO start of time step =',soilt(i,j),(tso(i,k,j),k=1,nsl) - print *, 'SOILMOIS start of time step =',(soilmois(i,k,j),k=1,nsl) - print *, 'SMFROZEN start of time step =',(smfr3d(i,k,j),k=1,nsl) - print *, ' I,J=, after SFCLAY CHS,FLHC ',i,j,chs(i,j),flhc(i,j) - print *, 'LSMRUC, IVGTYP,ISLTYP,ALB = ', ivgtyp(i,j),isltyp(i,j),alb(i,j),i,j - print *, 'LSMRUC I,J,DT,RAINBL =',I,J,dt,RAINBL(i,j) - print *, 'XLAND ---->, ivgtype,isoiltyp,i,j',xland(i,j),ivgtyp(i,j),isltyp(i,j),i,j + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print 100,'(RUC start) i=',i,' lat,lon=',xlat,xlon, & + 'mavail ', mavail(i,j),' soilt',soilt(i,j),'qvg ',qvg(i,j),& + 'p8w',p8w(i,1,j),'sflay qfx',qfx(i,j),'sflay hfx',hfx(i,j),& + 'gsw ',gsw(i,j),'glw ',glw(i,j),'soilt ',soilt(i,j), & + 'chs ',chs(i,j),'flqc ',flhc(i,j),'alb ',alb(i,j), & + 'rainbl ',rainbl(i,j),'dt ',dt + print *,'nzs',nzs, 'ivgtyp ',ivgtyp(i,j),'isltyp ',isltyp(i,j) + endif ENDIF @@ -652,7 +686,10 @@ SUBROUTINE LSMRUC( & NZS1=NZS-1 !----- IF (debug_print ) THEN - print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf + endif ENDIF DO K=2,NZS1 @@ -691,7 +728,7 @@ SUBROUTINE LSMRUC( & ! ! rooting depth RHONEWSN = 200. - if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.) then + if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.02) then RHOSN = SNOW(i,j)/SNOWH(i,j) else RHOSN = 300. @@ -699,38 +736,42 @@ SUBROUTINE LSMRUC( & IF (debug_print ) THEN if(init) then - print *,'before SOILVEGIN - z0,znt(195,254)',z0(i,j),znt(i,j) - print *,'ILAND, ISOIL =',i,j,iland,isoil + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'before SOILVEGIN - z0,znt',i,z0(i,j),znt(i,j) + print *,'ILAND, ISOIL =',i,iland,isoil + endif endif ENDIF !> - Call soilvegin() to initialize soil and surface properties !-- land or ice CALL SOILVEGIN ( debug_print, & - soilfrac,nscat,shdmin(i,j),shdmax(i,j),mosaic_lu, mosaic_soil,& + soilfrac,nscat,shdmin(i,j),shdmax(i,j), & NLCAT,ILAND,ISOIL,iswater,MYJ,IFOREST,lufrac,VEGFRA(I,J), & - EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),RDLAI2D, & + EMISSL(I,J),PC(I,J),MSNF(I,J),FACSNF(I,J), & + ZNT(I,J),LAI(I,J),RDLAI2D, & QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j,errmsg, errflg) !-- update background emissivity for land points, can have vegetation mosaic effect EMISBCK(I,J) = EMISSL(I,J) IF (debug_print ) THEN - if(init) & - print *,'after SOILVEGIN - z0,znt(1,26),lai(1,26)',z0(i,j),znt(i,j),lai(i,j) - if(init)then + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'after SOILVEGIN - z0,znt,lai',i,z0(i,j),znt(i,j),lai(i,j) print *,'NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J)', & NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),i,j print *,'NSCAT,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT',& NSCAT,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j + endif endif ENDIF CN=CFACTR_DATA ! exponent ! SAT=max(1.e-5,(min(5.e-4,(CMCMAX_DATA * (1.-exp(-0.5*lai(i,j))) * 0.01*VEGFRA(I,J))))) ! canopy water saturated SAT = 5.e-4 ! units [m] -! if(i==666.and.j==282) print *,'second 666,282 - sat',sat !-- definition of number of soil levels in the rooting zone ! IF(iforest(ivgtyp(i,j)).ne.1) THEN @@ -774,14 +815,6 @@ SUBROUTINE LSMRUC( & print *,'NROOT, meltfactor, iforest, ivgtyp, i,j ', nroot,meltfactor,iforest,ivgtyp(I,J),I,J ENDIF -!!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS -! if(i.eq.397.and.j.eq.562) then -! print *,'RUC LSM - xland(i,j),xice(i,j),snow(i,j)',i,j,xland(i,j),xice(i,j),snow(i,j) -! endif - -! if(lakemodel==1 .and. lakemask(i,j)==1.) goto 2999 -!Lakes - IF((XLAND(I,J)-1.5).GE.0.)THEN !-- Water SMAVAIL(I,J)=1.0 @@ -817,7 +850,6 @@ SUBROUTINE LSMRUC( & ! LAND POINT OR SEA ICE if(xice(i,j).ge.xice_threshold) then -! if(IVGTYP(i,j).eq.isice) then SEAICE(i,j)=1. else SEAICE(i,j)=0. @@ -879,36 +911,48 @@ SUBROUTINE LSMRUC( & LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/(ref-qmin))) IF (debug_print ) THEN - print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & - i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO - print *,'CONFLX =',CONFLX - print *,'SMFRKEEP,KEEPFR ',SMFRKEEP,KEEPFR + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & + i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO + print *,'CONFLX =',CONFLX + print *,'SMFRKEEP,KEEPFR ',SMFRKEEP,KEEPFR + endif ENDIF smtotold(i,j)=0. - do k=1,nzs-1 + + !do k=1,nzs-1 + do k=1,nroot smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(k))* & (zshalf(k+1)-zshalf(k)) enddo - smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(nzs))* & - (zsmain(nzs)-zshalf(nzs)) + !smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(nzs))* & + ! (zsmain(nzs)-zshalf(nzs)) + if (debug_print .and. abs(xlat-testptlat).lt.0.2 & + .and. abs(xlon-testptlon).lt.0.2) then + print *,'Old soilm1d ',i,soilm1d + endif canwatold(i,j) = canwatr !----------------------------------------------------------------- CALL SFCTMP (debug_print, dt,ktau,conflx,i,j, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,nddzs,nroot,meltfactor, & !added meltfactor iland,isoil,ivgtyp(i,j),isltyp(i,j), & PRCPMS, NEWSNMS,SNWE,SNHEI,SNOWFRAC, & - exticeden,RHOSN,RHONEWSN_ex(I,J),RHONEWSN, & + exticeden,RHOSN,RHONEWSN_ex(I),RHONEWSN, & RHOSNFALL,snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,RHO, & GLW(I,J),GSWdn(i,j),GSW(I,J), & EMISSL(I,J),EMISBCK(I,J), & + msnf(i,j), facsnf(i,j), & QKMS,TKMS,PC(I,J),LMAVAIL(I,J), & canwatr,vegfra(I,J),alb(I,J),znt(I,J), & - snoalb(i,j),albbck(i,j),lai(i,j), & !new + snoalb(i,j),albbck(i,j),lai(i,j), & + hgt(i,j),stdev(i,j), & !new myj,seaice(i,j),isice, & !--- soil fixed fields QWRTZ, & @@ -937,7 +981,6 @@ SUBROUTINE LSMRUC( & ! This change violates LSM moisture budget, but ! can be considered as a compensation for irrigation not included into LSM. - if(1==2) then !tgs - turn off "irrigation" while there is no fractional landuse and LAI !climatology. IF (lufrac(crop) > 0 .and. lai(i,j) > 1.1) THEN @@ -975,7 +1018,6 @@ SUBROUTINE LSMRUC( & endif enddo ENDIF - endif ! 1==2 !*** DIAGNOSTICS !--- available and maximum soil moisture content in the soil @@ -984,25 +1026,38 @@ SUBROUTINE LSMRUC( & smavail(i,j) = 0. smmax (i,j) = 0. - do k=1,nzs-1 + !do k=1,nzs-1 + !-- root-zone soil moisture + do k=1,nroot smavail(i,j)=smavail(i,j)+(qmin+soilm1d(k))* & (zshalf(k+1)-zshalf(k)) smmax (i,j) =smmax (i,j)+(qmin+dqm)* & (zshalf(k+1)-zshalf(k)) enddo - smavail(i,j)=smavail(i,j)+(qmin+soilm1d(nzs))* & - (zsmain(nzs)-zshalf(nzs)) - smmax (i,j) =smmax (i,j)+(qmin+dqm)* & - (zsmain(nzs)-zshalf(nzs)) + !smavail(i,j)=smavail(i,j)+(qmin+soilm1d(nzs))* & + ! (zsmain(nzs)-zshalf(nzs)) + !smmax (i,j) =smmax (i,j)+(qmin+dqm)* & + ! (zsmain(nzs)-zshalf(nzs)) + if (debug_print) then + if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print 100,'(RUC runoff) i=',i,' lat,lon=',xlat,xlon, & + 'RUNOFF1', RUNOFF1(I,J), 'RUNOFF2 ',RUNOFF2(I,J), & + 'edir ',edir(I,J),'ec ',ec(I,J),'ett ',ett(I,J) + endif + endif !--- Convert the water unit into mm - SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 - UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 - ACRUNOFF(I,J) = ACRUNOFF(I,J)+(RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 - SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. + !-- three lines below are commented because accumulation + ! happens in sfc_drv_ruc + !SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 + !UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 + !ACRUNOFF (I,J) = ACRUNOFF(i,j)+UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 + ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 + !ACRUNOFF(I,J) = ACRUNOFF(i,j)+RUNOFF1(I,J)*DT*1000.0 ! acc surface runoff + SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. ! mm SMMAX (I,J) = SMMAX(I,J) * 1000. - smtotold (I,J) = smtotold(I,J) * 1000. + smtotold (I,J) = smtotold(I,J) * 1000. ! mm do k=1,nzs @@ -1022,7 +1077,7 @@ SUBROUTINE LSMRUC( & !tgs add together dew and cloud at the ground surface !30july13 qcg(i,j)=qcg(i,j)+dew(i,j)/qkms - Z0 (I,J) = ZNT (I,J) + !Z0 (I,J) = ZNT (I,J) SFCEXC (I,J) = TKMS patmb=P8w(i,1,j)*1.e-2 Q2SAT=QSN(TABS,TBQ)/PATMB @@ -1039,13 +1094,6 @@ SUBROUTINE LSMRUC( & ! CHKLOWQ(I,J)=1. ! endif - IF (debug_print ) THEN - if(CHKLOWQ(I,J).eq.0.) then - print *,'i,j,CHKLOWQ', & - i,j,CHKLOWQ(I,J) - endif - ENDIF - if(snow(i,j)==0.) EMISSL(i,j) = EMISBCK(i,j) EMISS (I,J) = EMISSL(I,J) ! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m @@ -1053,14 +1101,18 @@ SUBROUTINE LSMRUC( & SNOWH (I,J) = SNHEI CANWAT (I,J) = CANWATR*1000. -if (debug_print) then - print *,'snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j)',snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j) -endif + if (debug_print) then + if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print *,'snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j)',snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j) + endif + endif INFILTR(I,J) = INFILTRP MAVAIL (i,j) = LMAVAIL(I,J) IF (debug_print ) THEN - print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + endif ENDIF !!! QFX (I,J) = LH(I,J)/LV SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT @@ -1074,9 +1126,9 @@ SUBROUTINE LSMRUC( & ! endif !--- SNOWC snow cover flag - if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then - SNOWFRAC = SNOWFRAC*XICE(I,J) - endif + !if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then + ! SNOWFRAC = SNOWFRAC*XICE(I,J) + !endif SNOWC(I,J)=SNOWFRAC @@ -1098,20 +1150,34 @@ SUBROUTINE LSMRUC( & ! endif ! budget(i,j)=budget(i,j)-smf(i,j) + if (debug_print ) then + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + !-- compute budget for a test point ac=0. as=0. + wb=0. - ac=max(0.,canwat(i,j)-canwatold(i,j)*1.e3) - as=max(0.,snwe-snowold(i,j)) - wb =rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source - -qfx(i,j)*dt & - -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 & - -ac-as - (smavail(i,j)-smtotold(i,j)) - + ac=canwat(i,j)-canwatold(i,j)*1.e3 ! canopy water change + as=snwe-snowold(i,j) ! SWE change + wb = smavail(i,j)-smtotold(i,j) waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source -qfx(i,j)*dt & -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 & - -ac-as - (smavail(i,j)-smtotold(i,j)) + -ac-as ! - (smavail(i,j)-smtotold(i,j)) + + print *,'soilm1d ',i,soilm1d + print 100,'(RUC budgets) i=',i,' lat,lon=',xlat,xlon, & + 'budget ',budget(i,j),'waterbudget',waterbudget(i,j), & + 'rainbl ',rainbl(i,j),'runoff1 ',runoff1(i,j), & + 'smelt ',smelt(i,j)*dt*1.e3,'smc change ',wb, & + 'snwe change ',as,'canw change ',ac,'runoff2 ',runoff2(i,j), & + 'qfx*dt ',qfx(i,j)*dt,'smavail ',smavail(i,j),'smcold',smtotold(i,j) + endif + endif + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es14.7))) + !-- + ! waterbudget(i,j)=rainbl(i,j)-qfx(i,j)*dt-(smavail(i,j)-smtotold(i,j)) & @@ -1121,27 +1187,29 @@ SUBROUTINE LSMRUC( & !!!!TEST use LH to check water budget ! GRDFLX (I,J) = waterbudget(i,j) - IF (debug_print ) THEN - print *,'Smf=',smf(i,j),i,j - print *,'Budget',budget(i,j),i,j - print *,'RUNOFF2= ', i,j,runoff2(i,j) - print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb - print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & - i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & - smelt(i,j)*dt*1.e3, & - (smavail(i,j)-smtotold(i,j)) - - print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) - print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) - print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) - print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) - ENDIF +! print *,'Smf=',smf(i,j),i,j +! print *,'Budget',budget(i,j),i,j +! print *,'RUNOFF2= ', i,j,runoff2(i,j) +! print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb +! print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & +! i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & +! smelt(i,j)*dt*1.e3, & +! (smavail(i,j)-smtotold(i,j)) +! +! print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) +! print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) +! print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) +! print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) +! ENDIF IF (debug_print ) THEN - print *,'LAND, i,j,tso1d,soilm1d,soilt - end of time step', & + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'LAND, i,j,tso1d,soilm1d,soilt - end of time step', & i,j,tso1d,soilm1d,soilt(i,j) - print *,'LAND, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + print *,'LAND, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + endif ENDIF !--- end of a land or sea ice point @@ -1153,6 +1221,7 @@ SUBROUTINE LSMRUC( & !----------------------------------------------------------------- END SUBROUTINE LSMRUC +!! @} !----------------------------------------------------------------- !>\ingroup lsm_ruc_group @@ -1165,15 +1234,16 @@ END SUBROUTINE LSMRUC !! the snow "mosaic" approach is turned on. !! - Updates emissivity and albedo for patch snow. SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input variables + xlat,xlon,testptlat,testptlon, & nzs,nddzs,nroot,meltfactor, & ILAND,ISOIL,IVGTYP,ISLTYP,PRCPMS, & NEWSNMS,SNWE,SNHEI,SNOWFRAC, & exticeden,RHOSN,RHONEWSN_ex,RHONEWSN,RHOSNFALL, & snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,rho, & - GLW,GSWdn,GSW,EMISS,EMISBCK,QKMS,TKMS,PC, & - MAVAIL,CST,VEGFRA,ALB,ZNT, & - ALB_SNOW,ALB_SNOW_FREE,lai, & + GLW,GSWdn,GSW,EMISS,EMISBCK,msnf,facsnf, & + QKMS,TKMS,PC,MAVAIL,CST,VEGFRA,ALB,ZNT, & + ALB_SNOW,ALB_SNOW_FREE,lai,hgt,stdev, & MYJ,SEAICE,ISICE, & QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & !--- soil fixed fields sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & @@ -1195,9 +1265,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: isice,i,j,nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor + REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon + REAL, INTENT(IN ) :: testptlat,testptlon REAL, INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex - LOGICAL, INTENT(IN ) :: myj, debug_print, exticeden + LOGICAL, INTENT(IN ) :: myj, debug_print, exticeden !--- 3-D Atmospheric variables REAL , & INTENT(IN ) :: PATM, & @@ -1209,9 +1280,11 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia GSW, & GSWdn, & PC, & + msnf,facsnf, & VEGFRA, & ALB_SNOW_FREE, & lai, & + hgt,stdev, & SEAICE, & RHO, & QKMS, & @@ -1289,7 +1362,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INFILTR, & RHOSN, & RHONEWSN, & - rhosnfall, & + rhosnfall, & snowrat, & grauprat, & icerat, & @@ -1365,7 +1438,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia REAL :: BSN, XSN , & RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & - T3, UPFLUX, XINET + T3, UPFLUX, XINET, snowfrac2, m REAL :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn REAL :: newsnowratio, dd1 @@ -1384,11 +1457,25 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SNWE,RHOSN,SNOM,SMELT,TS1D ENDIF + !-- Snow fraction options + !-- option 1: original formulation using critical snow depth to compute + !-- snow fraction + !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L. 2007,JGR,DOI:10.1029/2007JD008674. + !-- option 3: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L. 2007,JGR,DOI:10.1029/2007JD008674. + ! with vegetation dependent parameters from Noah MP (personal + ! communication with Mike Barlage) + !-- SNHEI_CRIT is a threshold for fractional snow in isncovr_opt=1 + snhei_crit=0.01601*1.e3/rhosn + snhei_crit_newsn=0.0005*1.e3/rhosn + !-- + zntsn = z0tbl(isice) snow_mosaic=0. snfr = 1. NEWSN=0. newsnowratio = 0. snowfracnewsn=0. + snowfrac2=0. + rhonewsn = 100. if(snhei == 0.) snowfrac=0. smelt = 0. RAINF = 0. @@ -1460,23 +1547,18 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(bsn*snwe*100..lt.1.e-4) goto 777 XSN=rhosn*(exp(bsn*snwe*100.)-1.)/(bsn*snwe*100.) rhosn=MIN(MAX(58.8,XSN),500.) -!13mar18 rhosn=MIN(MAX(76.9,XSN),500.) -! rhosn=MIN(MAX(62.5,XSN),890.) -! rhosn=MIN(MAX(100.,XSN),400.) -! rhosn=MIN(MAX(50.,XSN),400.) 777 continue - -! else -! rhosn =200. -! rhonewsn =200. endif + !-- snow_mosaic from the previous time step + if(snowfrac < 0.75) snow_mosaic = 1. + !if(snowfrac < 0.9) snow_mosaic = 1. + newsn=newsnms*delt !---- ACSNOW - run-total snowfall water [mm] acsnow=acsnow+newsn*1.e3 IF(NEWSN.GT.0.) THEN -! IF(NEWSN.GE.1.E-8) THEN IF (debug_print ) THEN print *, 'THERE IS NEW SNOW, newsn', newsn @@ -1484,18 +1566,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia newsnowratio = min(1.,newsn/(snwe+newsn)) -!*** Calculate fresh snow density (t > -15C, else MIN value) -!*** Eq. 10 from Koren et al. (1999) -!--- old formulation from Koren (1999) -! if(tabs.lt.258.15) then -! rhonewsn=50. -! rhonewsn=100. -! rhonewsn=62.5 - -! else -! rhonewsn=MIN(rhonewsn,400.) -! endif -!--- end of old formulation + !if(isncovr_opt == 2) then + !-- update snow fraction for fresh snowfall (Swenson&Lawrence,JGR,2012) + ! time-step snowfall [mm H2O], 0.1 - accumulation constant (unitless) + ! snowfrac = snowfrac + tanh(0.1*newsn*1.e3)*(1.-snowfrac) ! eq. 8.1 from CLM5 + ! if(debug_print) print *,'2 - snowfrac newsn', i,j,ktau,snowfrac + !endif !--- 27 Feb 2014 - empirical formulations from John M. Brown ! rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-Tabs)*0.3333)))) @@ -1506,13 +1582,21 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-Tabs)*0.15)))) rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-Tabs)*0.3333)))) rhonewice=rhonewsn + !--- compute density of "snowfall" from weighted contribution ! of snow, graupel and ice fractions - rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & + rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & !13mar18 rhosnfall = min(500.,max(76.9,(rhonewsn*snowrat + & rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) + if (debug_print) then + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' xlat, xlon', xlat, xlon + print *,'snow_mosaic = ',snow_mosaic + print *,'new snow,newsnowratio,rhosnfall =',newsn,newsnowratio,rhosnfall + print *,'snowrat,grauprat,icerat,curat,rhonewgr,rhonewsn,rhonewice',snowrat,grauprat,icerat,curat,rhonewgr,rhonewsn,rhonewice + endif ! from now on rhonewsn is the density of falling frozen precipitation rhonewsn=rhosnfall end if @@ -1523,15 +1607,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia xsn=(rhosn*snwe+rhonewsn*newsn)/ & (snwe+newsn) rhosn=MIN(MAX(58.8,XSN),500.) -!13mar18 rhosn=MIN(MAX(76.9,XSN),500.) -! rhosn=MIN(MAX(100.,XSN),500.) -! rhosn=MIN(MAX(50.,XSN),400.) - -!Update snow on the ground -! snwe=snwe+newsn -! newsnowratio = min(1.,newsn/snwe) -! snhei=snwe*rhowater/rhosn -! NEWSN=NEWSN*rhowater/rhonewsn ENDIF ! end NEWSN > 0. IF(PRCPMS.NE.0.) THEN @@ -1552,9 +1627,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! J. of Hydrometeorology, 2006, CLM. interw=0.25*DELT*PRCPMS*(1.-exp(-0.5*lai))*vegfrac intersn=0.25*NEWSN*(1.-exp(-0.5*lai))*vegfrac -!original - next 2 lines -! interw=DELT*PRCPMS*vegfrac -! intersn=NEWSN*vegfrac infwater=PRCPMS - interw/delt if((interw+intersn) > 0.) then intwratio=interw/(interw+intersn) @@ -1563,7 +1635,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! Update water/snow intercepted by the canopy dd1=CST + interw + intersn CST=DD1 -! if(i==666.and.j==282) print *,'666,282 - cst,sat,interw,intersn',cst,sat,interw,intersn IF(CST.GT.SAT) THEN CST=SAT DRIP=DD1-SAT @@ -1576,12 +1647,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia infwater=PRCPMS endif ! vegfrac > 0.01 -! SNHEI_CRIT is a threshold for fractional snow - SNHEI_CRIT=0.01601*1.e3/rhosn - SNHEI_CRIT_newsn=0.0005*1.e3/rhosn -! snowfrac from the previous time step - SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) - if(snowfrac < 0.75) snow_mosaic = 1. IF(NEWSN.GT.0.) THEN !Update snow on the ground @@ -1606,7 +1671,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia IF(SNHEI.GT.0.0) THEN !-- SNOW on the ground !--- Land-use category should be changed to snow/ice for grid points with snow>0 - ILAND=ISICE + ILAND=ISICE !24nov15 - based on field exp on Pleasant View soccer fields ! if(meltfactor > 1.5) then ! all veg. types, except forests ! SNHEI_CRIT=0.01601*1.e3/rhosn @@ -1618,9 +1683,38 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! SNHEI_CRIT_newsn=0.001*1.e3/rhosn ! endif - SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) -!24nov15 - SNOWFRAC for urban category < 0.75 - if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + !-- update snow cover with accounting for fresh snow + m = 1.0 ! m=1.6 in Niu&Yang, m=1 in CLM + if(isncovr_opt == 1) then + snowfrac=min(1.,snhei/(2.*snhei_crit)) + elseif(isncovr_opt == 2) then + snowfrac=min(1.,snhei/(2.*snhei_crit)) + if(ivgtyp == glacier .or. ivgtyp == bare) then + !-- sparsely vegetated or land ice + snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**m)) + !- TEST - replace rhonewsn with 100 in Niu&Yang + !snowfrac2 = tanh( snhei/(2.5 * znt *(rhosn*1.e-2)**m)) + else + !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests + ! on 3-km scale use actual roughness, but not higher than 0.2 m. + ! The factor is 20 for forests (~100/dx = 33.) + snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m)) + !- TEST - replace rhonewsn with 100 in Niu&Yang + !snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn*1.e-2)**m)) + endif + !-- snow fraction is average between method 1 and 2 + snowfrac = 0.5*(snowfrac+snowfrac2) + else + !-- isncovr_opt=3 + !m = msnf ! vegetation dependent facsnf/msnf from Noah MP + !-- for RRFS a factor 10. was added to 'facsnf' to get reasonal values of + ! snow cover fractions on the 3-km scale. + ! This factor is scale dependent. + snowfrac = tanh( snhei/(10. * facsnf *(rhosn/rhonewsn)**m)) + !- TEST - replace rhonewsn with 100 in Niu&Yang + !snowfrac = tanh( snhei/(10. * facsnf *(rhosn*1.e-2)**m)) + endif + ! if(meltfactor > 1.5) then ! if(isltyp > 9 .and. isltyp < 13) then !24nov15 clay soil types - SNOFRAC < 0.9 @@ -1631,19 +1725,25 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! snowfrac=min(0.85,snowfrac) ! endif -! SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) -! elseif(snowfrac < 0.3 .and. tabs > 275.) then -! if(snowfrac < 0.3.and. tabs > 275.) snow_mosaic = 1. + if(newsn > 0. ) then + SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) + endif + + !-- due to steep slopes and blown snow, limit snow fraction in the + !-- mountains to 0.85 (based on Swiss weather model over the Alps) + if(hgt > 2500. .and. ivgtyp == glacier) snowfrac=min(0.85,snowfrac) - if(snowfrac < 0.75) snow_mosaic = 1. + !24nov15 - SNOWFRAC for urban category < 0.75 + if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) - if(newsn > 0. ) SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) + if(snowfrac < 0.75) snow_mosaic = 1. + !if(snowfrac < 0.9) snow_mosaic = 1. - KEEP_SNOW_ALBEDO = 0. - IF (NEWSN > 0. .and. snowfracnewsn > 0.99) THEN + KEEP_SNOW_ALBEDO = 0. + IF (NEWSN > 0. .and. snowfracnewsn > 0.99 .and. rhosnfall < 450.) THEN ! new snow KEEP_SNOW_ALBEDO = 1. - snow_mosaic=0. ! ??? + !snow_mosaic=0. ! ??? ENDIF !7Mar18 - turn off snow mosaic for T<271K to prevent from too warm @@ -1659,14 +1759,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- Set znt for snow from VEGPARM table (snow/ice landuse), except for !-- land-use types with higher roughness (forests, urban). -!5mar12 IF(znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) -! IF(newsn==0. .and. znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) IF(newsn.eq.0. .and. znt.le.0.2 .and. IVGTYP.ne.isice) then if( snhei .le. 2.*ZNT)then + ! shallow snow znt=0.55*znt+0.45*z0tbl(iland) elseif( snhei .gt. 2.*ZNT .and. snhei .le. 4.*ZNT)then znt=0.2*znt+0.8*z0tbl(iland) elseif(snhei > 4.*ZNT) then + ! deep snow znt=z0tbl(iland) endif ENDIF @@ -1685,19 +1785,36 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if( snow_mosaic == 1.) then ALBsn=alb_snow ! ALBsn=max(0.4,alb_snow) + if(newsn > 0. .and. KEEP_SNOW_ALBEDO > 0.9 .and. albsn < 0.4) then + !-- Albedo correction with fresh snow and deep snow pack + !-- will reduce warm bias in western Canada + !-- and US West coast, where max snow albedo is low (0.3-0.5). + !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j + !!!!ALBsn = 0.7 + endif + Emiss= emissn else ALBsn = MAX(keep_snow_albedo*alb_snow, & MIN((alb_snow_free + & (alb_snow - alb_snow_free) * snowfrac), alb_snow)) + if(newsn > 0. .and. KEEP_SNOW_ALBEDO > 0.9 .and. albsn < 0.4) then + !-- Albedo correction with fresh snow and deep snow pack + !-- will reduce warm bias in western Canada + !-- and US West coast, where max snow albedo is low (0.3-0.5). + !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j + !!!!ALBsn = 0.7 + !print *,'NO mosaic ALB increase to 0.7',alb_snow,snhei,snhei_crit,alb,i,j + endif Emiss = MAX(keep_snow_albedo*emissn, & MIN((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) - endif + endif ! snow_mosaic + IF (debug_print ) THEN -! if(i.eq.279.and.j.eq.263) then - print *,'Snow on soil ALBsn,emiss,snow_mosaic',i,j,ALBsn,emiss,snow_mosaic + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'Snow on soil ALBsn,emiss,snow_mosaic',i,j,ALBsn,emiss,snow_mosaic ENDIF !28mar11 if canopy is covered with snow to 95% of its capacity and snow depth is ! higher than patchy snow treshold - then snow albedo is not less than 0.55 @@ -1765,7 +1882,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then print *,'Fractional snow - snowfrac=',snowfrac print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet ENDIF @@ -1789,7 +1905,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ilands = ivgtyp - CALL SOIL(debug_print, & + CALL SOIL(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,gswin, & @@ -1820,7 +1936,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then print *,'Fractional snow - snowfrac=',snowfrac print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet ENDIF @@ -1835,7 +1950,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia runoff1s=0. runoff2s=0. - CALL SICE(debug_print, & + CALL SICE(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & @@ -1866,34 +1981,22 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia enddo endif ! seaice < 0.5 -!return gswnew to incoming solar - IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'gswnew,alb_snow_free,alb',gswnew,alb_snow_free,alb - ENDIF -! gswnew=gswnew/(1.-alb_snow_free) - - IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'Incoming GSWnew snowfrac<1 -',gswnew - ENDIF endif ! snow_mosaic=1. !--- recompute absorbed solar radiation and net radiation !--- for updated value of snow albedo - ALB gswnew=GSWin*(1.-alb) -! print *,'SNOW fraction GSWnew',gswnew,'alb=',alb !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT XINET = EMISS*(GLW-UPFLUX) RNET = GSWnew + XINET IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then -! if(i.eq.271.and.j.eq.242) then + !if (abs(xlat-testptlat).lt.0.1 .and. abs(xlon-testptlon).lt.0.1)then print *,'RNET=',rnet print *,'SNOW - I,J,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB',& i,j,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB + print *,'GSWnew',gswnew,'alb=',alb ENDIF if (SEAICE .LT. 0.5) then @@ -1903,7 +2006,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia else snfr=snowfrac endif - CALL SNOWSOIL (debug_print, & !--- input variables + CALL SNOWSOIL (debug_print,xlat,xlon,testptlat,testptlon, & !--- input variables i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & @@ -1933,7 +2036,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia snfr=snowfrac endif - CALL SNOWSEAICE (debug_print, & + CALL SNOWSEAICE (debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & @@ -1970,27 +2073,24 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif - if(snhei.eq.0.) then -!--- all snow is melted - alb=alb_snow_free - iland=ivgtyp - endif - if (snow_mosaic==1.) then ! May 2014 - now combine snow covered and snow-free land fluxes, soil temp, moist, ! etc. if(SEAICE .LT. 0.5) then ! LAND IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'SOILT snow on land', ktau, i,j,soilt - print *,'SOILT on snow-free land', i,j,soilts - print *,'ts1d,ts1ds',i,j,ts1d,ts1ds + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' xlat, xlon', xlat, xlon + print *,' snowfrac = ',snowfrac + print *,' SOILT snow on land', ktau, i,j,soilt + print *,' SOILT on snow-free land', i,j,soilts + print *,' ts1d,ts1ds',i,j,ts1d,ts1ds print *,' SNOW flux',i,j, snflx print *,' Ground flux on snow-covered land',i,j, s print *,' Ground flux on snow-free land', i,j,ss print *,' CSTS, CST', i,j,csts,cst ENDIF + do k=1,nzs soilm1d(k) = soilm1ds(k)*(1.-snowfrac) + soilm1d(k)*snowfrac ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac @@ -2044,9 +2144,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia infiltr = infiltrs*(1.-snowfrac) + infiltr*snowfrac IF (debug_print ) THEN - print *,' Ground flux combined', i,j, s - print *,'SOILT combined on land', soilt - print *,'TS combined on land', ts1d + !if (abs(xlat-33.35).lt.0.2 .and. & abs(xlon-272.55).lt.0.2)then + print *,' Ground flux combined', xlat,xlon, s + print *,' SOILT combined on land', soilt + print *,' TS combined on land', ts1d ENDIF else ! SEA ICE @@ -2062,23 +2163,18 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia qvg = qvgs*(1.-snowfrac) + qvg*snowfrac qsg = qsgs*(1.-snowfrac) + qsg*snowfrac qcg = qcgs*(1.-snowfrac) + qcg*snowfrac + sublim = eeta*snowfrac eeta = eetas*(1.-snowfrac) + eeta*snowfrac qfx = qfxs*(1.-snowfrac) + qfx*snowfrac hfx = hfxs*(1.-snowfrac) + hfx*snowfrac s = ss*(1.-snowfrac) + s*snowfrac - sublim = eeta prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac fltot = fltots*(1.-snowfrac) + fltot*snowfrac -!alb ALB = MAX(keep_snow_albedo*alb, & MIN((albice + (alb - alb_snow_free) * snowfrac), alb)) - Emiss = MAX(keep_snow_albedo*emissn, & MIN((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) - -! alb=alb_snow_free*(1.-snowfrac) + alb*snowfrac -! emiss=1.*(1.-snowfrac) + emissn*snowfrac runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac smelt = smelt * snowfrac @@ -2091,9 +2187,104 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif endif ! snow_mosaic = 1. -! run-total accumulated snow based on snowfall and snowmelt in [m] + !-- 13 jan 2022 + ! update snow fraction after melting (Swenson, S.C. and Lawrence, 2012, + ! JGR, DOI:10.1029/2012MS000165 + ! + !if (snwe > 0.) then + ! if(smelt > 0.) then + !update snow fraction after melting + !n_melt = 200./max(10.,topo_std) + ! snowfrac = max(0.,snowfrac - (acos(min(1.,(2.*(smelt*delt/snwe) - + ! 1.)))/piconst)**10) + !snowfrac = 1. - (acos(min(1.,(2.*(smelt*delt/snwe) - + !1.)))/piconst)**10. + ! if(i==744.and.j==514 .or. i==924.and.j==568)then + !print *,'smr,n_melt,topo_std', smr,n_melt,topo_std + ! print *,'3 - snowfrac end', i,j,ktau,snowfrac,smelt*delt, snwe, + ! piconst + ! endif + ! endif + !else + ! snowfrac = 0. + !endif + ! + !-- The NY07 parameterization gives more realistic snow cover fraction + ! than SL12 + !-- 13 Jan 2022 + !-- update snow fraction after metlting (Niu, G.-Y., and Yang, Z.-L. 2007, + !JGR, + ! DOI:10.1029/2007JD008674) + ! Limit on znt (<0.25) is needed to avoid very small snow fractions in the + ! forested areas with large roughness + + IF(snhei == 0.) then + !--- all snow is melted + iland=ivgtyp + snowfrac = 0. + alb = alb_snow_free + emiss = emiss_snowfree + ELSE + !-- update snow cover after possible melting + m = 1.0 ! m=1.6 in Niu&Yang, m=1 in CLM + if(isncovr_opt == 1) then + snowfrac=min(1.,snhei/(2.*snhei_crit)) + elseif(isncovr_opt == 2) then + !-- isncovr_opt=2 + snowfrac=min(1.,snhei/(2.*snhei_crit)) + if(ivgtyp == glacier .or. ivgtyp == bare) then + !-- sparsely vegetated or land ice + snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**m)) + !- TEST - replace rhonewsn with 100 in Niu&Yang + !snowfrac2 = tanh( snhei/(2.5 * znt *(rhosn*1.e-2)**m)) + else + !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests + ! on 3-km scale use actual roughness, but not higher than 0.2 m. + ! The factor is 20 for forests (~100/dx = 33.) + snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m)) + !- TEST - replace rhonewsn with 100 in Niu&Yang + !snowfrac2 = tanh( snhei/(2.5 *min(0.15,znt) *(rhosn*1.e-2)**m)) + endif + !-- snow fraction is average between method 1 and 2 + snowfrac = 0.5*(snowfrac+snowfrac2) + else + !-- isncovr_opt=3 + !m = msnf ! vegetation dependent facsnf/msnf from Noah MP + !-- for RRFS a factor 10. was added to 'facsnf' to get reasonal values of + ! snow cover fractions on the 3-km scale. + ! This factor is scale dependent. + snowfrac = tanh( snhei/(10. * facsnf *(rhosn/rhonewsn)**m)) + !- TEST - replace rhonewsn with 100 in Niu&Yang + !snowfrac = tanh( snhei/(2.5* min(0.2,znt) *(rhosn*1.e-2)**m)) + endif - snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio)) + !-- due to steep slopes and blown snow, limit snow fraction in the + !-- mountains ( Swiss weather model) + if(hgt > 2500. .and. ivgtyp == glacier) snowfrac=min(0.85,snowfrac) + + if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + +! run-total accumulated snow based on snowfall and snowmelt in [mm] + + IF (debug_print ) then + !if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print *,'Snowfallac xlat, xlon',xlat,xlon + print *,'newsn,rhonewsn,newsnowratio=',newsn,rhonewsn,newsnowratio + print *,'Time-step newsn depth [m], swe [m]',newsn,newsn*rhonewsn + print *,'Time-step smelt: swe [m]' ,smelt*delt + print *,'Time-step sublim: swe,[kg m-2]',sublim*delt + endif + + !snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio))*1.e3 + snowfallac = snowfallac + max(0.,(newsn*rhonewsn - & ! source of snow (swe) [m] + (smelt+sublim*1.e-3)*delt*newsnowratio) & ! sink: melting and sublimation, (swe) [m] + /rhonewsn)*1.e3 ! snow accumulation in snow depth [mm] + + IF (debug_print ) THEN + !if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print *,'snowfallac,snhei,snwe',snowfallac,snhei,snwe + endif + ENDIF ELSE !--- no snow @@ -2112,7 +2303,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(SEAICE .LT. 0.5) then ! LAND - CALL SOIL(debug_print, & + CALL SOIL(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,GSWin, & @@ -2139,7 +2330,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia alb=albice RNET = GSWnew + XINET - CALL SICE(debug_print, & + CALL SICE(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & @@ -2210,7 +2401,7 @@ END FUNCTION QSN !>\ingroup lsm_ruc_group !> This subroutine calculates energy and moisture budget for vegetated surfaces !! without snow, heat diffusion and Richards eqns in soil. - SUBROUTINE SOIL (debug_print, & + SUBROUTINE SOIL (debug_print,xlat,xlon, & i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,& !--- input variables PRCPMS,RAINF,PATM,QVATM,QCATM, & GLW,GSW,GSWin,EMISS,RNET, & @@ -2292,7 +2483,7 @@ SUBROUTINE SOIL (debug_print, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX + REAL, INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables REAL, & @@ -2547,7 +2738,7 @@ SUBROUTINE SOIL (debug_print, & !--- water, and DRYCAN is the fraction of vegetated area where !--- transpiration may take place. - WETCAN=min(0.25,(CST/SAT)**CN) + WETCAN=min(0.25,max(0.,(CST/SAT))**CN) ! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN @@ -2580,6 +2771,21 @@ SUBROUTINE SOIL (debug_print, & ! print *,'alfa=',alfa, exp(G0_P*psit/r_v/SOILT) ! endif alfa=1. +! field capacity +! 20jun18 - beta in Eq. (5) is called soilres in the code - it limits soil evaporation +! when soil moisture is below field capacity. [Lee and Pielke, 1992] +! This formulation agrees with observations when top layer is < 2 cm thick. +! Soilres = 1 for snow, glaciers and wetland. +! fc=ref - suggested in the paper +! fc=max(qmin,ref*0.5) ! used prior to 20jun18 change +! Switch from ref*0.5 to ref*0.25 will reduce soil resistance, increase direct +! evaporation, effects sparsely vegetated areas--> cooler during the day +! fc=max(qmin,ref*0.25) ! +! For now we'll go back to ref*0.5 +! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct +! evaporation. Therefore , it is replaced with ref*0.7. + !fc=max(qmin,ref*0.5) + !fc=max(qmin,ref*0.7) fc=ref fex_fc=1. if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then @@ -2598,27 +2804,8 @@ SUBROUTINE SOIL (debug_print, & !************************************************************** ! SOILTEMP soilves heat budget and diffusion eqn. in soil !************************************************************** - if(1==2) then - print *,'i,j,iland,isoil ', i,j,iland,isoil - print *,'delt,ktau,conflx,nzs,nddzs,nroot ',delt,ktau,conflx,nzs,nddzs,nroot - print *,'PRCPMS,RAINF ',PRCPMS,RAINF - print *,'PATM,TABS,QVATM,QCATM,EMISS,RNET ',PATM,TABS,QVATM,QCATM,EMISS,RNET - print *,'QKMS,TKMS,PC,rho,vegfrac, lai ',QKMS,TKMS,PC,rho,vegfrac, lai - print *,'thdif ',thdif - print *,'cap ',cap - print *,'drycan,wetcan ',drycan,wetcan - print *,'transum,dew,soilres,alfa ',transum,dew,soilres,alfa - print *,'mavail ',mavail - print *,'dqm,qmin,bclh,zsmain,zshalf,DTDZS',dqm,qmin,bclh,zsmain,zshalf,DTDZS - print *,'xlv,CP,G0_P,cvw,stbolt ',xlv,CP,G0_P,cvw,stbolt - print *,'tso=',tso - print *,'soilt=',soilt - print *,'qvg=',qvg - print *,'qsg=',qsg - print *,'qcg=',qcg - endif ! 1==2 - - CALL SOILTEMP(debug_print, & + + CALL SOILTEMP(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & @@ -2634,15 +2821,6 @@ SUBROUTINE SOIL (debug_print, & !--- output variables tso,soilt,qvg,qsg,qcg,x) -if(1==2) then - print *,'after tso=',tso - print *,'after soilt=',soilt - print *,'after qvg=',qvg - print *,'after qsg=',qsg - print *,'after qcg=',qcg - print *,'after x=',x -endif - !************************************************************************ !--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW @@ -2850,7 +3028,7 @@ END SUBROUTINE SOIL !! on its surface. it solves heat diffusion inside ice and energy !! budget at the surface of ice. It computes skin temperature and !! temerature inside sea ice. - SUBROUTINE SICE ( debug_print, & + SUBROUTINE SICE ( debug_print,xlat,xlon, & i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & !--- input variables PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSW, & EMISS,RNET,QKMS,TKMS,rho,myj, & @@ -2874,7 +3052,7 @@ SUBROUTINE SICE ( debug_print, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX + REAL, INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables REAL, & @@ -3022,7 +3200,7 @@ SUBROUTINE SICE ( debug_print, & tn,aa1,bb,pp,fkq,r210 ENDIF QGOLD=QSG - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) !--- it is saturation over sea ice QVG=QS1 QSG=QS1 @@ -3118,7 +3296,8 @@ END SUBROUTINE SICE !! solves energy and moisture budgets on the surface of snow, and !! on the interface of snow and soil. It computes skin temperature, !! snow temperature, snow depth and snow melt. - SUBROUTINE SNOWSOIL ( debug_print, & + SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & + testptlat,testptlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & !--- input variables meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC, & @@ -3218,7 +3397,8 @@ SUBROUTINE SNOWSOIL ( debug_print, & REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,RHONEWSN, & - SNHEI_CRIT,meltfactor + testptlat,testptlon, & + SNHEI_CRIT,meltfactor,xlat,xlon LOGICAL, INTENT(IN ) :: myj @@ -3530,7 +3710,7 @@ SUBROUTINE SNOWSOIL ( debug_print, & SMELT=0. ! DD1=0. - H=1. + H=MAVAIL ! =1. if snowfrac=1 FQ=QKMS @@ -3546,18 +3726,18 @@ SUBROUTINE SNOWSOIL ( debug_print, & print *,'SNWE after subtracting intercepted snow - snwe=',snwe,vegfrac,cst ENDIF -! SNHEI=SNWE*1.e3/RHOSN +!-- Save SNWE from the previous time step SNWEPR=SNWE ! check if all snow can evaporate during DT BETA=1. - EPDT = EPOT * RAS *DELT*UMVEG + EPDT = EPOT * RAS *DELT IF(EPDT.gt.0. .and. SNWEPR.LE.EPDT) THEN - BETA=SNWEPR/max(1.e-8,EPDT) + BETA=SNWEPR/EPDT SNWE=0. ENDIF - WETCAN=min(0.25,(CST/SAT)**CN) + WETCAN=min(0.25,max(0.,(CST/SAT))**CN) ! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN @@ -3585,11 +3765,11 @@ SUBROUTINE SNOWSOIL ( debug_print, & IF (debug_print ) THEN print *, 'TSO before calling SNOWTEMP: ', tso ENDIF - CALL SNOWTEMP(debug_print, & + CALL SNOWTEMP(debug_print,xlat,xlon,testptlat,testptlon,& !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & - snwe,snwepr,snhei,newsnow,snowfrac, & + snwe,snwepr,snhei,newsnow,snowfrac,snhei_crit, & beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor PRCPMS,RAINF, & PATM,TABS,QVATM,QCATM, & @@ -3781,8 +3961,8 @@ SUBROUTINE SNOWSOIL ( debug_print, & EETA = (EDIR1 + EC1 + ETT1)*1.E3 ENDIF S=SNFLX -! sublim=eeta - sublim=EDIR1*1.E3 + !sublim=EDIR1*1.E3 + sublim=Q1*1.E3 !kg m-2 s-1 ! Energy budget FLTOT=RNET-HFT-XLVm*EETA-S-SNOH-x IF (debug_print ) THEN @@ -3807,7 +3987,7 @@ END SUBROUTINE SNOWSOIL !! its surface. It solves energy budget on the snow interface with !! atmosphere and snow interface with ice. It calculates skin !! temperature, snow and ice temperatures, snow depth and snow melt. - SUBROUTINE SNOWSEAICE( debug_print, & + SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,snowfrac, & @@ -3840,7 +4020,7 @@ SUBROUTINE SNOWSEAICE( debug_print, & REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,RHONEWSN, & - meltfactor, snhei_crit + meltfactor,snhei_crit,xlat,xlon real :: rhonewcsn LOGICAL, INTENT(IN ) :: myj @@ -3944,6 +4124,7 @@ SUBROUTINE SNOWSEAICE( debug_print, & REAL :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr integer :: nmelt + REAL :: keff, fact !----------------------------------------------------------------- XLMELT=3.35E+5 @@ -3951,6 +4132,12 @@ SUBROUTINE SNOWSEAICE( debug_print, & XLVm=XLV+XLMELT ! STBOLT=5.670151E-8 + !-- options for snow conductivity: + !-- 1 - constant + !-- opt 2 - Sturm et al., 1997 + !isncond_opt = 2 + keff = 0.265 + !--- SNOW flag -- ISICE ! ILAND=isice @@ -3990,7 +4177,45 @@ SUBROUTINE SNOWSEAICE( debug_print, & RHOCSN=2090.* RHOSN !18apr08 - add rhonewcsn RHOnewCSN=2090.* RHOnewSN - THDIFSN = 0.265/RHOCSN + + if(isncond_opt == 1) then + !if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + endif + else + !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) + !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + fact = 1. + if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then + keff = 0.023 + 0.234 * rhosn * 1.e-3 + !-- fact is added by tgs based on 4 Jan 2017 testing + fact = 5. + else + keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 + fact = 2. + endif + !fact = 1. + + !if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + thdifsn = keff/rhocsn * fact + endif + endif + RAS=RHO*1.E-3 SOILTFRAC=SOILT @@ -4215,14 +4440,17 @@ SUBROUTINE SNOWSEAICE( debug_print, & print *,'TABS,QVATM,TN,QVG=',TABS,QVATM,TN,QVG ENDIF - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) !--- it is saturation over snow QVG=QS1 QSG=QS1 QCG=0. -!--- SOILT - skin temperature +!--- SOILT - skin temperature of snow on ice SOILT=TS1 + if(nmelt==1 .and. snowfrac==1) then + soilt = min(273.15,soilt) + endif IF (debug_print ) THEN print *,' AFTER VILKA-SNOW on SEAICE' @@ -4280,10 +4508,10 @@ SUBROUTINE SNOWSEAICE( debug_print, & !--- IF SOILT > 273.15 F then melting of snow can happen ! IF(SOILT.GT.273.15.AND.SNWE.GT.0.) THEN ! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0..AND.SNHEI.GT.0.) THEN + !IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0..AND.SNHEI.GT.0.) THEN + IF(SOILT.GT.273.15.AND.BETA.EQ.1..AND.SNHEI.GT.0.) THEN ! nmelt = 1 -! soiltfrac=273.15 soiltfrac=snowfrac*273.15+(1.-snowfrac)*min(271.4,SOILT) QSG= QSN(soiltfrac,TBQ)/PP @@ -4392,11 +4620,13 @@ SUBROUTINE SNOWSEAICE( debug_print, & !--- If there is no snow melting then just evaporation !--- or condensation changes SNWE ELSE - if(snhei.ne.0.) then + if(snhei.ne.0..and. beta == 1.) then EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & BETA*EPOT*RAS*DELT)) ! BETA*EPOT*RAS*DELT*snowfrac)) + else + snwe = 0. endif ENDIF @@ -4424,7 +4654,44 @@ SUBROUTINE SNOWSEAICE( debug_print, & !13mar18 rhosn=MIN(MAX(76.9,XSN),500.) RHOCSN=2090.* RHOSN - thdifsn = 0.265/RHOCSN + if(isncond_opt == 1) then + ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + endif + else + !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) + !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + fact = 1. + if(rhosn < 156. .or. (newsn > 0. .and. rhonewsn < 156.)) then + keff = 0.023 + 0.234 * rhosn * 1.e-3 + !-- fact is added by tgs based on 4 Jan 2017 testing + fact = 5. + else + keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 + fact = 2. + endif + !fact = 1. + + !if(newsn <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + thdifsn = keff/rhocsn * fact + endif + endif + endif endif @@ -4562,7 +4829,7 @@ END SUBROUTINE SNOWSEAICE !>\ingroup lsm_ruc_group !> This subroutine solves energy budget equation and heat diffusion !! equation. - SUBROUTINE SOILTEMP( debug_print, & + SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,TABS,QVATM,QCATM, & @@ -4632,7 +4899,7 @@ SUBROUTINE SOILTEMP( debug_print, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF + REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon REAL, INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables REAL, & @@ -4787,7 +5054,7 @@ SUBROUTINE SOILTEMP( debug_print, & ! AA1=AA*alfa+CC PP=PATM*1.E3 AA1=AA1/PP - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) TQ2=QVATM TX2=TQ2*(1.-H) Q1=TX2+H*QS1 @@ -4810,7 +5077,7 @@ SUBROUTINE SOILTEMP( debug_print, & 100 BB=BB-AA*TX2 AA=(AA*H+CC)/PP - CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) Q1=TX2+H*QS1 IF (debug_print ) THEN ! if(i.eq.279.and.j.eq.263) then @@ -4885,10 +5152,10 @@ END SUBROUTINE SOILTEMP !>\ingroup lsm_ruc_group !> This subroutine solves energy bugdget equation and heat diffusion !! equation to obtain snow and soil temperatures. - SUBROUTINE SNOWTEMP( debug_print, & - i,j,iland,isoil, & !--- input variables + SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & + testptlat,testptlon,i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & - snwe,snwepr,snhei,newsnow,snowfrac, & + snwe,snwepr,snhei,newsnow,snowfrac,snhei_crit, & beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor PRCPMS,RAINF, & PATM,TABS,QVATM,QCATM, & @@ -4963,7 +5230,8 @@ SUBROUTINE SNOWTEMP( debug_print, & REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & - rhonewsn,meltfactor + testptlat,testptlon , & + rhonewsn,meltfactor,xlat,xlon,snhei_crit real :: rhonewcsn !--- 3-D Atmospheric variables @@ -5071,13 +5339,19 @@ SUBROUTINE SNOWTEMP( debug_print, & qfx, & hfx - REAL :: RNET,rsmfrac,soiltfrac,hsn,rr - integer :: nmelt, iter + REAL :: RNET,rsmfrac,soiltfrac,hsn,rr,keff,fact + integer :: nmelt, iter !----------------------------------------------------------------- iter = 0 + !-- options for snow conductivity: + !-- 1 - constant + !-- opt 2 - Sturm et al., 1997 + !isncond_opt = 1 + keff = 0.265 + do k=1,nzs transp (k)=0. cotso (k)=0. @@ -5091,7 +5365,57 @@ SUBROUTINE SNOWTEMP( debug_print, & RHOCSN=2090.* RHOSN !18apr08 - add rhonewcsn RHOnewCSN=2090.* RHOnewSN - THDIFSN = 0.265/RHOCSN + if(isncond_opt == 1) then + ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + endif + else + !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) + !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + fact = 1. + if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then + keff = 0.023 + 0.234 * rhosn * 1.e-3 + !-- fact is added by tgs based on 4 Jan 2017 testing + fact = 5. + else + keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 + fact = 2. + if(debug_print) then + print *,'SnowTemp xlat,xlon,rhosn,keff', xlat,xlon,rhosn,keff,keff/rhocsn*fact + print *,'SNOWTEMP - 0.265/rhocsn',0.265/rhocsn + endif + endif + if ( debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then + print *,'SNOWTEMP - xlat,xlon,newsnow,rhonewsn,rhosn,fact,keff',xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff + endif + + !fact = 1. + + ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + thdifsn = keff/rhocsn * fact + endif + if (debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then + print *,'SNOWTEMP - thdifsn',xlat,xlon,thdifsn + print *,'SNOWTEMP - 0.265/rhocsn',0.265/rhocsn + endif + + endif + RAS=RHO*1.E-3 SOILTFRAC=SOILT @@ -5159,8 +5483,8 @@ SUBROUTINE SNOWTEMP( debug_print, & cotsn=cotso(NZS) rhtsn=rhtso(NZS) !*** Average temperature of snow pack (C) - tsnav=0.5*(soilt+tso(1)) & - -273.15 + tsnav=min(0.,0.5*(soilt+tso(1)) & + -273.15) else !-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth @@ -5188,9 +5512,9 @@ SUBROUTINE SNOWTEMP( debug_print, & cotsn=x1sn/denomsn rhtsn=(ftsnow+X1SN1*rhtso(NZS))/denomsn !*** Average temperature of snow pack (C) - tsnav=0.5/snhei*((soilt+soilt1)*deltsn & + tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15 + -273.15) endif ENDIF IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then @@ -5211,8 +5535,8 @@ SUBROUTINE SNOWTEMP( debug_print, & denom = 1. + x1sn + x2 - x2*cotso(nzs-2) cotso(nzs1) = x1sn/denom rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom - tsnav=0.5*(soilt+tso(1)) & - -273.15 + tsnav=min(0.,0.5*(soilt+tso(1)) & + -273.15) cotso(NZS)=cotso(nzs1) rhtso(NZS)=rhtso(nzs1) cotsn=cotso(NZS) @@ -5229,7 +5553,7 @@ SUBROUTINE SNOWTEMP( debug_print, & ETT1=0. EPOT=-QKMS*(QVATM-QGOLD) RHCS=CAP(1) - H=1. + H=MAVAIL !1. TRANS=TRANSUM*DRYCAN/ZSHALF(NROOT+1) CAN=WETCAN+TRANS UMVEG=1.-VEGFRAC @@ -5318,12 +5642,19 @@ SUBROUTINE SNOWTEMP( debug_print, & AA1=AA1/PP BB=BB-SNOH/TDENOM - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + IF (debug_print ) THEN + if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'1-', i,rnet,tabs,tn,aa1,bb,pp,ktau,newsnow,snwepr,snwe,snhei,snowfrac,soilt,soilt1,tso,rhosn + print *,'2-', i,tdenom,fkq,vegfrac,can,R210,D10,R21,D9sn,D1sn,R22sn,R7,prcpms + endif + ENDIF + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) TQ2=QVATM TX2=TQ2*(1.-H) Q1=TX2+H*QS1 IF (debug_print ) THEN - print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1,xlat,xlon ENDIF IF(Q1.LT.QS1) GOTO 100 !--- if no saturation - goto 100 @@ -5337,9 +5668,10 @@ SUBROUTINE SNOWTEMP( debug_print, & GOTO 200 100 BB=BB-AA*TX2 AA=(AA*H+CC)/PP - CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) Q1=TX2+H*QS1 IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'VILKA2 - TS1,QS1,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 ENDIF IF(Q1.GT.QS1) GOTO 90 @@ -5364,26 +5696,37 @@ SUBROUTINE SNOWTEMP( debug_print, & iter=1 ! goto 2211 endif -endif ! 1==2 IF (debug_print ) THEN if(iter==1) then print *,'SNOW - QVATM,QVG,QSG,QCG,TS1',QVATM,QVG,QSG,QCG,TS1 endif ENDIF +endif ! 1==2 !--- SOILT - skin temperature SOILT=TS1 + if(nmelt==1 .and. snowfrac==1 .and. snwe > 0. .and. SOILT > 273.15) then + !--7feb22 on the second iteration when SNOH is known and snwe > 0. after melting, + !-- check if the snow skin temperature is =<273.15K + !-- when a grid cell is fully covered with snow (snowfrac=1) + !-- or with partial snow cover and snow_mosaic=1 (snowfrac=1). + if (debug_print ) then + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'soilt is too high =',soilt,xlat,xlon + soilt = min(273.15,soilt) + endif + endif + IF (debug_print ) THEN -! IF(i.eq.266.and.j.eq.447) then - print *,'snwe,snhei,soilt,soilt1,tso',i,j,snwe,snhei,soilt,soilt1,tso -! endif + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'snwe,snwepr,snhei,snowfr,soilt,soilt1,tso',i,j,snwe,snwepr,snhei,snowfrac,soilt,soilt1,tso ENDIF ! Solution for temperature at 7.5 cm depth and snow-soil interface IF(SNHEI.GE.SNTH) THEN if(snhei.gt.DELTSN+SNTH) then !-- 2-layer snow model - SOILT1=min(273.15,rhtsn+cotsn*SOILT) + SOILT1=rhtsn+cotsn*SOILT TSO(1)=rhtso(NZS)+cotso(NZS)*SOILT1 tsob=soilt1 else @@ -5406,6 +5749,12 @@ SUBROUTINE SNOWTEMP( debug_print, & tsob=TSO(1) !new tsob=tso(2) ENDIF + if(nmelt==1.and.snowfrac==1) then + !-- second iteration with full snow cover + SOILT1= min(273.15,SOILT1) + TSO(1)= min(273.15,TSO(1)) + tsob = min(273.15,tsob) + endif !---- Final solution for TSO IF (SNHEI > 0. .and. SNHEI < SNTH) THEN @@ -5432,16 +5781,18 @@ SUBROUTINE SNOWTEMP( debug_print, & IF (debug_print ) THEN -! IF(i.eq.266.and.j.eq.447) then - print *,'SOILT,SOILT1,tso,TSOB,QSG',i,j,SOILT,SOILT1,tso,TSOB,QSG,'nmelt=',nmelt + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'Final SOILT,SOILT1,tso,TSOB,QSG',xlat,xlon,SOILT,SOILT1,tso,TSOB,QSG,'nmelt=',nmelt + print *,'SNWEPR-BETA*EPOT*RAS*DELT',SNWEPR-BETA*EPOT*RAS*DELT,beta,snwepr,epot ENDIF if(nmelt.eq.1) go to 220 !--- IF SOILT > 273.15 F then melting of snow can happen ! IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN -! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0.AND.SNHEI.GT.0.) THEN +! if all snow can evaporate (beta<1), then there is nothing to melt + IF(SOILT.GT.273.15.AND.BETA.EQ.1.AND.SNHEI.GT.0.) THEN + !-- snow sublimation and melting nmelt = 1 soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT QSG=min(QSG, QSN(soiltfrac,TBQ)/PP) @@ -5453,6 +5804,7 @@ SUBROUTINE SNOWTEMP( debug_print, & EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS + IF (Q1.LE.0..or.iter==1) THEN ! --- condensation DEW=-EPOT @@ -5495,7 +5847,7 @@ SUBROUTINE SNOWTEMP( debug_print, & ENDIF ! - X= (R21+D9SN*R22SN)*(soiltfrac-TN) + & + X= (R21+D9SN*R22SN)*(soiltfrac-TN) + & XLVM*R210*(QVG-QGOLD) IF (debug_print ) THEN print *,'SNOWTEMP storage ',i,j,x @@ -5511,69 +5863,110 @@ SUBROUTINE SNOWTEMP( debug_print, & !-- SMELT is speed of melting in M/S SMELT= SNOH /XLMELT*1.E-3 IF (debug_print ) THEN - print *,'1- SMELT',i,j,smelt - ENDIF - SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) - IF (debug_print ) THEN - print *,'2- SMELT',i,j,smelt + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'1- SMELT',smelt,snoh,xlat,xlon ENDIF - SMELT=AMAX1(0.,SMELT) + + IF(EPOT.gt.0. .and. SNWEPR.LE.EPOT*RAS*DELT) THEN +!-- all snow can evaporate + BETA=SNWEPR/(EPOT*RAS*DELT) + SMELT=AMAX1(0.,AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS)) + SNWE=0. + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'2- SMELT',xlat,xlon,snwe,smelt,rhonewsn,xlat,xlon + ENDIF + goto 88 + ENDIF !18apr08 - Egglston limit -! SMELT= amin1 (smelt, 5.6E-7*meltfactor*max(1.,(soilt-273.15))) + !-- 22apr22 Do not limit snow melting for hail (rhonewsn > 450), or dense snow + !-- (rhosn > 350.) with very warm surface temperatures (>10C) + if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*max(1.,(soilt-273.15))) -! SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*min(2.,max(0.001,(tabs-273.15))) ! SnowMIP - IF (debug_print ) THEN - print *,'3- SMELT',i,j,smelt - ENDIF +! SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*min(2.,max(0.001,(tabs-273.15))) ! SnowMIP + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'3- SMELT',xlat,xlon,smelt,rhosn,rhonewsn,xlat,xlon + ENDIF + endif ! rr - potential melting rr=max(0.,SNWEPR/delt-BETA*EPOT*RAS) - SMELT=min(SMELT,rr) - IF (debug_print ) THEN - print *,'4- SMELT i,j,smelt,rr',i,j,smelt,rr - ENDIF + if(smelt > rr) then + SMELT = min(SMELT,rr) + SNWE = 0. + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'4- SMELT i,j,smelt,rr',xlat,xlon,smelt,rr + ENDIF + endif + 88 continue SNOHGNEW=SMELT*XLMELT*1.E3 SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) SNOH=SNOHGNEW - IF (debug_print ) THEN - print *,'SNOH,SNODIF',SNOH,SNODIF - ENDIF + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'SNOH,SNODIF',SNOH,SNODIF + print *,' xlat, xlon', xlat, xlon + ENDIF + IF( smelt > 0.) then !*** From Koren et al. (1999) 13% of snow melt stays in the snow pack rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) - if(snhei > 0.01) then + if(snhei > 0.01 .and. rhosn < 350.) then rsm=min(snwe,rsmfrac*smelt*delt) else -! do not keep melted water if snow depth is less that 1 cm + ! do not keep melted water if snow depth is less that 1 cm + ! or if snow is dense rsm=0. endif !18apr08 rsm is part of melted water that stays in snow as liquid - SMELT=max(0.,SMELT-rsm/delt) - IF (debug_print ) THEN - print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & + if(rsm > 0.) then + SMELT=max(0.,SMELT-rsm/delt) + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & i,j,smelt,rsm,snwepr,rsmfrac - ENDIF + print *,' xlat, xlon', xlat, xlon + ENDIF + endif ! rsm + + ENDIF ! smelt > 0 !-- update of liquid equivalent of snow depth !-- due to evaporation and snow melt - SNWE = AMAX1(0.,(SNWEPR- & - (SMELT+BETA*EPOT*RAS)*DELT & -! (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & -! (SMELT+BETA*EPOT*RAS*UMVEG)*DELT & + if(snwe > 0.) then + SNWE = AMAX1(0.,(SNWEPR- & + (SMELT+BETA*EPOT*RAS)*DELT & ) ) -!--- If there is no snow melting then just evaporation -!--- or condensation cxhanges SNWE + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' Snow is melting and sublimating, snwe', xlat, xlon, SNWE + endif + else + !-- all snow is sublimated or melted + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' all snwe is sublimated or melted', xlat, xlon, SNWE + endif + endif ELSE - if(snhei.ne.0.) then + !-- NO MELTING, only sublimation + !--- If there is no snow melting then just evaporation + !--- or condensation changes SNWE + if(snhei.ne.0..and. beta == 1.) then EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & BETA*EPOT*RAS*DELT)) -! BETA*EPOT*RAS*DELT*snowfrac)) + else + !-- all snow is sublibated + snwe = 0. endif ENDIF + !18apr08 - if snow melt occurred then go into iteration for energy budget ! solution if(nmelt.eq.1) goto 212 ! second interation @@ -5596,7 +5989,57 @@ SUBROUTINE SNOWTEMP( debug_print, & ! rhosn=MIN(MAX(76.9,XSN),500.) RHOCSN=2090.* RHOSN - thdifsn = 0.265/RHOCSN + if(isncond_opt == 1) then + !if(newsnow<= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + endif + else + !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) + !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + fact = 1. + if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then + keff = 0.023 + 0.234 * rhosn * 1.e-3 + !-- fact is added by tgs based on 4 Jan 2017 testing + fact = 5. + else + keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 + fact = 2. + if(debug_print) then + print *,'End SNOWTEMP - xlat,xlon,rhosn,keff',xlat,xlon,rhosn,keff + print *,'End SNOWTEMP - 0.265/rhocsn',0.265/rhocsn + endif + endif + if (debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then + print *,'END SNOWTEMP - newsnow, rhonewsn,rhosn,fact,keff', & + xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff,keff/rhocsn*fact + endif + + !fact = 1. + + ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + thdifsn = keff/rhocsn * fact + endif + + endif + if (debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then + print *,'END SNOWTEMP - thdifsn',xlat,xlon,thdifsn + print *,'END SNOWTEMP - 0.265/rhocsn',0.265/rhocsn + endif endif endif @@ -5616,33 +6059,48 @@ SUBROUTINE SNOWTEMP( debug_print, & S=D9*(tso(1)-tso(2)) ENDIF + !-- Update snow depth after melting at the interface with the atmosphere SNHEI=SNWE *1.E3 / RHOSN + !-- If ground surface temperature -!-- is above freezing snow can melt from the bottom. The following +!-- is above freezing snow can melt from the bottom at the interface with soild. The following !-- piece of code will check if bottom melting is possible. + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'snhei,snwe,rhosn,snowfr',snhei,snwe,rhosn,snowfrac,xlat,xlon + endif + IF(TSO(1).GT.273.15 .and. snhei > 0.) THEN +!-- melting at the soil/snow interface if (snhei.GT.deltsn+snth) then hsn = snhei - deltsn - IF (debug_print ) THEN - print*,'2 layer snow - snhei,hsn',snhei,hsn - ENDIF + IF (debug_print ) THEN + print*,'2 layer snow - snhei,hsn',snhei,hsn + ENDIF else - IF (debug_print ) THEN - print*,'1 layer snow or blended - snhei',snhei - ENDIF + IF (debug_print ) THEN + print*,'1 layer snow or blended - snhei',snhei + ENDIF hsn = snhei endif soiltfrac=snowfrac*273.15+(1.-snowfrac)*TSO(1) - SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & + SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & RHOCSN*0.5*hsn) / DELT - SNOHG=AMAX1(0.,SNOHG) - SNODIF=0. - SMELTG=SNOHG/XLMELT*1.E-3 + SNOHG=AMAX1(0.,SNOHG) + SNODIF=0. + SMELTG=SNOHG/XLMELT*1.E-3 + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' SMELTG =',smeltg,xlat,xlon + endif ! Egglston - empirical limit on snow melt from the bottom of snow pack - SMELTG=AMIN1(SMELTG, 5.8e-9) + !9jun22-- the next line excludeis cases of summer hail from snowmelt limiting + if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then + SMELT=AMIN1(SMELTG, 5.8e-9) + endif ! rr - potential melting rr=SNWE/delt @@ -5651,41 +6109,42 @@ SUBROUTINE SNOWTEMP( debug_print, & SNOHGNEW=SMELTG*XLMELT*1.e3 SNODIF=AMAX1(0.,(SNOHG-SNOHGNEW)) IF (debug_print ) THEN -! if(i.eq.266.and.j.eq.447) then - print *,'TSO(1),soiltfrac,smeltg,SNODIF',TSO(1),soiltfrac,smeltg,SNODIF + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',TSO(1),soiltfrac,snowfrac,smeltg,SNODIF + print *,' xlat, xlon', xlat, xlon ENDIF -! snwe=max(0.,snwe-smeltg*delt*snowfrac) snwe=max(0.,snwe-smeltg*delt) SNHEI=SNWE *1.E3 / RHOSN + !-- add up all snow melt + SMELT = SMELT + SMELTG if(snhei > 0.) TSO(1) = soiltfrac + IF (debug_print ) THEN -! if(i.eq.266.and.j.eq.447) then + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'Melt from the bottom snwe,snhei',snwe,snhei + print *,' xlat, xlon', xlat, xlon + print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',TSO(1),soiltfrac,snowfrac,smeltg,SNODIF + print *,'Melt from the bottom snwe,snhei,snoh',snwe,snhei,snoh + print *,' Final TSO ',tso if (snhei==0.) & print *,'Snow is all melted on the warm ground' ENDIF - ENDIF - IF (debug_print ) THEN - print *,'SNHEI,SNOH',i,j,SNHEI,SNOH - ENDIF -! & + ENDIF ! melt on snow/soil interface + snweprint=snwe snheiprint=snweprint*1.E3 / RHOSN - IF (debug_print ) THEN -print *, 'snweprint : ',snweprint -print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB - ENDIF - - X= (R21+D9SN*R22SN)*(soilt-TN) + & + X= (R21+D9SN*R22SN)*(soilt-TN) + & XLVM*R210*(QSG-QGOLD) IF (debug_print ) THEN - print *,'SNOWTEMP storage ',i,j,x + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'end SNOWTEMP storage ',xlat,xlon,x print *,'R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim', & R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim + print *,'snwe, snhei ',snwe,snhei ENDIF X=X & @@ -5700,14 +6159,14 @@ SUBROUTINE SNOWTEMP( debug_print, & IF(SNHEI.GT.0.) THEN if(ilnb.gt.1) then - tsnav=0.5/snhei*((soilt+soilt1)*deltsn & - +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15 + tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & + +(soilt1+tso(1))*(SNHEI-DELTSN)) & + -273.15) else - tsnav=0.5*(soilt+tso(1)) - 273.15 + tsnav=min(0.,0.5*(soilt+tso(1)) - 273.15) endif ELSE - tsnav= soilt - 273.15 + tsnav= min(0.,soilt - 273.15) ENDIF !------------------------------------------------------------------------ @@ -5913,7 +6372,7 @@ SUBROUTINE SOILMOIST ( debug_print, & ! TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT - TOTLIQ=PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT + TOTLIQ=PRCP-DRIP/DELT-(1.-VEGFRAC)*DEW*RAS-SMELT IF (debug_print ) THEN print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT @@ -6506,13 +6965,13 @@ END SUBROUTINE TRANSF !> This subroutine finds the solution of energy budget at the surface !! from the pre-computed table of saturated water vapor mixing ratio !! and estimated surface temperature. - SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil) + SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) !-------------------------------------------------------------- !--- VILKA finds the solution of energy budget at the surface !--- using table T,QS computed from Clausius-Klapeiron !-------------------------------------------------------------- REAL, DIMENSION(1:5001), INTENT(IN ) :: TT - REAL, INTENT(IN ) :: TN,D1,D2,PP + REAL, INTENT(IN ) :: TN,D1,D2,PP,xlat,xlon INTEGER, INTENT(IN ) :: NSTEP,ii,j,iland,isoil REAL, INTENT(OUT ) :: QS, TS @@ -6535,12 +6994,12 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil) IF(I1.NE.I) GOTO 10 TS=T1-.05*RN QS=(TT(I)+(TT(I)-TT(I+1))*RN)/PP -! print *,'in VILKA - TS,QS',ts,qs GOTO 20 ! 1 PRINT *,'Crash in surface energy budget - STOP' 1 PRINT *,' AVOST IN VILKA Table index= ',I ! PRINT *,TN,D1,D2,PP,NSTEP,I,TT(i),ii,j,iland,isoil print *,'I,J=',ii,j,'LU_index = ',iland, 'Psfc[hPa] = ',pp, 'Tsfc = ',tn + print *,'AVOST point at xlat/xlon=',xlat,xlon ! CALL wrf_error_fatal (' Crash in surface energy budget ' ) 20 CONTINUE !----------------------------------------------------------------------- @@ -6551,12 +7010,12 @@ END SUBROUTINE VILKA !! This subroutine computes effective land and soil parameters in the !! grid cell from the weighted contribution of soil and land categories !! represented in the grid cell. - SUBROUTINE SOILVEGIN ( debug_print, & - soilfrac,nscat,shdmin, shdmax, & - mosaic_lu, mosaic_soil, & - NLCAT,IVGTYP,ISLTYP,iswater,MYJ, & - IFOREST,lufrac,vegfrac,EMISS,PC,ZNT,LAI,RDLAI2D,& - QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,I,J,& + SUBROUTINE SOILVEGIN ( debug_print, & + soilfrac,nscat,shdmin, shdmax, & + NLCAT,IVGTYP,ISLTYP,iswater,MYJ, & + IFOREST,lufrac,vegfrac,EMISS,PC, & + MSNF,FACSNF,ZNT,LAI,RDLAI2D, & + QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,I,J, & errmsg, errflg) !************************************************************************ @@ -6790,7 +7249,6 @@ SUBROUTINE SOILVEGIN ( debug_print, & INTEGER :: & IVGTYP, & ISLTYP - INTEGER, INTENT(IN ) :: mosaic_lu, mosaic_soil LOGICAL, INTENT(IN ) :: myj REAL, INTENT(IN ) :: SHDMAX @@ -6800,7 +7258,9 @@ SUBROUTINE SOILVEGIN ( debug_print, & REAL, DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC REAL , & - INTENT ( OUT) :: pc + INTENT ( OUT) :: pc, & + msnf, & + facsnf REAL , & INTENT (INOUT ) :: emiss, & @@ -6898,6 +7358,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & ZNT = 0. ZNT1 = 0. PC = 0. + MSNF = 0. + FACSNF= 0. if(.not.rdlai2d) LAI = 0. AREA = 0. !-- mosaic approach to landuse in the grid box @@ -6914,6 +7376,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & ZNT1 = ZNT1 + lufrac(k)*ZNTtoday(K) if(.not.rdlai2d) LAI = LAI + LAItoday(K)*lufrac(k) PC = PC + PCTBL(K)*lufrac(k) + MSNF = MSNF + MFSNO(K)*lufrac(k) + FACSNF= FACSNF + SNCOVFAC(K)*lufrac(k) enddo if (area.gt.1.) area=1. @@ -6933,6 +7397,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & ZNT = LB/EXP(SQRT(1./ZNT)) if(.not.rdlai2d) LAI = LAI/AREA PC = PC /AREA + MSNF = MSNF /AREA + FACSNF= FACSNF /AREA IF (debug_print ) THEN print *,'mosaic=',j,ivgtyp,nlcat,(lufrac(k),k=1,nlcat),EMISS,ZNT,ZNT1,LAI,PC @@ -6943,17 +7409,19 @@ SUBROUTINE SOILVEGIN ( debug_print, & EMISS = LEMITBL(IVGTYP) ZNT = ZNTtoday(IVGTYP) PC = PCTBL(IVGTYP) + MSNF = MFSNO(IVGTYP) + FACSNF= SNCOVFAC(IVGTYP) if(.not.rdlai2d) LAI = LAItoday(IVGTYP) endif ! parameters from SOILPARM.TBL RHOCS = 0. BCLH = 0. - DQM = 1. + DQM = 0. KSAT = 0. PSIS = 0. QMIN = 0. - REF = 1. + REF = 0. WILT = 0. QWRTZ = 0. AREA = 0. @@ -7301,6 +7769,8 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) READ (19,*) READ (19,*)BARE READ (19,*) + READ (19,*)GLACIER + READ (19,*) READ (19,*)NATURAL READ (19,*) READ (19,*)CROP diff --git a/physics/namelist_soilveg_ruc.F90 b/physics/namelist_soilveg_ruc.F90 index 1e05122c4..2270d35eb 100644 --- a/physics/namelist_soilveg_ruc.F90 +++ b/physics/namelist_soilveg_ruc.F90 @@ -26,12 +26,15 @@ module namelist_soilveg_ruc REAL SNUPTBL(MAX_VEGTYP) REAL LAITBL(MAX_VEGTYP) REAL MAXALB(MAX_VEGTYP) + REAL MFSNO(MAX_VEGTYP) + REAL SNCOVFAC(MAX_VEGTYP) LOGICAL LPARAM REAL TOPT_DATA REAL CMCMAX_DATA REAL CFACTR_DATA REAL RSMAX_DATA INTEGER BARE + INTEGER GLACIER INTEGER NATURAL INTEGER CROP INTEGER URBAN diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index c03e6fc5f..77e4f9ac5 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -30,8 +30,9 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) NAMELIST /SOIL_VEG_RUC/ SLOPE_DATA, ALBTBL, Z0TBL, LEMITBL, & & PCTBL, SHDTBL, & & IFORTBL, RSTBL, RGLTBL, HSTBL, SNUPTBL, LAITBL, MAXALB, & + & MFSNO, SNCOVFAC, & & LPARAM, TOPT_DATA, CMCMAX_DATA, CFACTR_DATA, & - & RSMAX_DATA, BARE, NATURAL, CROP, URBAN, & + & RSMAX_DATA, BARE, GLACIER, NATURAL, CROP, URBAN, & & DEFINED_VEG, DEFINED_SOIL, DEFINED_SLOPE, & & BB, DRYSMC, HC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, & & WLTSMC, QTZ, mosaic_soil, mosaic_lu, & @@ -200,15 +201,41 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) & 70., 55., 60., 75., 70., 0., 0., 0., & & 0., 0., 0., 0., 0., 0./) + mfsno = & !< modified for RRFS Noah_MP snowmelt curve parameter () + & (/ 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, & + & 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, & + & 3.00, 3.00, 2.00, 2.00, 2.00, 2.00, & + & 2.00, 2.00, 0.00, 0.00, 0.00, 0.00, & +! & 3.00, 3.00, 2.00, 3.00, 3.00, 3.00, & +! & 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) + +!-- Noah MP snowmelt curve values +! & (/ 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, & +! & 2.00, 2.00, 2.00, 2.00, 3.00, 3.00, & +! & 4.00, 4.00, 2.50, 3.00, 3.00, 3.50, & +! & 3.50, 3.50, 0.00, 0.00, 0.00, 0.00, & +! & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) + + sncovfac = & !< Noah_MP snow cover factor (m), first 5 categories are modified for RRFS + & (/ 0.030, 0.030, 0.030, 0.030, 0.030, & + !& (/ 0.008, 0.008, 0.008, 0.008, 0.008, & + & 0.016, 0.016, 0.020, 0.020, 0.020, & + & 0.020, 0.014, 0.042, 0.026, 0.030, & + & 0.016, 0.030, 0.030, 0.030, 0.030, & + & 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000 /) + natural = 10 - bare = 16 crop = 12 urban = 13 + glacier = 15 + bare = 16 endif ! end if veg table ! - set mosaic_lu=1 when info for fractional landuse is available - mosaic_lu = 0 + mosaic_lu = 1 topt_data =298.0 cmcmax_data =0.2e-3 @@ -338,12 +365,14 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) REFSMC =(/0.174, 0.179, 0.249, 0.369, 0.369, 0.314, & + !-- test to reduce moist bias + !REFSMC =(/0.220, 0.205, 0.312, 0.375, 0.369, 0.339, & & 0.299, 0.357, 0.391, 0.316, 0.409, 0.400, & & 0.314, 1.000, 0.100, 0.249, 0.454, 0.170, & & 0.236, 0.000, 0.000, 0.000, 0.000, 0.000, & & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) - SATPSI =(/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, & + SATPSI =(/0.121, 0.150, 0.218, 0.786, 0.786, 0.478, & & 0.299, 0.356, 0.630, 0.153, 0.490, 0.405, & & 0.478, 0.000, 0.121, 0.218, 0.468, 0.069, & & 0.069, 0.00, 0.00, 0.00, 0.00, 0.00, & @@ -413,7 +442,7 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) END DO ! - set mosaic_soil=1 when info for fractional landuse is available - mosaic_soil = 0 + mosaic_soil = 1 ! PT 5/18/2015 - changed to FALSE to match atm_namelist setting ! PT LPARAM is not used anywhere From b6c327bd8748463c97a50c2d8407bbfad98409c5 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 8 Mar 2023 21:51:55 +0000 Subject: [PATCH 02/28] Update parameters for RUC LSM. --- physics/set_soilveg_ruc.F90 | 35 +++-------------------------------- 1 file changed, 3 insertions(+), 32 deletions(-) diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index 77e4f9ac5..f29726645 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -30,9 +30,8 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) NAMELIST /SOIL_VEG_RUC/ SLOPE_DATA, ALBTBL, Z0TBL, LEMITBL, & & PCTBL, SHDTBL, & & IFORTBL, RSTBL, RGLTBL, HSTBL, SNUPTBL, LAITBL, MAXALB, & - & MFSNO, SNCOVFAC, & & LPARAM, TOPT_DATA, CMCMAX_DATA, CFACTR_DATA, & - & RSMAX_DATA, BARE, GLACIER, NATURAL, CROP, URBAN, & + & RSMAX_DATA, BARE, NATURAL, CROP, URBAN, & & DEFINED_VEG, DEFINED_SOIL, DEFINED_SLOPE, & & BB, DRYSMC, HC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, & & WLTSMC, QTZ, mosaic_soil, mosaic_lu, & @@ -201,36 +200,10 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) & 70., 55., 60., 75., 70., 0., 0., 0., & & 0., 0., 0., 0., 0., 0./) - mfsno = & !< modified for RRFS Noah_MP snowmelt curve parameter () - & (/ 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, & - & 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, & - & 3.00, 3.00, 2.00, 2.00, 2.00, 2.00, & - & 2.00, 2.00, 0.00, 0.00, 0.00, 0.00, & -! & 3.00, 3.00, 2.00, 3.00, 3.00, 3.00, & -! & 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) - -!-- Noah MP snowmelt curve values -! & (/ 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, & -! & 2.00, 2.00, 2.00, 2.00, 3.00, 3.00, & -! & 4.00, 4.00, 2.50, 3.00, 3.00, 3.50, & -! & 3.50, 3.50, 0.00, 0.00, 0.00, 0.00, & -! & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) - - sncovfac = & !< Noah_MP snow cover factor (m), first 5 categories are modified for RRFS - & (/ 0.030, 0.030, 0.030, 0.030, 0.030, & - !& (/ 0.008, 0.008, 0.008, 0.008, 0.008, & - & 0.016, 0.016, 0.020, 0.020, 0.020, & - & 0.020, 0.014, 0.042, 0.026, 0.030, & - & 0.016, 0.030, 0.030, 0.030, 0.030, & - & 0.000, 0.000, 0.000, 0.000, 0.000, & - & 0.000, 0.000, 0.000, 0.000, 0.000 /) - natural = 10 + bare = 16 crop = 12 urban = 13 - glacier = 15 - bare = 16 endif ! end if veg table @@ -365,14 +338,12 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) REFSMC =(/0.174, 0.179, 0.249, 0.369, 0.369, 0.314, & - !-- test to reduce moist bias - !REFSMC =(/0.220, 0.205, 0.312, 0.375, 0.369, 0.339, & & 0.299, 0.357, 0.391, 0.316, 0.409, 0.400, & & 0.314, 1.000, 0.100, 0.249, 0.454, 0.170, & & 0.236, 0.000, 0.000, 0.000, 0.000, 0.000, & & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) - SATPSI =(/0.121, 0.150, 0.218, 0.786, 0.786, 0.478, & + SATPSI =(/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, & & 0.299, 0.356, 0.630, 0.153, 0.490, 0.405, & & 0.478, 0.000, 0.121, 0.218, 0.468, 0.069, & & 0.069, 0.00, 0.00, 0.00, 0.00, 0.00, & From a9376a3745fa220ac7f38fbb3c5be82efcc382fc Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 10 Mar 2023 20:46:52 +0000 Subject: [PATCH 03/28] Switch to the default options in snow model --- physics/module_sf_ruclsm.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 744e321ef..d0c3db631 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -27,17 +27,17 @@ MODULE module_sf_ruclsm real (kind=kind_phys), parameter :: r_v = 4.6150e+2 !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 - integer, parameter :: isncond_opt = 2 + integer, parameter :: isncond_opt = 1 !-- Snow fraction options !-- option 1: original formulation using threshold snow depth to compute snow fraction - !integer, parameter :: isncovr_opt = 1 + integer, parameter :: isncovr_opt = 1 !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L., 2007,JGR,DOI:10.1029/2007JD008674. !integer, parameter :: isncovr_opt = 2 !-- option 3: the tanh formulation from Niu,G.-Y.,and Yang,Z with ! vegetation-dependent parameters from Noah MP (personal communication with ! Mike Barlage) - integer, parameter :: isncovr_opt = 3 + !integer, parameter :: isncovr_opt = 3 !-- Mosaic_lu and mosaic_soil are defined in set_soilveg_ruc.F90 and ! passes to RUC LSM via namelist_soilveg_ruc.F90. From c5c6c045fe30bff63c87ec4e5d874b65ca56de55 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 10 Mar 2023 21:19:26 +0000 Subject: [PATCH 04/28] Moved some variables from Interstitial to Sfcprop --- physics/GFS_debug.F90 | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 5387e6300..0414a553f 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -493,6 +493,8 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oro_uf' , Sfcprop%oro_uf) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%hice' , Sfcprop%hice) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%weasd' , Sfcprop%weasd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%weasdl' , Sfcprop%weasdl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%%weasdi' , Sfcprop%weasdi) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%canopy' , Sfcprop%canopy) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%ffmm' , Sfcprop%ffmm) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%ffhh' , Sfcprop%ffhh) @@ -624,6 +626,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, ! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%fluxr_n ', Diag%fluxr(:,n)) !end do call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%srunoff ', Diag%srunoff) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evbs ', Diag%evbs) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evcw ', Diag%evcw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%sbsno ', Diag%sbsno) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evbsa ', Diag%evbsa) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evcwa ', Diag%evcwa) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%snohfa ', Diag%snohfa) @@ -1204,8 +1209,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_ice ', Interstitial%evap_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_land ', Interstitial%evap_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_water ', Interstitial%evap_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evbs ', Interstitial%evbs ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evcw ', Interstitial%evcw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ext_diag_thompson_reset', Interstitial%ext_diag_thompson_reset) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%faerlw ', Interstitial%faerlw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%faersw ', Interstitial%faersw ) @@ -1285,7 +1288,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qss_ice ', Interstitial%qss_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qss_land ', Interstitial%qss_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qss_water ', Interstitial%qss_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fullradar_diag ', Interstitial%fullradar_diag ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%radar_reset ', Interstitial%radar_reset ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%raddt ', Interstitial%raddt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%raincd ', Interstitial%raincd ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%raincs ', Interstitial%raincs ) @@ -1302,7 +1305,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_tcp ', Interstitial%save_tcp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_u ', Interstitial%save_u ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_v ', Interstitial%save_v ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sbsno ', Interstitial%sbsno ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%uvbfc ', Interstitial%scmpsw%uvbfc ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%uvbf0 ', Interstitial%scmpsw%uvbf0 ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%nirbm ', Interstitial%scmpsw%nirbm ) @@ -1315,6 +1317,9 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmafrac ', Interstitial%sigmafrac ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmatot ', Interstitial%sigmatot ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowc ', Interstitial%snowc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_ice ', Interstitial%snowd_ice ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_water ', Interstitial%snowd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snohf ', Interstitial%snohf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowmt ', Interstitial%snowmt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress ', Interstitial%stress ) @@ -1327,7 +1332,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_ice ', Interstitial%tprcp_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_land ', Interstitial%tprcp_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_water ', Interstitial%tprcp_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%trans ', Interstitial%trans ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%trans ', Interstitial%trans ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tseal ', Interstitial%tseal ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfa ', Interstitial%tsfa ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_water ', Interstitial%tsfc_water ) @@ -1341,6 +1346,9 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vdftra ', Interstitial%vdftra ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vegf1d ', Interstitial%vegf1d ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wcbmax ', Interstitial%wcbmax ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_ice ', Interstitial%weasd_ice ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_land ', Interstitial%weasd_land ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_water ', Interstitial%weasd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wind ', Interstitial%wind ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work1 ', Interstitial%work1 ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work2 ', Interstitial%work2 ) From dcf8a31685223e184a1492ee89e58d3174fb4afc Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 17 Mar 2023 01:12:48 +0000 Subject: [PATCH 05/28] Taking care of Dustin Wales comments, removing unnecessary comments, cleaning, etc. --- physics/module_sf_ruclsm.F90 | 1070 +++++++++++----------------------- 1 file changed, 338 insertions(+), 732 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index d0c3db631..4e44bbffd 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -8,7 +8,7 @@ !! and all terms of the surface energy balance and surface water balance. MODULE module_sf_ruclsm - use machine , only : kind_phys + use machine , only : kind_phys, kind_dbl_prec use namelist_soilveg_ruc implicit none @@ -62,7 +62,7 @@ MODULE module_sf_ruclsm !! @{ INTEGER :: SLPCATS INTEGER, PARAMETER :: NSLOPE=30 - REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & + real (kind=kind_phys) :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & CZIL_DATA !! @} @@ -183,8 +183,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! INTEGER, PARAMETER :: nzss=5 ! INTEGER, PARAMETER :: nddzs=2*(nzss-2) - REAL, INTENT(IN ) :: xlat,xlon - REAL, INTENT(IN ) :: DT + real (kind=kind_phys), INTENT(IN ) :: xlat,xlon + real (kind=kind_phys), INTENT(IN ) :: DT LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden INTEGER, INTENT(IN ) :: NLCAT, NSCAT INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & @@ -193,7 +193,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! LOGICAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: flag_iter, flag - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ) , & INTENT(IN ) :: QV3D, & QC3D, & p8w, & @@ -201,7 +201,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & T3D, & z3D - REAL, DIMENSION( ims:ime , jms:jme ), & + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: RAINBL, & GLW, & GSWdn, & @@ -215,22 +215,22 @@ SUBROUTINE LSMRUC(xlat,xlon, & VEGFRA, & TBOT - REAL, DIMENSION( ims:ime , jms:jme ), & + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: GRAUPELNCV, & SNOWNCV, & RAINCV, & RAINNCV - REAL, DIMENSION( ims:ime), INTENT(IN ) :: RHONEWSN_ex !externally-calculated srf frz precip density + real (kind=kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: RHONEWSN_ex !externally-calculated srf frz precip density - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev LOGICAL, intent(in) :: rdlai2d - REAL, DIMENSION( 1:nsl), INTENT(IN ) :: ZS + real (kind=kind_phys), DIMENSION( 1:nsl), INTENT(IN ) :: ZS - REAL, DIMENSION( ims:ime , jms:jme ), & + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: & SNOW, & SNOWH, & @@ -246,23 +246,23 @@ SUBROUTINE LSMRUC(xlat,xlon, & Z0 , & ZNT - REAL, DIMENSION( ims:ime , jms:jme ), & + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: & FRZFRAC INTEGER, DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: IVGTYP, & ISLTYP - REAL, DIMENSION( ims:ime , 1:nlcat, jms:jme ), INTENT(IN):: LANDUSEF - REAL, DIMENSION( ims:ime , 1:nscat, jms:jme ), INTENT(IN):: SOILCTOP + real (kind=kind_phys), DIMENSION( ims:ime , 1:nlcat, jms:jme ), INTENT(IN):: LANDUSEF + real (kind=kind_phys), DIMENSION( ims:ime , 1:nscat, jms:jme ), INTENT(IN):: SOILCTOP - REAL, INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & + real (kind=kind_phys), INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & XICE_threshold - REAL, DIMENSION( ims:ime , 1:nsl, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime , 1:nsl, jms:jme ) , & INTENT(INOUT) :: SOILMOIS,SH2O,TSO - REAL, DIMENSION( ims:ime, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: SOILT, & HFX, & QFX, & @@ -288,11 +288,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & SOILT1, & TSNAV - REAL, DIMENSION( ims:ime, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: SMAVAIL, & SMMAX - REAL, DIMENSION( its:ite, jts:jte ) :: & + real (kind=kind_phys), DIMENSION( its:ite, jts:jte ) :: & PC, & SFCRUNOFF, & UDRUNOFF, & @@ -310,7 +310,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & SEAICE, & INFILTR ! Energy and water budget variables: - REAL, DIMENSION( its:ite, jts:jte ) :: & + real (kind=kind_phys), DIMENSION( its:ite, jts:jte ) :: & budget, & acbudget, & waterbudget, & @@ -320,16 +320,16 @@ SUBROUTINE LSMRUC(xlat,xlon, & canwatold - REAL, DIMENSION( ims:ime, 1:nsl, jms:jme) & + real (kind=kind_phys), DIMENSION( ims:ime, 1:nsl, jms:jme) & :: KEEPFR3DFLAG, & SMFR3D - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & + real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & RHOSNF, & !RHO of snowfall PRECIPFR, & ! time-step frozen precip SNOWFALLAC !--- soil/snow properties - REAL & + real (kind=kind_phys) & :: RHOCS, & RHONEWSN, & RHOSN, & @@ -347,7 +347,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & SNHEI, & SNWE - REAL :: CN, & + real (kind=kind_phys) :: CN, & SAT,CW, & C1SN, & C2SN, & @@ -356,31 +356,31 @@ SUBROUTINE LSMRUC(xlat,xlon, & KWT - REAL, DIMENSION(1:NSL) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NSL) :: ZSMAIN, & ZSHALF, & DTDZS2 - REAL, DIMENSION(1:2*(nsl-2)) :: DTDZS + real (kind=kind_phys), DIMENSION(1:2*(nsl-2)) :: DTDZS - REAL, DIMENSION(1:5001) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001) :: TBQ - REAL, DIMENSION( 1:nsl ) :: SOILM1D, & + real (kind=kind_phys), DIMENSION( 1:nsl ) :: SOILM1D, & TSO1D, & SOILICE, & SOILIQW, & SMFRKEEP - REAL, DIMENSION( 1:nsl ) :: KEEPFR + real (kind=kind_phys), DIMENSION( 1:nsl ) :: KEEPFR - REAL, DIMENSION( 1:nlcat ) :: lufrac - REAL, DIMENSION( 1:nscat ) :: soilfrac + real (kind=kind_phys), DIMENSION( 1:nlcat ) :: lufrac + real (kind=kind_phys), DIMENSION( 1:nscat ) :: soilfrac - REAL :: RSM, & - SNWEPRINT, & - SNHEIPRINT + real (kind=kind_phys) :: RSM, & + SNWEPRINT, & + SNHEIPRINT - REAL :: PRCPMS, & + real (kind=kind_phys) :: PRCPMS, & NEWSNMS, & prcpncliq, & prcpncfr, & @@ -401,10 +401,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & icerat, & curat, & INFILTRP - REAL :: cq,r61,r273,arp,brp,x,evs,eis - REAL :: cropsm + real (kind=kind_phys) :: cq,r61,r273,arp,brp,x,evs,eis + real (kind=kind_phys) :: cropsm - REAL :: meltfactor, ac,as, wb,rovcp + real (kind=kind_phys) :: meltfactor, ac,as, wb,rovcp INTEGER :: NROOT INTEGER :: ILAND,ISOIL,IFOREST @@ -701,10 +701,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & DTDZS(K2)=X/(ZSMAIN(K+1)-ZSMAIN(K)) END DO -!27jul2011 - CN and SAT are defined in VEGPARM.TBL -! CN=0.5 ! exponent -! SAT=0.0004 ! canopy water saturated - CW =4.183E6 @@ -719,7 +715,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & !--- Constants for snow density calculations C1SN and C2SN c1sn=0.026 -! c1sn=0.01 c2sn=21. !*********************************************************************** @@ -770,11 +765,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & ENDIF CN=CFACTR_DATA ! exponent -! SAT=max(1.e-5,(min(5.e-4,(CMCMAX_DATA * (1.-exp(-0.5*lai(i,j))) * 0.01*VEGFRA(I,J))))) ! canopy water saturated SAT = 5.e-4 ! units [m] !-- definition of number of soil levels in the rooting zone -! IF(iforest(ivgtyp(i,j)).ne.1) THEN IF(iforest.gt.2) THEN !---- all vegetation types except evergreen and mixed forests !18apr08 - define meltfactor for Egglston melting limit: @@ -861,7 +854,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & PRINT*,' sea-ice at water point, I=',I, & 'J=',J ENDIF -! ILAND = 24 ILAND = isice if(nscat == 9) then ISOIL = 9 ! ZOBLER @@ -870,7 +862,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif ZNT(I,J) = 0.011 ! in FV3 albedo and emiss are defined for ice - !snoalb(i,j) = snoalb(i,j) emissl(i,j) = emisbck(i,j) ! no snow impact, old 0.98 used in WRF dqm = 1. ref = 1. @@ -895,9 +886,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! or dry soil moisture content for a given soil type) as a state variable. DO k=1,nzs -! soilm1d - soil moisture content minus residual [m**3/m**3] + ! soilm1d - soil moisture content minus residual [m**3/m**3] soilm1d (k) = min(max(0.,soilmois(i,k,j)-qmin),dqm) -! soilm1d (k) = min(max(0.,soilmois(i,k,j)),dqm) tso1d (k) = tso(i,k,j) soiliqw (k) = min(max(0.,sh2o(i,k,j)-qmin),soilm1d(k)) soilice (k) =(soilm1d (k) - soiliqw (k))/0.9 @@ -922,14 +912,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & smtotold(i,j)=0. - !do k=1,nzs-1 do k=1,nroot smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(k))* & (zshalf(k+1)-zshalf(k)) enddo - !smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(nzs))* & - ! (zsmain(nzs)-zshalf(nzs)) if (debug_print .and. abs(xlat-testptlat).lt.0.2 & .and. abs(xlon-testptlon).lt.0.2) then print *,'Old soilm1d ',i,soilm1d @@ -984,8 +971,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & !tgs - turn off "irrigation" while there is no fractional landuse and LAI !climatology. IF (lufrac(crop) > 0 .and. lai(i,j) > 1.1) THEN -! IF (ivgtyp(i,j) == crop .and. lai(i,j) > 1.1) THEN -! cropland + ! cropland do k=1,nroot cropsm=1.1*wilt - qmin if(soilm1d(k) < cropsm*lufrac(crop)) then @@ -1002,7 +988,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & enddo ELSEIF (ivgtyp(i,j) == natural .and. lai(i,j) > 0.7) THEN -! grassland: assume that 40% of grassland is irrigated cropland + ! grassland: assume that 40% of grassland is irrigated cropland do k=1,nroot cropsm=1.2*wilt - qmin if(soilm1d(k) < cropsm*lufrac(natural)*0.4) then @@ -1035,11 +1021,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & (zshalf(k+1)-zshalf(k)) enddo - !smavail(i,j)=smavail(i,j)+(qmin+soilm1d(nzs))* & - ! (zsmain(nzs)-zshalf(nzs)) - !smmax (i,j) =smmax (i,j)+(qmin+dqm)* & - ! (zsmain(nzs)-zshalf(nzs)) - if (debug_print) then if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then print 100,'(RUC runoff) i=',i,' lat,lon=',xlat,xlon, & @@ -1050,11 +1031,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & !--- Convert the water unit into mm !-- three lines below are commented because accumulation ! happens in sfc_drv_ruc - !SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 - !UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 - !ACRUNOFF (I,J) = ACRUNOFF(i,j)+UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 - !ACRUNOFF(I,J) = ACRUNOFF(i,j)+RUNOFF1(I,J)*DT*1000.0 ! acc surface runoff SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. ! mm SMMAX (I,J) = SMMAX(I,J) * 1000. smtotold (I,J) = smtotold(I,J) * 1000. ! mm @@ -1077,26 +1054,23 @@ SUBROUTINE LSMRUC(xlat,xlon, & !tgs add together dew and cloud at the ground surface !30july13 qcg(i,j)=qcg(i,j)+dew(i,j)/qkms - !Z0 (I,J) = ZNT (I,J) + Z0 (I,J) = ZNT (I,J) SFCEXC (I,J) = TKMS patmb=P8w(i,1,j)*1.e-2 Q2SAT=QSN(TABS,TBQ)/PATMB QSFC(I,J) = QVG(I,J)/(1.+QVG(I,J)) -! for MYJ surface and PBL scheme -! if (myj) then -! MYJSFC expects QSFC as actual specific humidity at the surface + ! for MYJ surface and PBL scheme + ! if (myj) then + ! MYJSFC expects QSFC as actual specific humidity at the surface IF((QVATM.GE.Q2SAT*0.95).AND.QVATM.LT.qvg(I,J))THEN CHKLOWQ(I,J)=0. ELSE CHKLOWQ(I,J)=1. ENDIF -! else -! CHKLOWQ(I,J)=1. -! endif if(snow(i,j)==0.) EMISSL(i,j) = EMISBCK(i,j) EMISS (I,J) = EMISSL(I,J) -! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m + ! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m SNOW (i,j) = SNWE*1000. SNOWH (I,J) = SNHEI CANWAT (I,J) = CANWATR*1000. @@ -1114,7 +1088,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) endif ENDIF -!!! QFX (I,J) = LH(I,J)/LV SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT GRDFLX (I,J) = -1. * sflx(I,J) @@ -1126,10 +1099,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! endif !--- SNOWC snow cover flag - !if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then - ! SNOWFRAC = SNOWFRAC*XICE(I,J) - !endif - SNOWC(I,J)=SNOWFRAC !--- RHOSNF - density of snowfall @@ -1138,16 +1107,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! Accumulated moisture flux [kg/m^2] SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT -!TEST!!!! for test put heat budget term in GRDFLX - -! acbudget(i,j)=acbudget(i,j)+budget(i,j)-smf(i,j) -! GRDFLX (I,J) = acbudget(i,j) - -! if(smf(i,j) .ne.0.) then -!tgs - SMF.NE.0. when there is phase change in the top soil layer -! The heat of freezing/thawing of soil water is not computed explicitly -! and is responsible for the residual in the energy budget. -! endif +!--tgs - SMF.NE.0. when there is phase change in the top soil layer +! The heat of freezing/thawing of soil water is not computed explicitly +! and is responsible for the residual in the energy budget. +! endif ! budget(i,j)=budget(i,j)-smf(i,j) if (debug_print ) then @@ -1161,46 +1124,38 @@ SUBROUTINE LSMRUC(xlat,xlon, & ac=canwat(i,j)-canwatold(i,j)*1.e3 ! canopy water change as=snwe-snowold(i,j) ! SWE change wb = smavail(i,j)-smtotold(i,j) - waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source + waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3_kind_phys & ! source -qfx(i,j)*dt & - -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 & + -runoff1(i,j)*dt*1.e3_kind_phys-runoff2(i,j)*dt*1.e3_kind_phys & -ac-as ! - (smavail(i,j)-smtotold(i,j)) print *,'soilm1d ',i,soilm1d print 100,'(RUC budgets) i=',i,' lat,lon=',xlat,xlon, & 'budget ',budget(i,j),'waterbudget',waterbudget(i,j), & 'rainbl ',rainbl(i,j),'runoff1 ',runoff1(i,j), & - 'smelt ',smelt(i,j)*dt*1.e3,'smc change ',wb, & + 'smelt ',smelt(i,j)*dt*1.e3_kind_phys,'smc change ',wb, & 'snwe change ',as,'canw change ',ac,'runoff2 ',runoff2(i,j), & 'qfx*dt ',qfx(i,j)*dt,'smavail ',smavail(i,j),'smcold',smtotold(i,j) + !-- + waterbudget(i,j)=rainbl(i,j)-qfx(i,j)*dt-(smavail(i,j)-smtotold(i,j)) & + + print *,'Smf=',smf(i,j),i,j + print *,'Budget',budget(i,j),i,j + print *,'RUNOFF2= ', i,j,runoff2(i,j) + print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb + print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & + i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & + smelt(i,j)*dt*1.e3_kind_phys, & + (smavail(i,j)-smtotold(i,j)) +! + print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) + print *,'SNOW-SNOWold',i,j,max(0._kind_phys,snwe-snowold(i,j)) + print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) + print *,'canwat(i,j)-canwatold(i,j)',max(0._kind_phys,canwat(i,j)-canwatold(i,j)) endif endif - 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es14.7))) - !-- - - - -! waterbudget(i,j)=rainbl(i,j)-qfx(i,j)*dt-(smavail(i,j)-smtotold(i,j)) & -!tgs27apr17 acwaterbudget(i,j)=acwaterbudget(i,j)+waterbudget(i,j) - -!!!!TEST use LH to check water budget -! GRDFLX (I,J) = waterbudget(i,j) - -! print *,'Smf=',smf(i,j),i,j -! print *,'Budget',budget(i,j),i,j -! print *,'RUNOFF2= ', i,j,runoff2(i,j) -! print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb -! print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & -! i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & -! smelt(i,j)*dt*1.e3, & -! (smavail(i,j)-smtotold(i,j)) -! -! print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) -! print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) -! print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) -! print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) -! ENDIF + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es14.7))) IF (debug_print ) THEN @@ -1265,17 +1220,17 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: isice,i,j,nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon - REAL, INTENT(IN ) :: testptlat,testptlon - REAL, INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon + real (kind=kind_phys), INTENT(IN ) :: testptlat,testptlon + real (kind=kind_phys), INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex LOGICAL, INTENT(IN ) :: myj, debug_print, exticeden !--- 3-D Atmospheric variables - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: PATM, & TABS, & QVATM, & QCATM - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: GLW, & GSW, & GSWdn, & @@ -1292,7 +1247,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP !--- 2-D variables - REAL , & + real (kind=kind_phys) , & INTENT(INOUT) :: EMISS, & EMISBCK, & MAVAIL, & @@ -1302,7 +1257,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia CST !--- soil properties - REAL :: & + real (kind=kind_phys) :: & RHOCS, & BCLH, & DQM, & @@ -1314,7 +1269,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SAT, & WILT - REAL, INTENT(IN ) :: CN, & + real (kind=kind_phys), INTENT(IN ) :: CN, & CW, & CP, & ROVCP, & @@ -1325,26 +1280,26 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia KICE, & KWT - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TS1D, & SOILM1D, & SMFRKEEP - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR - REAL, DIMENSION(1:NZS), INTENT(INOUT) :: SOILICE, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(INOUT) :: SOILICE, & SOILIQW @@ -1352,7 +1307,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER :: ILANDs !-------- 2-d variables - REAL , & + real (kind=kind_phys) , & INTENT(INOUT) :: DEW, & EDIR1, & EC1, & @@ -1392,7 +1347,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia TSNAV, & ZNT - REAL, DIMENSION(1:NZS) :: & + real (kind=kind_phys), DIMENSION(1:NZS) :: & tice, & rhosice, & capice, & @@ -1404,7 +1359,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SOILICES, & KEEPFRS !-------- 1-d variables - REAL :: & + real (kind=kind_phys) :: & DEWS, & MAVAILS, & EDIR1s, & @@ -1429,23 +1384,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia - REAL, INTENT(INOUT) :: RSM, & + real (kind=kind_phys), INTENT(INOUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables INTEGER :: K,ILNB - REAL :: BSN, XSN , & + real (kind=kind_phys) :: BSN, XSN , & RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & T3, UPFLUX, XINET, snowfrac2, m - REAL :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn - REAL :: newsnowratio, dd1 + real (kind=kind_phys) :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn + real (kind=kind_phys) :: newsnowratio, dd1 - REAL :: rhonewgr,rhonewice + real (kind=kind_phys) :: rhonewgr,rhonewice - REAL :: RNET,GSWNEW,GSWIN,EMISSN,ZNTSN,EMISS_snowfree - REAL :: VEGFRAC, snow_mosaic, snfr, vgfr + real (kind=kind_phys) :: RNET,GSWNEW,GSWIN,EMISSN,ZNTSN,EMISS_snowfree + real (kind=kind_phys) :: VEGFRAC, snow_mosaic, snfr, vgfr real :: cice, albice, albsn, drip, dripsn, dripliq real :: interw, intersn, infwater, intwratio @@ -1465,23 +1420,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! with vegetation dependent parameters from Noah MP (personal ! communication with Mike Barlage) !-- SNHEI_CRIT is a threshold for fractional snow in isncovr_opt=1 - snhei_crit=0.01601*1.e3/rhosn - snhei_crit_newsn=0.0005*1.e3/rhosn + snhei_crit=0.01601_kind_phys*1.e3_kind_phys/rhosn + snhei_crit_newsn=0.0005*1.e3_kind_phys/rhosn !-- zntsn = z0tbl(isice) - snow_mosaic=0. - snfr = 1. - NEWSN=0. - newsnowratio = 0. - snowfracnewsn=0. - snowfrac2=0. - rhonewsn = 100. - if(snhei == 0.) snowfrac=0. - smelt = 0. - RAINF = 0. - RSM=0. - DD1=0. - INFILTR=0. + snow_mosaic=0._kind_phys + snfr = 1._kind_phys + NEWSN=0._kind_phys + newsnowratio = 0._kind_phys + snowfracnewsn=0._kind_phys + snowfrac2=0._kind_phys + rhonewsn = 100._kind_phys + if(snhei == 0._kind_phys) snowfrac=0._kind_phys + smelt = 0._kind_phys + RAINF = 0._kind_phys + RSM=0._kind_phys + DD1=0._kind_phys + INFILTR=0._kind_phys ! Jul 2016 - Avissar and Pielke (1989) ! This formulation depending on LAI defines relative contribution of the vegetation to ! the total heat fluxes between surface and atmosphere. @@ -1489,29 +1444,29 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! only 86% of the total surface fluxes. ! VGFR=0.01*VEGFRA ! % --> fraction ! VEGFRAC=2.*lai*vgfr/(1.+2.*lai*vgfr) - VEGFRAC=0.01*VEGFRA - drip = 0. - dripsn = 0. - dripliq = 0. - smf = 0. - interw=0. - intersn=0. - infwater=0. + VEGFRAC=0.01_kind_phys*VEGFRA + drip = 0._kind_phys + dripsn = 0._kind_phys + dripliq = 0._kind_phys + smf = 0._kind_phys + interw=0._kind_phys + intersn=0._kind_phys + infwater=0._kind_phys !---initialize local arrays for sea ice do k=1,nzs - tice(k) = 0. - rhosice(k) = 0. - cice = 0. - capice(k) = 0. - thdifice(k) = 0. + tice(k) = 0._kind_phys + rhosice(k) = 0._kind_phys + cice = 0._kind_phys + capice(k) = 0._kind_phys + thdifice(k) = 0._kind_phys enddo GSWnew=GSW GSWin=GSWdn !/(1.-alb) ALBice=ALB_SNOW_FREE ALBsn=alb_snow - EMISSN = 0.99 ! from setemis, from WRF - 0.98 + EMISSN = 0.99_kind_phys ! from setemis, from WRF - 0.98 EMISS_snowfree = EMISBCK ! LEMITBL(IVGTYP) !--- sea ice properties @@ -1535,7 +1490,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif IF (debug_print ) THEN -! print *,'I,J,KTAU,QKMS,TKMS', i,j,ktau,qkms,tkms print *,'alb_snow_free',ALB_SNOW_FREE print *,'GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE',& GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE @@ -1552,7 +1506,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- snow_mosaic from the previous time step if(snowfrac < 0.75) snow_mosaic = 1. - !if(snowfrac < 0.9) snow_mosaic = 1. newsn=newsnms*delt !---- ACSNOW - run-total snowfall water [mm] @@ -1587,7 +1540,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! of snow, graupel and ice fractions rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & -!13mar18 rhosnfall = min(500.,max(76.9,(rhonewsn*snowrat + & rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) if (debug_print) then @@ -1684,23 +1636,19 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! endif !-- update snow cover with accounting for fresh snow - m = 1.0 ! m=1.6 in Niu&Yang, m=1 in CLM + m = 1.0_kind_phys ! m=1.6 in Niu&Yang, m=1 in CLM if(isncovr_opt == 1) then - snowfrac=min(1.,snhei/(2.*snhei_crit)) + snowfrac=min(1._kind_phys,snhei/(2.*snhei_crit)) elseif(isncovr_opt == 2) then - snowfrac=min(1.,snhei/(2.*snhei_crit)) + snowfrac=min(1.,snhei/(2._kind_phys*snhei_crit)) if(ivgtyp == glacier .or. ivgtyp == bare) then !-- sparsely vegetated or land ice snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**m)) - !- TEST - replace rhonewsn with 100 in Niu&Yang - !snowfrac2 = tanh( snhei/(2.5 * znt *(rhosn*1.e-2)**m)) else !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests ! on 3-km scale use actual roughness, but not higher than 0.2 m. ! The factor is 20 for forests (~100/dx = 33.) snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m)) - !- TEST - replace rhonewsn with 100 in Niu&Yang - !snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn*1.e-2)**m)) endif !-- snow fraction is average between method 1 and 2 snowfrac = 0.5*(snowfrac+snowfrac2) @@ -1711,20 +1659,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! snow cover fractions on the 3-km scale. ! This factor is scale dependent. snowfrac = tanh( snhei/(10. * facsnf *(rhosn/rhonewsn)**m)) - !- TEST - replace rhonewsn with 100 in Niu&Yang - !snowfrac = tanh( snhei/(10. * facsnf *(rhosn*1.e-2)**m)) endif -! if(meltfactor > 1.5) then -! if(isltyp > 9 .and. isltyp < 13) then -!24nov15 clay soil types - SNOFRAC < 0.9 -! snowfrac=min(0.9,snowfrac) -! endif -! else -!24nov15 - SNOWFRAC for forests < 0.75 -! snowfrac=min(0.85,snowfrac) -! endif - if(newsn > 0. ) then SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) endif @@ -1737,21 +1673,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) if(snowfrac < 0.75) snow_mosaic = 1. - !if(snowfrac < 0.9) snow_mosaic = 1. KEEP_SNOW_ALBEDO = 0. IF (NEWSN > 0. .and. snowfracnewsn > 0.99 .and. rhosnfall < 450.) THEN -! new snow + ! new snow KEEP_SNOW_ALBEDO = 1. !snow_mosaic=0. ! ??? ENDIF -!7Mar18 - turn off snow mosaic for T<271K to prevent from too warm -! temperature and loss of low-level clouds in HRRR (case 2 Feb. 2018, 15z) -! IF (TABS < 271.) then -! snow_mosaic=0. -! ENDIF - IF (debug_print ) THEN print *,'SNHEI_CRIT,SNOWFRAC,SNHEI_CRIT_newsn,SNOWFRACnewsn', & SNHEI_CRIT,SNOWFRAC,SNHEI_CRIT_newsn,SNOWFRACnewsn @@ -1772,10 +1701,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ENDIF -!--- GSWNEW in-coming solar for snow on land or on ice -! GSWNEW=GSWnew/(1.-ALB) -!-- Time to update snow and ice albedo - IF(SEAICE .LT. 0.5) THEN !----- SNOW on soil !-- ALB dependence on snow depth @@ -1784,13 +1709,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! hwlps with these biases.. if( snow_mosaic == 1.) then ALBsn=alb_snow -! ALBsn=max(0.4,alb_snow) if(newsn > 0. .and. KEEP_SNOW_ALBEDO > 0.9 .and. albsn < 0.4) then !-- Albedo correction with fresh snow and deep snow pack !-- will reduce warm bias in western Canada !-- and US West coast, where max snow albedo is low (0.3-0.5). !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j - !!!!ALBsn = 0.7 + !ALBsn = 0.7 endif Emiss= emissn @@ -1803,7 +1727,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- will reduce warm bias in western Canada !-- and US West coast, where max snow albedo is low (0.3-0.5). !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j - !!!!ALBsn = 0.7 + !ALBsn = 0.7 !print *,'NO mosaic ALB increase to 0.7',alb_snow,snhei,snhei_crit,alb,i,j endif @@ -1820,10 +1744,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! higher than patchy snow treshold - then snow albedo is not less than 0.55 ! (inspired by the flight from Fairbanks to Seatle) -!test if(cst.ge.0.95*sat .and. snowfrac .gt.0.99)then -! albsn=max(alb_snow,0.55) -! endif - !-- ALB dependence on snow temperature. When snow temperature is !-- below critical value of -10C - no change to albedo. !-- If temperature is higher that -10C then albedo is decreasing. @@ -1831,7 +1751,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- albedo of temperatures below -10C. if(albsn.lt.0.4 .or. keep_snow_albedo==1) then ALB=ALBsn -! ALB=max(0.4,alb_snow) else !-- change albedo when no fresh snow and snow albedo is higher than 0.5 ALB = MIN(ALBSN,MAX(ALBSN - 0.1*(soilt - 263.15)/ & @@ -2120,7 +2039,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia sublim = sublim*snowfrac prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac fltot = fltots*(1.-snowfrac) + fltot*snowfrac -!alb ALB = MAX(keep_snow_albedo*alb, & MIN((alb_snow_free + (alb - alb_snow_free) * snowfrac), alb)) @@ -2128,12 +2046,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia MIN((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) -! alb=alb_snow_free*(1.-snowfrac) + alb*snowfrac -! emiss=emiss_snowfree*(1.-snowfrac) + emissn*snowfrac - -! if(abs(fltot) > 2.) then -! print *,'i,j,fltot,snowfrac,fltots',fltot,snowfrac,fltots,i,j -! endif runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac smelt = smelt * snowfrac @@ -2235,15 +2147,11 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(ivgtyp == glacier .or. ivgtyp == bare) then !-- sparsely vegetated or land ice snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**m)) - !- TEST - replace rhonewsn with 100 in Niu&Yang - !snowfrac2 = tanh( snhei/(2.5 * znt *(rhosn*1.e-2)**m)) else !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests ! on 3-km scale use actual roughness, but not higher than 0.2 m. ! The factor is 20 for forests (~100/dx = 33.) snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m)) - !- TEST - replace rhonewsn with 100 in Niu&Yang - !snowfrac2 = tanh( snhei/(2.5 *min(0.15,znt) *(rhosn*1.e-2)**m)) endif !-- snow fraction is average between method 1 and 2 snowfrac = 0.5*(snowfrac+snowfrac2) @@ -2254,8 +2162,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! snow cover fractions on the 3-km scale. ! This factor is scale dependent. snowfrac = tanh( snhei/(10. * facsnf *(rhosn/rhonewsn)**m)) - !- TEST - replace rhonewsn with 100 in Niu&Yang - !snowfrac = tanh( snhei/(2.5* min(0.2,znt) *(rhosn*1.e-2)**m)) endif !-- due to steep slopes and blown snow, limit snow fraction in the @@ -2275,7 +2181,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia print *,'Time-step sublim: swe,[kg m-2]',sublim*delt endif - !snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio))*1.e3 snowfallac = snowfallac + max(0.,(newsn*rhonewsn - & ! source of snow (swe) [m] (smelt+sublim*1.e-3)*delt*newsnowratio) & ! sink: melting and sublimation, (swe) [m] /rhonewsn)*1.e3 ! snow accumulation in snow depth [mm] @@ -2363,8 +2268,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ENDIF -! RETURN -! END !--------------------------------------------------------------- END SUBROUTINE SFCTMP !--------------------------------------------------------------- @@ -2374,10 +2277,10 @@ END SUBROUTINE SFCTMP !! the precomputed table and a given temperature. FUNCTION QSN(TN,T) !**************************************************************** - REAL, DIMENSION(1:5001), INTENT(IN ) :: T - REAL, INTENT(IN ) :: TN + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN ) :: T + real (kind=kind_phys), INTENT(IN ) :: TN - REAL QSN, R,R1,R2 + real (kind=kind_phys) QSN, R,R1,R2 INTEGER I R=(TN-173.15)/.05+1. @@ -2391,9 +2294,6 @@ FUNCTION QSN(TN,T) 20 R1=T(I) R2=R-I QSN=(T(I+1)-R1)*R2 + R1 -! print *,' in QSN, I,R,R1,R2,T(I+1),TN, QSN', I,R,r1,r2,t(i+1),tn,QSN -! RETURN -! END !----------------------------------------------------------------------- END FUNCTION QSN !------------------------------------------------------------------------ @@ -2483,15 +2383,15 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,xlat,xlon + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: GLW, & GSW, & GSWin, & @@ -2505,7 +2405,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & TKMS !--- soil properties - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -2516,7 +2416,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & REF, & WILT - REAL, INTENT(IN ) :: CN, & + real (kind=kind_phys), INTENT(IN ) :: CN, & CW, & KQWRTZ, & KICE, & @@ -2525,27 +2425,27 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & g0_p - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO, & SOILMOIS, & SMFRKEEP - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR !-------- 2-d variables - REAL, & + real (kind=kind_phys), & INTENT(INOUT) :: DEW, & CST, & DRIP, & @@ -2569,40 +2469,38 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & SOILT !-------- 1-d variables - REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & SOILIQW !--- Local variables - REAL :: INFILTRP, transum , & + real (kind=kind_phys) :: INFILTRP, transum , & RAINF, PRCPMS , & TABS, T3, UPFLUX, XINET - REAL :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & + real (kind=kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & can,epot,fac,fltot,ft,fq,hft , & q1,ras,rhoice,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW, X - REAL, DIMENSION(1:NZS) :: transp,cap,diffu,hydro , & + real (kind=kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold - REAL :: soiltold,smf - REAL :: soilres, alfa, fex, fex_fc, fc, psit + real (kind=kind_phys) :: soiltold,smf + real (kind=kind_phys) :: soilres, alfa, fex, fex_fc, fc, psit INTEGER :: nzs1,nzs2,k !----------------------------------------------------------------- !-- define constants -! STBOLT=5.670151E-8 RHOICE=900. CI=RHOICE*2100. XLMELT=3.35E+5 cvw=cw -! SAT=0.0004 prcpl=prcpms smf=0. @@ -2652,13 +2550,13 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & soilice(k)=(soilmois(k)-soiliqw(k))/RIW !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then + if(keepfr(k).eq.1._kind_phys) then soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw) + soiliqw(k)=max(0._kind_phys,soilmois(k)-soilice(k)*riw) endif else - soilice(k)=0. + soilice(k)=0._kind_phys soiliqw(k)=soilmois(k) endif @@ -2670,17 +2568,17 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) tavln=log(tav(k)/273.15) - if(tavln.lt.0.) then + if(tavln.lt.0._kind_phys) then soiliqwm(k)=(dqm+qmin)*(XLMELT* & (tav(k)-273.15)/tav(k)/9.81/psis) & **(-1./bclh)-qmin fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin - soiliqwm(k)=max(0.,soiliqwm(k)) + soiliqwm(k)=max(0._kind_phys,soiliqwm(k)) soiliqwm(k)=min(soiliqwm(k), soilmoism(k)) soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then + if(keepfr(k).eq.1._kind_phys) then soilicem(k)=min(soilicem(k), & 0.5*(smfrkeep(k)+smfrkeep(k+1))) soiliqwm(k)=max(0.,soilmoism(k)-soilicem(k)*riw) @@ -2689,16 +2587,16 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & endif else - soilicem(k)=0. + soilicem(k)=0._kind_phys soiliqwm(k)=soilmoism(k) lwsat(k)=dqm+qmin - fwsat(k)=0. + fwsat(k)=0._kind_phys endif ENDDO do k=1,nzs - if(soilice(k).gt.0.) then + if(soilice(k).gt.0._kind_phys) then smfrkeep(k)=soilice(k) else smfrkeep(k)=soilmois(k)/riw @@ -2739,7 +2637,6 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !--- transpiration may take place. WETCAN=min(0.25,max(0.,(CST/SAT))**CN) -! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN !************************************************************** @@ -2784,8 +2681,6 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! For now we'll go back to ref*0.5 ! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct ! evaporation. Therefore , it is replaced with ref*0.7. - !fc=max(qmin,ref*0.5) - !fc=max(qmin,ref*0.7) fc=ref fex_fc=1. if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then @@ -2911,7 +2806,6 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & T3 = STBOLT*SOILTold*SOILTold*SOILTold UPFLUX = T3 * 0.5*(SOILTold+SOILT) XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET HFT=-TKMS*CP*RHO*(TABS-SOILT) HFX=-TKMS*CP*RHO*(TABS-SOILT) & *(P1000mb*0.00001/Patm)**ROVCP @@ -2937,7 +2831,6 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & CST=CST+DELT*DEW*RAS * vegfrac IF (debug_print ) THEN ! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then -! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then print *,'Cond RUC LSM EETA',EETA,eeta*xlv, i,j ENDIF endif ! myj @@ -2958,11 +2851,6 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & CST=max(0.,CST-EC1 * DELT) -! if (EC1 > CMC2MS) then -! EC1 = min(cmc2ms,ec1) -! CST = 0. -! endif - if (myj) then !-- moisture flux for coupling with MYJ PBL EETA=-soilres*QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 @@ -2974,13 +2862,11 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & print *,'Q1*(1.-vegfrac),EDIR1',Q1*(1.-vegfrac),EDIR1 print *,'CST,WETCAN,DRYCAN',CST,WETCAN,DRYCAN print *,'EC1=',EC1,'ETT1=',ETT1,'CMC2MS=',CMC2MS,'CMC2MS*ras=',CMC2MS*ras -! print *,'MYJ EETA',eeta,eeta*xlv ENDIF !-- actual moisture flux from RUC LSM EETA = (EDIR1 + EC1 + ETT1)*1.E3 IF (debug_print ) THEN ! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then -! IF(i.eq.440.and.j.eq.180 .or. qfx.gt.1000..or.i.eq.417.and.j.eq.540) then print *,'RUC LSM EETA',EETA,eeta*xlv ENDIF endif ! myj @@ -3004,7 +2890,6 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ENDIF if(detal(1) .ne. 0.) then ! SMF - energy of phase change in the first soil layer -! smf=xlmelt*1.e3*(soiliqwm(1)-soiliqwmold(1))/delt smf=fltot IF (debug_print ) THEN print *,'detal(1),xlmelt,soiliqwm(1),delt',detal(1),xlmelt,soiliqwm(1),delt @@ -3052,15 +2937,15 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,xlat,xlon + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: GLW, & GSW, & EMISS, & @@ -3068,7 +2953,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & QKMS, & TKMS !--- sea ice properties - REAL, DIMENSION(1:NZS) , & + real (kind=kind_phys), DIMENSION(1:NZS) , & INTENT(IN ) :: & tice, & rhosice, & @@ -3076,25 +2961,25 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & thdifice - REAL, INTENT(IN ) :: & + real (kind=kind_phys), INTENT(IN ) :: & CW, & XLV - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !----soil temperature - REAL, DIMENSION( 1:nzs ), INTENT(INOUT) :: TSO + real (kind=kind_phys), DIMENSION( 1:nzs ), INTENT(INOUT) :: TSO !-------- 2-d variables - REAL, & + real (kind=kind_phys), & INTENT(INOUT) :: DEW, & EETA, & EVAPL, & @@ -3109,28 +2994,27 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & SOILT !--- Local variables - REAL :: x,x1,x2,x4,tn,denom - REAL :: RAINF, PRCPMS , & - TABS, T3, UPFLUX, XINET + real (kind=kind_phys) :: x,x1,x2,x4,tn,denom + real (kind=kind_phys) :: RAINF, PRCPMS , & + TABS, T3, UPFLUX, XINET - REAL :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & + real (kind=kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & epot,fltot,ft,fq,hft,ras,cvw - REAL :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11 , & + real (kind=kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & TDENOM,QGOLD,SNOH - REAL :: AA1,RHCS, icemelt + real (kind=kind_phys) :: AA1,RHCS, icemelt - REAL, DIMENSION(1:NZS) :: cotso,rhtso + real (kind=kind_phys), DIMENSION(1:NZS) :: cotso,rhtso INTEGER :: nzs1,nzs2,k,k1,kn,kk !----------------------------------------------------------------- !-- define constants -! STBOLT=5.670151E-8 XLMELT=3.35E+5 cvw=cw @@ -3221,7 +3105,6 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & T3 = STBOLT*TN*TN*TN UPFLUX = T3 *0.5*(TN+SOILT) XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET HFT=-TKMS*CP*RHO*(TABS-SOILT) HFX=-TKMS*CP*RHO*(TABS-SOILT) & *(P1000mb*0.00001/Patm)**ROVCP @@ -3395,7 +3278,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & RAINF,NEWSNOW,RHONEWSN, & testptlat,testptlon, & SNHEI_CRIT,meltfactor,xlat,xlon @@ -3403,12 +3286,12 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: GLW, & GSW, & GSWin, & @@ -3422,7 +3305,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: IVGTYP !--- soil properties - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -3434,7 +3317,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & SAT, & WILT - REAL, INTENT(IN ) :: CN, & + real (kind=kind_phys), INTENT(IN ) :: CN, & CW, & XLV, & G0_P, & @@ -3443,23 +3326,23 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & KWT - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO, & SOILMOIS, & SMFRKEEP - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR @@ -3467,7 +3350,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !-------- 2-d variables - REAL , & + real (kind=kind_phys) , & INTENT(INOUT) :: DEW, & CST, & DRIP, & @@ -3504,35 +3387,35 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER, INTENT(INOUT) :: ILNB !-------- 1-d variables - REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & - SOILIQW + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + SOILIQW - REAL, INTENT(OUT) :: RSM, & - SNWEPRINT, & - SNHEIPRINT + real (kind=kind_phys), INTENT(OUT) :: RSM, & + SNWEPRINT, & + SNHEIPRINT !--- Local variables INTEGER :: nzs1,nzs2,k - REAL :: INFILTRP, TRANSUM , & + real (kind=kind_phys) :: INFILTRP, TRANSUM , & SNTH, NEWSN , & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP - REAL :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt,dzstop , & + real (kind=kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt,dzstop, & can,epot,fac,fltot,ft,fq,hft , & q1,ras,rhoice,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW,DELTSN,H,UMVEG - REAL, DIMENSION(1:NZS) :: transp,cap,diffu,hydro , & + real (kind=kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold - REAL :: soiltold, qgold + real (kind=kind_phys) :: soiltold, qgold - REAL :: RNET, X + real (kind=kind_phys) :: RNET, X !----------------------------------------------------------------- @@ -3540,11 +3423,8 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & XLMELT=3.35E+5 !-- heat of water vapor sublimation XLVm=XLV+XLMELT -! STBOLT=5.670151E-8 !--- SNOW flag -- ISICE -! ILAND=isice - !--- DELTSN - is the threshold for splitting the snow layer into 2 layers. !--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm, !--- equivalent to 0.03 m SNWE. For other snow densities the threshold is @@ -3560,16 +3440,8 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & x=0. ! increase thinkness of top snow layer from 3 cm SWE to 5 cm SWE -! DELTSN=5.*SNHEI_CRIT -! snth=0.4*SNHEI_CRIT - DELTSN=0.05*1.e3/rhosn snth=0.01*1.e3/rhosn -! snth=0.01601*1.e3/rhosn - -! if(i.eq.442.and.j.eq.260) then -! print *,'deltsn,snhei,snth',i,j,deltsn,snhei,snth -! ENDIF ! For 2-layer snow model when the snow depth is marginally higher than DELTSN, ! reset DELTSN to half of snow depth. @@ -3584,7 +3456,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & CI=RHOICE*2100. RAS=RHO*1.E-3 RIW=rhoice*1.e-3 -! MAVAIL=1. RSM=0. DO K=1,NZS @@ -3709,7 +3580,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW SMELT=0. -! DD1=0. H=MAVAIL ! =1. if snowfrac=1 FQ=QKMS @@ -3738,7 +3608,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ENDIF WETCAN=min(0.25,max(0.,(CST/SAT))**CN) -! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN !************************************************************** @@ -3798,7 +3667,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & DO K=1,NROOT TRANSP(K)=vegfrac*RAS*FQ*(QVATM-QSG) & *tranf(K)*DRYCAN/zshalf(NROOT+1) -! IF(TRANSP(K).GT.0.) TRANSP(K)=0. ETT1=ETT1-TRANSP(K) ENDDO DO k=nroot+1,nzs @@ -3888,7 +3756,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & T3 = STBOLT*SOILTold*SOILTold*SOILTold UPFLUX = T3 *0.5*(SOILTold+SOILT) XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET HFX=-TKMS*CP*RHO*(TABS-SOILT) & *(P1000mb*0.00001/Patm)**ROVCP IF (debug_print ) THEN @@ -3932,11 +3799,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & CST=max(0.,CST-EC1 * DELT) -! if(EC1 > CMC2MS) then -! EC1 = min(cmc2ms,ec1) -! CST = 0. -! endif - IF (debug_print ) THEN print*,'Q1,umveg,beta',Q1,umveg,beta print *,'wetcan,vegfrac',wetcan,vegfrac @@ -3961,7 +3823,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & EETA = (EDIR1 + EC1 + ETT1)*1.E3 ENDIF S=SNFLX - !sublim=EDIR1*1.E3 sublim=Q1*1.E3 !kg m-2 s-1 ! Energy budget FLTOT=RNET-HFT-XLVm*EETA-S-SNOH-x @@ -4018,19 +3879,19 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & RAINF,NEWSNOW,RHONEWSN, & meltfactor,snhei_crit,xlat,xlon real :: rhonewcsn LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: GLW, & GSW, & RHO, & @@ -4038,35 +3899,35 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & TKMS !--- sea ice properties - REAL, DIMENSION(1:NZS) , & + real (kind=kind_phys), DIMENSION(1:NZS) , & INTENT(IN ) :: & tice, & rhosice, & capice, & thdifice - REAL, INTENT(IN ) :: & + real (kind=kind_phys), INTENT(IN ) :: & CW, & XLV - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & - ZSHALF, & - DTDZS2 + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + ZSHALF, & + DTDZS2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO INTEGER, INTENT(INOUT) :: ILAND !-------- 2-d variables - REAL , & + real (kind=kind_phys) , & INTENT(INOUT) :: DEW, & EETA, & RHOSN, & @@ -4094,53 +3955,49 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & INTEGER, INTENT(INOUT) :: ILNB - REAL, INTENT(OUT) :: RSM, & - SNWEPRINT, & - SNHEIPRINT + real (kind=kind_phys), INTENT(OUT) :: RSM, & + SNWEPRINT, & + SNHEIPRINT !--- Local variables INTEGER :: nzs1,nzs2,k,k1,kn,kk - REAL :: x,x1,x2,dzstop,ft,tn,denom + real (kind=kind_phys) :: x,x1,x2,dzstop,ft,tn,denom - REAL :: SNTH, NEWSN , & + real (kind=kind_phys) :: SNTH, NEWSN , & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP - REAL :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & + real (kind=kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & epot,fltot,fq,hft,q1,ras,rhoice,ci,cvw , & RIW,DELTSN,H - REAL :: rhocsn,thdifsn, & + real (kind=kind_phys) :: rhocsn,thdifsn, & xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn - REAL :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - REAL :: fso,fsn, & + real (kind=kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn + real (kind=kind_phys) :: fso,fsn, & FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & FKQ,R210,AA,BB,QS1,TS1,TQ2,TX2, & TDENOM,AA1,RHCS,H1,TSOB, SNPRIM, & SNODIF,SOH,TNOLD,QGOLD,SNOHGNEW - REAL, DIMENSION(1:NZS) :: cotso,rhtso + real (kind=kind_phys), DIMENSION(1:NZS) :: cotso,rhtso - REAL :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr + real (kind=kind_phys) :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr integer :: nmelt - REAL :: keff, fact + real (kind=kind_phys) :: keff, fact !----------------------------------------------------------------- XLMELT=3.35E+5 !-- heat of sublimation of water vapor XLVm=XLV+XLMELT -! STBOLT=5.670151E-8 !-- options for snow conductivity: !-- 1 - constant !-- opt 2 - Sturm et al., 1997 - !isncond_opt = 2 keff = 0.265 !--- SNOW flag -- ISICE -! ILAND=isice - !--- DELTSN - is the threshold for splitting the snow layer into 2 layers. !--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm, !--- equivalent to 0.03 m SNWE. For other snow densities the threshold is @@ -4149,13 +4006,8 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !--- the top sea ice layer. SNTH is computed using snwe=0.016 m, and !--- equals 4 cm for snow density 400 kg/m^3. -! increase thickness of top snow layer from 3 cm SWE to 5 cm SWE -! DELTSN=5.*SNHEI_CRIT -! snth=0.4*SNHEI_CRIT - DELTSN=0.05*1.e3/rhosn snth=0.01*1.e3/rhosn -! snth=0.01601*1.e3/rhosn ! For 2-layer snow model when the snow depth is marginlly higher than DELTSN, ! reset DELTSN to half of snow depth. @@ -4179,7 +4031,6 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & RHOnewCSN=2090.* RHOnewSN if(isncond_opt == 1) then - !if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -4202,9 +4053,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 fact = 2. endif - !fact = 1. - !if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -4506,10 +4355,8 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(nmelt.eq.1) go to 220 !--- IF SOILT > 273.15 F then melting of snow can happen -! IF(SOILT.GT.273.15.AND.SNWE.GT.0.) THEN -! if all snow can evaporate, then there is nothing to melt - !IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0..AND.SNHEI.GT.0.) THEN - IF(SOILT.GT.273.15.AND.BETA.EQ.1..AND.SNHEI.GT.0.) THEN +! if all snow can evaporate, then there is nothing to melt + IF(SOILT.GT.273.15.AND.BETA.EQ.1._kind_phys.AND.SNHEI.GT.0._kind_phys) THEN ! nmelt = 1 soiltfrac=snowfrac*273.15+(1.-snowfrac)*min(271.4,SOILT) @@ -4560,19 +4407,17 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & print *,'RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac)', & RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac) ENDIF - SNOH=AMAX1(0.,SNOH) + SNOH=AMAX1(0._kind_phys,SNOH) !-- SMELT is speed of melting in M/S SMELT= SNOH /XLMELT*1.E-3 SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) - SMELT=AMAX1(0.,SMELT) + SMELT=AMAX1(0._kind_phys,SMELT) IF (debug_print ) THEN print *,'1-SMELT i,j',smelt,i,j ENDIF !18apr08 - Egglston limit SMELT= amin1 (smelt,delt/60.* 5.6E-8*meltfactor*max(1.,(soilt-273.15))) ! SnowMIP -! SMELT= amin1 (smelt,delt/60.* 5.6E-8*meltfactor*min(2.,max(0.001,(tabs-273.15))) ! SnowMIP -! SMELT= amin1 (smelt, 5.6E-8*meltfactor*max(1.,(soilt-273.15))) IF (debug_print ) THEN print *,'2-SMELT i,j',smelt,i,j ENDIF @@ -4613,9 +4458,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !-- for evaporation and snow melt SNWE = AMAX1(0.,(SNWEPR- & (SMELT+BETA*EPOT*RAS)*DELT & -! (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & ) ) -!!!! soilt=soiltfrac !--- If there is no snow melting then just evaporation !--- or condensation changes SNWE @@ -4624,7 +4467,6 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & BETA*EPOT*RAS*DELT)) -! BETA*EPOT*RAS*DELT*snowfrac)) else snwe = 0. endif @@ -4651,11 +4493,9 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & xsn=(rhosn*(snwe-rsm)+1.e3*rsm)/ & snwe rhosn=MIN(MAX(58.8,XSN),500.) -!13mar18 rhosn=MIN(MAX(76.9,XSN),500.) RHOCSN=2090.* RHOSN if(isncond_opt == 1) then - ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -4678,9 +4518,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 fact = 2. endif - !fact = 1. - !if(newsn <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -4732,7 +4570,6 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & T3 = STBOLT*TNold*TNold*TNold UPFLUX = T3 *0.5*(SOILT+TNold) XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET HFT=-TKMS*CP*RHO*(TABS-SOILT) HFX=-TKMS*CP*RHO*(TABS-SOILT) & *(P1000mb*0.00001/Patm)**ROVCP @@ -4899,15 +4736,15 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon - REAL, INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon + real (kind=kind_phys), INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: & EMISS, & RHO, & @@ -4920,17 +4757,17 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & TKMS !--- soil properties - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: & BCLH, & DQM, & QMIN - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: & soilres,alfa - REAL, INTENT(IN ) :: CP, & + real (kind=kind_phys), INTENT(IN ) :: CP, & CVW, & XLV, & STBOLT, & @@ -4938,23 +4775,23 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & G0_P - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & THDIF, & CAP - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO !-------- 2-d variables - REAL , & + real (kind=kind_phys) , & INTENT(INOUT) :: & MAVAIL, & QVG, & @@ -4965,16 +4802,16 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & !--- Local variables - REAL :: x,x1,x2,x4,dzstop,can,ft,sph , & + real (kind=kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph , & tn,trans,umveg,denom,fex - REAL :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11 , & + real (kind=kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & TDENOM - REAL :: C,CC,AA1,RHCS,H1, QGOLD + real (kind=kind_phys) :: C,CC,AA1,RHCS,H1, QGOLD - REAL, DIMENSION(1:NZS) :: cotso,rhtso + real (kind=kind_phys), DIMENSION(1:NZS) :: cotso,rhtso INTEGER :: nzs1,nzs2,k,k1,kn,kk, iter @@ -4996,11 +4833,6 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & !****************************************************************************** ! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO !****************************************************************************** -! did=2.*(ZSMAIN(nzs)-ZSHALF(nzs)) -! h1=DTDZS(8)*THDIF(nzs-1)*(ZSHALF(nzs)-ZSHALF(nzs-1))/did -! cotso(1)=h1/(1.+h1) -! rhtso(1)=(tso(nzs)+h1*(tso(nzs-1)-tso(nzs)))/ -! 1 (1.+h1) cotso(1)=0. rhtso(1)=TSO(NZS) DO 33 K=1,NZS2 @@ -5051,7 +4883,6 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & +RAINF*CVW*PRCPMS*max(273.15,TABS) & )/TDENOM AA1=AA+CC -! AA1=AA*alfa+CC PP=PATM*1.E3 AA1=AA1/PP CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) @@ -5061,7 +4892,6 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & IF (debug_print ) THEN print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 ENDIF -!with alfa go to 100 IF(Q1.LT.QS1) GOTO 100 !--- if no saturation - goto 100 !--- if saturation - goto 90 @@ -5084,13 +4914,12 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & print *,'VILKA2 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 ENDIF IF(Q1.GE.QS1) GOTO 90 -!with alfa 100 continue QSG=QS1 QVG=Q1 ! if( QS1>QVATM .and. QVATM > QVG) then -! very dry soil -! print *,'very dry soils mavail,qvg,qs1,qvatm,ts1',i,j,mavail,qvg,qs1,qvatm,ts1 -! QVG = QVATM + ! very dry soil + ! print *,'very dry soils mavail,qvg,qs1,qvatm,ts1',i,j,mavail,qvg,qs1,qvatm,ts1 + ! QVG = QVATM ! endif TSO(1)=TS1 QCG=0. @@ -5098,20 +4927,6 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & IF (debug_print ) THEN print *,'200 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) ENDIF -if(1==2) then - if(qvatm > QSG .and. iter==0) then -!condensation regime - IF (debug_print ) THEN - print *,'turn off canopy evaporation and transpiration' - print *,' QVATM,QVG,QSG,TS1',QVATM,QVG,QSG,TS1 - print *,'before can, umveg ',can,umveg - ENDIF -! can=0. -! umveg=1. - iter=1 -! goto 2111 - endif -endif ! 1==2 IF (debug_print ) THEN if(iter == 1) then print *,'QVATM,QVG,QSG,QCG,TS1',QVATM,QVG,QSG,QCG,TS1 @@ -5227,7 +5042,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & testptlat,testptlon , & @@ -5235,12 +5050,12 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & real :: rhonewcsn !--- 3-D Atmospheric variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: GLW, & GSW, & RHO, & @@ -5250,14 +5065,14 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & TKMS !--- soil properties - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: & BCLH, & DQM, & PSIS, & QMIN - REAL, INTENT(IN ) :: CP, & + real (kind=kind_phys), INTENT(IN ) :: CP, & ROVCP, & CVW, & STBOLT, & @@ -5265,25 +5080,25 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & G0_P - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & THDIF, & CAP, & TRANF - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO !-------- 2-d variables - REAL , & + real (kind=kind_phys) , & INTENT(INOUT) :: DEW, & CST, & RHOSN, & @@ -5303,9 +5118,9 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & SOILT1, & TSNAV - REAL, INTENT(INOUT) :: DRYCAN, WETCAN + real (kind=kind_phys), INTENT(INOUT) :: DRYCAN, WETCAN - REAL, INTENT(OUT) :: RSM, & + real (kind=kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & SNHEIPRINT INTEGER, INTENT(OUT) :: ilnb @@ -5314,16 +5129,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & INTEGER :: nzs1,nzs2,k,k1,kn,kk - REAL :: x,x1,x2,x4,dzstop,can,ft,sph, & + real (kind=kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph, & tn,trans,umveg,denom - REAL :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn + real (kind=kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - REAL :: t3,upflux,xinet,ras, & + real (kind=kind_phys) :: t3,upflux,xinet,ras, & xlmelt,rhocsn,thdifsn, & beta,epot,xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn - REAL :: fso,fsn, & + real (kind=kind_phys) :: fso,fsn, & FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2, & TDENOM,C,CC,AA1,RHCS,H1, & @@ -5331,15 +5146,15 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & smeltg,snohg,snodif,soh, & CMC2MS,TNOLD,QGOLD,SNOHGNEW - REAL, DIMENSION(1:NZS) :: transp,cotso,rhtso - REAL :: edir1, & + real (kind=kind_phys), DIMENSION(1:NZS) :: transp,cotso,rhtso + real (kind=kind_phys) :: edir1, & ec1, & ett1, & eeta, & qfx, & hfx - REAL :: RNET,rsmfrac,soiltfrac,hsn,rr,keff,fact + real (kind=kind_phys) :: RNET,rsmfrac,soiltfrac,hsn,rr,keff,fact integer :: nmelt, iter !----------------------------------------------------------------- @@ -5349,7 +5164,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- options for snow conductivity: !-- 1 - constant !-- opt 2 - Sturm et al., 1997 - !isncond_opt = 1 keff = 0.265 do k=1,nzs @@ -5363,10 +5177,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ENDIF XLMELT=3.35E+5 RHOCSN=2090.* RHOSN -!18apr08 - add rhonewcsn RHOnewCSN=2090.* RHOnewSN if(isncond_opt == 1) then - ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -5397,9 +5209,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,'SNOWTEMP - xlat,xlon,newsnow,rhonewsn,rhosn,fact,keff',xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff endif - !fact = 1. - - ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -5429,7 +5238,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & RSMFRAC = 0. fsn=1. fso=0. -! hsn=snhei NZS1=NZS-1 NZS2=NZS-2 @@ -5440,12 +5248,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !****************************************************************************** ! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO !****************************************************************************** -! did=2.*(ZSMAIN(nzs)-ZSHALF(nzs)) -! h1=DTDZS(8)*THDIF(nzs-1)*(ZSHALF(nzs)-ZSHALF(nzs-1))/did -! cotso(1)=h1/(1.+h1) -! rhtso(1)=(tso(nzs)+h1*(tso(nzs-1)-tso(nzs)))/ -! 1 (1.+h1) - cotso(1)=0. rhtso(1)=TSO(NZS) DO 33 K=1,NZS2 @@ -5518,7 +5320,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & endif ENDIF IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then -! IF(SNHEI.LT.SNTH.AND.SNHEI.GE.0.) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first soil layer. snprim=SNHEI+zsmain(2) @@ -5691,10 +5492,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,' QVATM,QVG,QSG,TS1',QVATM,QVG,QSG,TS1 print *,'before can, umveg ',can, umveg ENDIF -! can=0. -! umveg=1. iter=1 -! goto 2211 endif IF (debug_print ) THEN @@ -5747,7 +5545,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & TSO(1)=SOILT SOILT1=SOILT tsob=TSO(1) -!new tsob=tso(2) ENDIF if(nmelt==1.and.snowfrac==1) then !-- second iteration with full snow cover @@ -5789,7 +5586,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & if(nmelt.eq.1) go to 220 !--- IF SOILT > 273.15 F then melting of snow can happen -! IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN ! if all snow can evaporate (beta<1), then there is nothing to melt IF(SOILT.GT.273.15.AND.BETA.EQ.1.AND.SNHEI.GT.0.) THEN !-- snow sublimation and melting @@ -5800,7 +5596,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & T3 = STBOLT*TN*TN*TN UPFLUX = T3 * 0.5*(TN + SOILTfrac) XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS @@ -5819,7 +5614,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & DO K=1,NROOT TRANSP(K)=-VEGFRAC*q1 & *TRANF(K)*DRYCAN/zshalf(NROOT+1) -! IF(TRANSP(K).GT.0.) TRANSP(K)=0. ETT1=ETT1-TRANSP(K) ENDDO DO k=nroot+1,nzs @@ -5829,7 +5623,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & EDIR1 = Q1*UMVEG * BETA EC1 = Q1 * WETCAN * vegfrac CMC2MS=CST/DELT*RAS -! EC1=MIN(CMC2MS,EC1) EETA = (EDIR1 + EC1 + ETT1)*1.E3 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ QFX= XLVM * EETA @@ -5884,7 +5677,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- (rhosn > 350.) with very warm surface temperatures (>10C) if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*max(1.,(soilt-273.15))) -! SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*min(2.,max(0.001,(tabs-273.15))) ! SnowMIP IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'3- SMELT',xlat,xlon,smelt,rhosn,rhonewsn,xlat,xlon @@ -5986,11 +5778,9 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & xsn=(rhosn*(snwe-rsm)+1.e3*rsm)/ & snwe rhosn=MIN(MAX(58.8,XSN),500.) -! rhosn=MIN(MAX(76.9,XSN),500.) RHOCSN=2090.* RHOSN if(isncond_opt == 1) then - !if(newsnow<= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -6022,9 +5812,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff,keff/rhocsn*fact endif - !fact = 1. - - ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -6229,12 +6016,12 @@ SUBROUTINE SOILMOIST ( debug_print, & !------------------------------------------------------------------ !--- input variables LOGICAL, INTENT(IN ) :: debug_print - REAL, INTENT(IN ) :: DELT + real (kind=kind_phys), INTENT(IN ) :: DELT INTEGER, INTENT(IN ) :: NZS,NDDZS ! input variables - REAL, DIMENSION(1:NZS), INTENT(IN ) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN ) :: ZSMAIN, & ZSHALF, & DIFFU, & HYDRO, & @@ -6242,33 +6029,33 @@ SUBROUTINE SOILMOIST ( debug_print, & SOILICE, & DTDZS2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM , & + real (kind=kind_phys), INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM, & QKMS,VEGFRAC,DRIP,PRCP , & DEW,SMELT,SNOWFRAC , & DQM,QMIN,REF,KSAT,RAS,RIW,SOILRES ! output - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: SOILMOIS,SOILIQW - REAL, INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & + real (kind=kind_phys), INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & INFMAX ! local variables - REAL, DIMENSION( 1:nzs ) :: COSMC,RHSMC + real (kind=kind_phys), DIMENSION( 1:nzs ) :: COSMC,RHSMC - REAL :: DZS,R1,R2,R3,R4,R5,R6,R7,R8,R9,R10 - REAL :: REFKDT,REFDK,DELT1,F1MAX,F2MAX - REAL :: F1,F2,FD,KDT,VAL,DDT,PX,FK,FKMAX - REAL :: QQ,UMVEG,INFMAX1,TRANS - REAL :: TOTLIQ,FLX,FLXSAT,QTOT - REAL :: DID,X1,X2,X4,DENOM,Q2,Q4 - REAL :: dice,fcr,acrt,frzx,sum,cvfrz + real (kind=kind_phys) :: DZS,R1,R2,R3,R4,R5,R6,R7,R8,R9,R10 + real (kind=kind_phys) :: REFKDT,REFDK,DELT1,F1MAX,F2MAX + real (kind=kind_phys) :: F1,F2,FD,KDT,VAL,DDT,PX,FK,FKMAX + real (kind=kind_phys) :: QQ,UMVEG,INFMAX1,TRANS + real (kind=kind_phys) :: TOTLIQ,FLX,FLXSAT,QTOT + real (kind=kind_phys) :: DID,X1,X2,X4,DENOM,Q2,Q4 + real (kind=kind_phys) :: dice,fcr,acrt,frzx,sum,cvfrz INTEGER :: NZS1,NZS2,K,KK,K1,KN,ialp1,jj,jk @@ -6288,45 +6075,23 @@ SUBROUTINE SOILMOIST ( debug_print, & DID=(ZSMAIN(NZS)-ZSHALF(NZS)) X1=ZSMAIN(NZS)-ZSMAIN(NZS1) -!7may09 DID=(ZSMAIN(NZS)-ZSHALF(NZS))*2. -! DENOM=DID/DELT+DIFFU(NZS1)/X1 -! COSMC(1)=DIFFU(NZS1)/X1/DENOM -! RHSMC(1)=(SOILMOIS(NZS)*DID/DELT -! 1 +TRANSP(NZS)-(HYDRO(NZS)*SOILMOIS(NZS) -! 1 -HYDRO(NZS1)*SOILMOIS(NZS1))*DID -! 1 /X1) /DENOM - DENOM=(1.+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/(2.*DID)*DELT) COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & +HYDRO(NZS1)/2./DID)/DENOM RHSMC(1)=(SOILMOIS(NZS)+TRANSP(NZS)*DELT/ & DID)/DENOM -! RHSMC(1)=(SOILMOIS(NZS)*DID/DELT & -! +TRANSP(NZS)-(HYDRO(NZS)*SOILMOIS(NZS) & -! -HYDRO(NZS1)*SOILMOIS(NZS1))*DID & -! /X1) /DENOM - !12 June 2014 - low boundary condition: 1 - zero diffusion below the lowest ! level; 2 - soil moisture at the low boundary can be lost due to the root uptake. ! So far - no interaction with the water table. DENOM=1.+DIFFU(nzs1)/X1/DID*DELT -!orig DENOM=(1.+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/DID*DELT) -!orig COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & -!orig +HYDRO(NZS1)/2./DID)/DENOM COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & +HYDRO(NZS1)/DID)/DENOM -! RHSMC(1)=(SOILMOIS(NZS)+TRANSP(NZS)*DELT/ & -! DID)/DENOM - RHSMC(1)=(SOILMOIS(NZS)-HYDRO(NZS)*DELT/DID*soilmois(nzs) & +TRANSP(NZS)*DELT/DID)/DENOM -!test RHSMC(1)=SOILMOIS(NZS)-HYDRO(NZS)*soilmois(nzs) -!test!!! -!this test gave smoother soil moisture, ovwerall better results COSMC(1)=0. RHSMC(1)=SOILMOIS(NZS) ! @@ -6370,26 +6135,21 @@ SUBROUTINE SOILMOIST ( debug_print, & 191 format (f23.19) -! TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT - TOTLIQ=PRCP-DRIP/DELT-(1.-VEGFRAC)*DEW*RAS-SMELT IF (debug_print ) THEN print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT ENDIF -!test 16 may TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT -!30july13 TOTLIQ=UMVEG*PRCP-DRIP/DELT-SMELT - FLX=TOTLIQ INFILTRP=TOTLIQ ! ----------- FROZEN GROUND VERSION ------------------------- ! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF -! AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. +! Areal (kind=kind_phys) DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. ! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. -! BASED ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT -! CLOSE TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. +! BASED ON FIELD DATA CV DEPENDS ON Areal (kind=kind_phys) MEAN OF FROZEN DEPTH, AND IT +! CLOSE TO CONSTANT = 0.6 IF Areal (kind=kind_phys) MEAN FROZEN DEPTH IS ABOVE 20 CM. ! THAT IS WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}) ! ! Current logic doesn't allow CVFRZ be bigger than 3 @@ -6473,7 +6233,6 @@ SUBROUTINE SOILMOIST ( debug_print, & FLX=FLX-SOILMOIS(1)*R7 ! R8 is for direct evaporation from soil, which occurs ! only from snow-free areas -! R8=UMVEG*R6 R8=UMVEG*R6*(1.-snowfrac) QTOT=QVATM+QCATM R9=TRANS @@ -6500,7 +6259,6 @@ SUBROUTINE SOILMOIST ( debug_print, & IF (debug_print ) THEN print *,'FLXSAT,FLX,DELT',FLXSAT,FLX,DELT,RUNOFF2 ENDIF -! RUNOFF2=(FLXSAT-FLX) RUNOFF=RUNOFF+(FLXSAT-FLX) ELSE SOILMOIS(1)=min(dqm,max(1.e-8,QQ)) @@ -6515,11 +6273,8 @@ SUBROUTINE SOILMOIST ( debug_print, & DO K=2,NZS KK=NZS-K+1 QQ=COSMC(KK)*SOILMOIS(K-1)+RHSMC(KK) -! QQ=COSMC(KK)*SOILIQW(K-1)+RHSMC(KK) IF (QQ.LT.0.) THEN -! print *,'negative QQ=',qq - SOILMOIS(K)=1.e-8 ELSE IF(QQ.GT.DQM) THEN !-- saturation @@ -6529,12 +6284,8 @@ SUBROUTINE SOILMOIST ( debug_print, & print *,'hydro(k),QQ,DQM,k',hydro(k),QQ,DQM,k ENDIF RUNOFF2=RUNOFF2+((QQ-DQM)*(ZSMAIN(K)-ZSHALF(K)))/DELT -! RUNOFF2=RUNOFF2+(QQ-DQM)*hydro(k) -! print *,'RUNOFF2=',RUNOFF2 ELSE -! print *,'QQ,DQM,k',QQ,DQM,k RUNOFF2=RUNOFF2+((QQ-DQM)*(ZSHALF(K+1)-ZSHALF(K)))/DELT -! RUNOFF2=RUNOFF2+(QQ-DQM)*hydro(k) ENDIF ELSE SOILMOIS(K)=min(dqm,max(1.e-8,QQ)) @@ -6544,13 +6295,7 @@ SUBROUTINE SOILMOIST ( debug_print, & print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw ENDIF -! RUNOFF2=RUNOFF2+hydro(nzs)*SOILMOIS(NZS) -! MAVAIL=max(.00001,min(1.,SOILMOIS(1)/DQM)) -! MAVAIL=max(.00001,min(1.,SOILMOIS(1)/(REF-QMIN))) MAVAIL=max(.00001,min(1.,(SOILMOIS(1)/(REF-QMIN)*(1.-snowfrac)+1.*snowfrac))) - -! RETURN -! END !------------------------------------------------------------------- END SUBROUTINE SOILMOIST !------------------------------------------------------------------- @@ -6592,7 +6337,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- soil properties LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: NZS - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -6601,12 +6346,12 @@ SUBROUTINE SOILPROP( debug_print, & QWRTZ, & QMIN - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(IN ) :: SOILMOIS, & keepfr - REAL, INTENT(IN ) :: CP, & + real (kind=kind_phys), INTENT(IN ) :: CP, & CVW, & RIW, & kqwrtz, & @@ -6618,7 +6363,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- output variables - REAL, DIMENSION(1:NZS) , & + real (kind=kind_phys), DIMENSION(1:NZS) , & INTENT(INOUT) :: cap,diffu,hydro , & thdif,tav , & soilmoism , & @@ -6627,14 +6372,14 @@ SUBROUTINE SOILPROP( debug_print, & fwsat,lwsat !--- local variables - REAL, DIMENSION(1:NZS) :: hk,detal,kasat,kjpl + real (kind=kind_phys), DIMENSION(1:NZS) :: hk,detal,kasat,kjpl - REAL :: x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci - REAL :: tln,tavln,tn,pf,a,am,ame,h + real (kind=kind_phys) :: x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci + real (kind=kind_phys) :: tln,tavln,tn,pf,a,am,ame,h INTEGER :: nzs1,k !-- for Johansen thermal conductivity - REAL :: kzero,gamd,kdry,kas,x5,sr,ke + real (kind=kind_phys) :: kzero,gamd,kdry,kas,x5,sr,ke nzs1=nzs-1 @@ -6657,7 +6402,6 @@ SUBROUTINE SOILPROP( debug_print, & !--- Next 3 lines are for Johansen thermal conduct. gamd=(1.-ws)*2700. kdry=(0.135*gamd+64.7)/(2700.-0.947*gamd) - !kas=kqwrtz**qwrtz*kzero**(1.-qwrtz) !-- one more option from Christa's paper if(qwrtz > 0.2) then kas=kqwrtz**qwrtz*kzero**(1.-qwrtz) @@ -6701,9 +6445,6 @@ SUBROUTINE SOILPROP( debug_print, & if(soilicem(k).eq.0.) then sr=max(0.101,x5) ke=log10(sr)+1. -!--- next 2 lines - for coarse soils -! sr=max(0.0501,x5) -! ke=0.7*log10(sr)+1. else ke=x5 endif @@ -6727,15 +6468,11 @@ SUBROUTINE SOILPROP( debug_print, & if(a.ne.0.)facd=1.-a/max(1.e-8,soilmoism(K)) ame=max(1.e-8,ws-riw*soilicem(K)) !--- DIFFU is diffusional conductivity of soil water - diffu(K)=-BCLH*KSAT*PSIS/ame* & + diffu(K)=-BCLH*KSAT*PSIS/ame* & (ws/ame)**3. & *H**(BCLH+2.)*facd endif -! diffu(K)=-BCLH*KSAT*PSIS/dqm & -! *H**(BCLH+2.) - - !--- thdif - thermal diffusivity ! thdif(K)=HK(K)/CAP(K) !--- Use thermal conductivity from Johansen (1975) @@ -6756,7 +6493,7 @@ SUBROUTINE SOILPROP( debug_print, & fach=1.-riw*soilice(k)/max(1.e-8,soilmois(k)) am=max(1.e-8,ws-riw*soilice(k)) !--- HYDRO is hydraulic conductivity of soil water - hydro(K)=min(KSAT,KSAT/am* & + hydro(K)=min(KSAT,KSAT/am* & (soiliqw(K)/am) & **(2.*BCLH+2.) & * fach) @@ -6768,9 +6505,6 @@ SUBROUTINE SOILPROP( debug_print, & print *,'hydro=',hydro ENDIF -! RETURN -! END - !----------------------------------------------------------------------- END SUBROUTINE SOILPROP !----------------------------------------------------------------------- @@ -6800,31 +6534,31 @@ SUBROUTINE TRANSF( debug_print, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: nroot,nzs,iland - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: GSWin, TABS, lai !--- soil properties - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: DQM, & QMIN, & REF, & PC, & WILT - REAL, DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & ZSHALF !-- output - REAL, DIMENSION(1:NZS), INTENT(OUT) :: TRANF - REAL, INTENT(OUT) :: TRANSUM + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: TRANF + real (kind=kind_phys), INTENT(OUT) :: TRANSUM !-- local variables - REAL :: totliq, did + real (kind=kind_phys) :: totliq, did INTEGER :: k !-- for non-linear root distribution - REAL :: gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4 - REAL :: FTEM, PCtot, fsol, f1, cmin, cmax, totcnd - REAL, DIMENSION(1:NZS) :: PART + real (kind=kind_phys) :: gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4 + real (kind=kind_phys) :: FTEM, PCtot, fsol, f1, cmin, cmax, totcnd + real (kind=kind_phys), DIMENSION(1:NZS) :: PART !-------------------------------------------------------------------- do k=1,nzs @@ -6895,7 +6629,6 @@ SUBROUTINE TRANSF( debug_print, & ! pctot=min(0.8,max(pc,pc*lai)) endif IF ( debug_print ) THEN -! if (i==421.and.j==280) then print *,'pctot,lai,pc',pctot,lai,pc ENDIF !--- @@ -6907,7 +6640,6 @@ SUBROUTINE TRANSF( debug_print, & FTEM = 1.0 / (1.0 + EXP(0.5 * (TABS - 314.0))) ENDIF IF ( debug_print ) THEN -! if (i==421.and.j==280) then print *,'tabs,ftem',tabs,ftem ENDIF !--- incoming solar function @@ -6933,14 +6665,12 @@ SUBROUTINE TRANSF( debug_print, & fsol = 1. endif IF ( debug_print ) THEN -! if (i==421.and.j==280) then print *,'GSWin,lai,f1,fsol',gswin,lai,f1,fsol ENDIF !--- total conductance totcnd =(cmin + (cmax - cmin)*pctot*ftem*fsol)/cmax IF ( debug_print ) THEN -! if (i==421.and.j==280) then print *,'iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd' & ,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd ENDIF @@ -6953,7 +6683,6 @@ SUBROUTINE TRANSF( debug_print, & transum=transum+tranf(k) END DO IF ( debug_print ) THEN -! if (i==421.and.j==280) then print *,'transum,TRANF',transum,tranf endif @@ -6970,13 +6699,13 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) !--- VILKA finds the solution of energy budget at the surface !--- using table T,QS computed from Clausius-Klapeiron !-------------------------------------------------------------- - REAL, DIMENSION(1:5001), INTENT(IN ) :: TT - REAL, INTENT(IN ) :: TN,D1,D2,PP,xlat,xlon + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN ) :: TT + real (kind=kind_phys), INTENT(IN ) :: TN,D1,D2,PP,xlat,xlon INTEGER, INTENT(IN ) :: NSTEP,ii,j,iland,isoil - REAL, INTENT(OUT ) :: QS, TS + real (kind=kind_phys), INTENT(OUT ) :: QS, TS - REAL :: F1,T1,T2,RN + real (kind=kind_phys) :: F1,T1,T2,RN INTEGER :: I,I1 I=(TN-1.7315E2)/.05+1 @@ -6995,12 +6724,9 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) TS=T1-.05*RN QS=(TT(I)+(TT(I)-TT(I+1))*RN)/PP GOTO 20 -! 1 PRINT *,'Crash in surface energy budget - STOP' 1 PRINT *,' AVOST IN VILKA Table index= ',I -! PRINT *,TN,D1,D2,PP,NSTEP,I,TT(i),ii,j,iland,isoil print *,'I,J=',ii,j,'LU_index = ',iland, 'Psfc[hPa] = ',pp, 'Tsfc = ',tn print *,'AVOST point at xlat/xlon=',xlat,xlon -! CALL wrf_error_fatal (' Crash in surface energy budget ' ) 20 CONTINUE !----------------------------------------------------------------------- END SUBROUTINE VILKA @@ -7071,7 +6797,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & ! 19 White Sand ! !---------------------------------------------------------------------- - REAL LQMA(nsoilclas),LRHC(nsoilclas), & + real (kind=kind_phys) LQMA(nsoilclas),LRHC(nsoilclas), & LPSI(nsoilclas),LQMI(nsoilclas), & LBCL(nsoilclas),LKAS(nsoilclas), & LWIL(nsoilclas),LREF(nsoilclas), & @@ -7208,7 +6934,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & !---- Below are the arrays for the vegetation parameters - REAL LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & + real (kind=kind_phys) LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & LROU(nvegclas),LTHI(nvegclas),LSIG(nvegclas), & LPC(nvegclas) @@ -7224,8 +6950,6 @@ SUBROUTINE SOILVEGIN ( debug_print, & .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95, & .85,.85,.90 / !-- Roughness length is changed for forests and some others -! DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.8,.85, & -! 2.0,1.0,.563,.0001,.2,.4,.05,.1,.15,.1,.065,.05/ DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, & .5,.5,.5,.0001,.2,.4,.05,.1,.15,.1,.065,.05, & .01,.15,.01 / @@ -7235,14 +6959,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & ! !---- still needs to be corrected ! -! DATA LPC/ 15*.8,0.,.8,.8,.5,.5,.5,.5,.5,.0/ DATA LPC /0.4,0.3,0.4,0.4,0.4,0.4,0.4,0.4,0.4,0.4,5*0.55,0.,0.55,0.55, & 0.3,0.3,0.4,0.4,0.3,0.,.3,0.,0./ - -! used in RUC DATA LPC /0.6,6*0.8,0.7,0.75,6*0.8,0.,0.8,0.8, & -! 0.5,0.7,0.6,0.7,0.5,0./ - - !*************************************************************************** @@ -7251,24 +6969,24 @@ SUBROUTINE SOILVEGIN ( debug_print, & ISLTYP LOGICAL, INTENT(IN ) :: myj - REAL, INTENT(IN ) :: SHDMAX - REAL, INTENT(IN ) :: SHDMIN - REAL, INTENT(IN ) :: VEGFRAC - REAL, DIMENSION( 1:NLCAT ), INTENT(IN):: LUFRAC - REAL, DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC + real (kind=kind_phys), INTENT(IN ) :: SHDMAX + real (kind=kind_phys), INTENT(IN ) :: SHDMIN + real (kind=kind_phys), INTENT(IN ) :: VEGFRAC + real (kind=kind_phys), DIMENSION( 1:NLCAT ), INTENT(IN):: LUFRAC + real (kind=kind_phys), DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC - REAL , & + real (kind=kind_phys) , & INTENT ( OUT) :: pc, & msnf, & facsnf - REAL , & + real (kind=kind_phys) , & INTENT (INOUT ) :: emiss, & lai, & znt LOGICAL, intent(in) :: rdlai2d !--- soil properties - REAL , & + real (kind=kind_phys) , & INTENT( OUT) :: RHOCS, & BCLH, & DQM, & @@ -7281,25 +6999,15 @@ SUBROUTINE SOILVEGIN ( debug_print, & INTEGER, INTENT ( OUT) :: iforest character(len=*),intent(out) :: errmsg integer, intent(out) :: errflg -! INTEGER, DIMENSION( 1:(lucats) ) , & -! INTENT ( OUT) :: iforest - - -! INTEGER, DIMENSION( 1:50 ) :: if1 INTEGER :: kstart, kfin, lstart, lfin INTEGER :: k - REAL :: area, factor, znt1, lb - REAL, DIMENSION( 1:NLCAT ) :: ZNTtoday, LAItoday, deltalai + real (kind=kind_phys) :: area, factor, znt1, lb + real (kind=kind_phys), DIMENSION( 1:NLCAT ) :: ZNTtoday, LAItoday, deltalai !*********************************************************************** ! DATA ZS1/0.0,0.05,0.20,0.40,1.6,3.0/ ! o - levels in soil ! DATA ZS2/0.0,0.025,0.125,0.30,1.,2.3/ ! x - levels in soil -! DATA IF1/12*0,1,1,1,12*0/ - -! do k=1,LUCATS -! iforest(k)=if1(k) -! enddo ! Initialize error-handling errflg = 0 @@ -7344,7 +7052,6 @@ SUBROUTINE SOILVEGIN ( debug_print, & endif else LAItoday(k) = LAITBL(K) -! ZNTtoday(k) = Z0TBL(K) ZNTtoday(k) = ZNT ! do not overwrite z0 over water with the table value endif enddo @@ -7429,7 +7136,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & if(mosaic_soil == 1 ) then do k = 1, nscat if(k.ne.14) then ! STATSGO value for water -!exclude watrer points from this loop + !exclude water points from this loop AREA = AREA + soilfrac(k) RHOCS = RHOCS + HC(k)*1.E6*soilfrac(k) BCLH = BCLH + BB(K)*soilfrac(k) @@ -7484,18 +7191,6 @@ SUBROUTINE SOILVEGIN ( debug_print, & QWRTZ = QTZ(ISLTYP) endif endif -! print *,'rhocs,dqm,qmin,qwrtz',j,rhocs,dqm,qmin,qwrtz - -! parameters from the look-up tables -! BCLH = LBCL(ISLTYP) -! DQM = LQMA(ISLTYP)- & -! LQMI(ISLTYP) -! KSAT = LKAS(ISLTYP) -! PSIS = - LPSI(ISLTYP) -! QMIN = LQMI(ISLTYP) -! REF = LREF(ISLTYP) -! WILT = LWIL(ISLTYP) -! QWRTZ = DATQTZ(ISLTYP) !-------------------------------------------------------------------------- END SUBROUTINE SOILVEGIN @@ -7518,33 +7213,33 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & #endif IMPLICIT NONE LOGICAL, INTENT(IN ) :: debug_print - REAL, DIMENSION( ims:ime), INTENT(IN ) :: landfrac, fice - REAL, INTENT(IN ) :: min_seaice + real (kind=kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: landfrac, fice + real (kind=kind_phys), INTENT(IN ) :: min_seaice INTEGER, INTENT(IN ) :: & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & nzs - REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ), & INTENT(IN) :: TSLB, & SMOIS INTEGER, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: ISLTYP,IVGTYP - REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , & INTENT(OUT) :: SMFR3D, & SH2O - REAL, DIMENSION( ims:ime, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: MAVAIL !-- local - REAL, DIMENSION ( 1:nzs ) :: SOILIQW + real (kind=kind_phys), DIMENSION ( 1:nzs ) :: SOILIQW INTEGER :: I,J,L,itf,jtf - REAL :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH + real (kind=kind_phys) :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH INTEGER :: errflag @@ -7600,7 +7295,6 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & soiliqw(l)=(dqm+qmin)*(XLMELT* & (tslb(i,l,j)-273.15)/tslb(i,l,j)/9.81/psis) & **(-1./bclh) - !**(-1./bclh)-qmin soiliqw(l)=max(0.,soiliqw(l)) soiliqw(l)=min(soiliqw(l),smois(i,l,j)) sh2o(i,l,j)=soiliqw(l) @@ -7636,21 +7330,6 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & END SUBROUTINE ruclsminit ! -!----------------------------------------------------------------- -! SUBROUTINE RUCLSM_PARM_INIT -!----------------------------------------------------------------- - -! character*9 :: MMINLU, MMINSL - -! MMINLU='MODIS-RUC' -! MMINLU='USGS-RUC' -! MMINSL='STAS-RUC' -! call RUCLSM_SOILVEGPARM( MMINLU, MMINSL) - -!----------------------------------------------------------------- -! END SUBROUTINE RUCLSM_PARM_INIT -!----------------------------------------------------------------- - !----------------------------------------------------------------- !>\ingroup lsm_ruc_group !> This subroutine specifies vegetation related characteristics. @@ -7796,34 +7475,6 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) ! CALL wrf_error_fatal ("Land Use Dataset '"//MMINLURUC//"' not found in VEGPARM.TBL.") ENDIF -! END IF - -! CALL wrf_dm_bcast_string ( LUTYPE , 8 ) -! CALL wrf_dm_bcast_integer ( LUCATS , 1 ) -! CALL wrf_dm_bcast_integer ( IINDEX , 1 ) -! CALL wrf_dm_bcast_integer ( LUMATCH , 1 ) -! CALL wrf_dm_bcast_real ( ALBTBL , NLUS ) -! CALL wrf_dm_bcast_real ( Z0TBL , NLUS ) -! CALL wrf_dm_bcast_real ( LEMITBL , NLUS ) -! CALL wrf_dm_bcast_real ( PCTBL , NLUS ) -! CALL wrf_dm_bcast_real ( SHDTBL , NLUS ) -! CALL wrf_dm_bcast_real ( IFORTBL , NLUS ) -! CALL wrf_dm_bcast_real ( RSTBL , NLUS ) -! CALL wrf_dm_bcast_real ( RGLTBL , NLUS ) -! CALL wrf_dm_bcast_real ( HSTBL , NLUS ) -! CALL wrf_dm_bcast_real ( SNUPTBL , NLUS ) -! CALL wrf_dm_bcast_real ( LAITBL , NLUS ) -! CALL wrf_dm_bcast_real ( MAXALB , NLUS ) -! CALL wrf_dm_bcast_real ( TOPT_DATA , 1 ) -! CALL wrf_dm_bcast_real ( CMCMAX_DATA , 1 ) -! CALL wrf_dm_bcast_real ( CFACTR_DATA , 1 ) -! CALL wrf_dm_bcast_real ( RSMAX_DATA , 1 ) -! CALL wrf_dm_bcast_integer ( BARE , 1 ) -! CALL wrf_dm_bcast_integer ( NATURAL , 1 ) -! CALL wrf_dm_bcast_integer ( CROP , 1 ) -! CALL wrf_dm_bcast_integer ( URBAN , 1 ) - -! !-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL ! ! IF ( wrf_dm_on_monitor() ) THEN @@ -7888,23 +7539,6 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) 2003 CONTINUE CLOSE (19) -! ENDIF - -! CALL wrf_dm_bcast_integer ( LUMATCH , 1 ) -! CALL wrf_dm_bcast_string ( SLTYPE , 8 ) -! CALL wrf_dm_bcast_string ( MMINSL , 8 ) ! since this is reset above, see oct2 ^ -! CALL wrf_dm_bcast_integer ( SLCATS , 1 ) -! CALL wrf_dm_bcast_integer ( IINDEX , 1 ) -! CALL wrf_dm_bcast_real ( BB , NSLTYPE ) -! CALL wrf_dm_bcast_real ( DRYSMC , NSLTYPE ) -! CALL wrf_dm_bcast_real ( HC , NSLTYPE ) -! CALL wrf_dm_bcast_real ( MAXSMC , NSLTYPE ) -! CALL wrf_dm_bcast_real ( REFSMC , NSLTYPE ) -! CALL wrf_dm_bcast_real ( SATPSI , NSLTYPE ) -! CALL wrf_dm_bcast_real ( SATDK , NSLTYPE ) -! CALL wrf_dm_bcast_real ( SATDW , NSLTYPE ) -! CALL wrf_dm_bcast_real ( WLTSMC , NSLTYPE ) -! CALL wrf_dm_bcast_real ( QTZ , NSLTYPE ) IF(LUMATCH.EQ.0)THEN print *, 'SOIl TEXTURE IN INPUT FILE DOES NOT ' @@ -7915,7 +7549,6 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) ! !-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL ! -! IF ( wrf_dm_on_monitor() ) THEN OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) IF(ierr .NE. OPEN_OK ) THEN print *,& @@ -7961,23 +7594,6 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) READ (19,*)SMHIGH_DATA !sms$serial end CLOSE (19) -! ENDIF - -! CALL wrf_dm_bcast_integer ( NUM_SLOPE , 1 ) -! CALL wrf_dm_bcast_integer ( SLPCATS , 1 ) -! CALL wrf_dm_bcast_real ( SLOPE_DATA , NSLOPE ) -! CALL wrf_dm_bcast_real ( SBETA_DATA , 1 ) -! CALL wrf_dm_bcast_real ( FXEXP_DATA , 1 ) -! CALL wrf_dm_bcast_real ( CSOIL_DATA , 1 ) -! CALL wrf_dm_bcast_real ( SALP_DATA , 1 ) -! CALL wrf_dm_bcast_real ( REFDK_DATA , 1 ) -! CALL wrf_dm_bcast_real ( REFKDT_DATA , 1 ) -! CALL wrf_dm_bcast_real ( FRZK_DATA , 1 ) -! CALL wrf_dm_bcast_real ( ZBOT_DATA , 1 ) -! CALL wrf_dm_bcast_real ( CZIL_DATA , 1 ) -! CALL wrf_dm_bcast_real ( SMLOW_DATA , 1 ) -! CALL wrf_dm_bcast_real ( SMHIGH_DATA , 1 ) - !----------------------------------------------------------------- END SUBROUTINE RUCLSM_SOILVEGPARM @@ -8018,7 +7634,7 @@ SUBROUTINE SOILIN (ISLTYP, DQM, REF, PSIS, QMIN, BCLH ) integer, intent ( in) :: isltyp real, intent ( out) :: dqm,ref,qmin,psis,bclh - REAL LQMA(nsoilclas),LREF(nsoilclas),LBCL(nsoilclas), & + real (kind=kind_phys) LQMA(nsoilclas),LREF(nsoilclas),LBCL(nsoilclas), & LPSI(nsoilclas),LQMI(nsoilclas) !-- LQMA Rawls et al.[1982] @@ -8066,37 +7682,27 @@ END SUBROUTINE SOILIN !>\ingroup lsm_ruc_group !> This function calculates the liquid saturation vapor mixing ratio as !! a function of temperature and pressure (from Thompson scheme). - REAL FUNCTION RSLF(P,T) + real (kind=kind_phys) FUNCTION RSLF(P,T) IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESL,X - REAL, PARAMETER:: C0= .611583699E03 - REAL, PARAMETER:: C1= .444606896E02 - REAL, PARAMETER:: C2= .143177157E01 - REAL, PARAMETER:: C3= .264224321E-1 - REAL, PARAMETER:: C4= .299291081E-3 - REAL, PARAMETER:: C5= .203154182E-5 - REAL, PARAMETER:: C6= .702620698E-8 - REAL, PARAMETER:: C7= .379534310E-11 - REAL, PARAMETER:: C8=-.321582393E-13 + real (kind=kind_phys), INTENT(IN):: P, T + real (kind=kind_phys):: ESL,X + real (kind=kind_phys), PARAMETER:: C0= .611583699E03 + real (kind=kind_phys), PARAMETER:: C1= .444606896E02 + real (kind=kind_phys), PARAMETER:: C2= .143177157E01 + real (kind=kind_phys), PARAMETER:: C3= .264224321E-1 + real (kind=kind_phys), PARAMETER:: C4= .299291081E-3 + real (kind=kind_phys), PARAMETER:: C5= .203154182E-5 + real (kind=kind_phys), PARAMETER:: C6= .702620698E-8 + real (kind=kind_phys), PARAMETER:: C7= .379534310E-11 + real (kind=kind_phys), PARAMETER:: C8=-.321582393E-13 X=MAX(-80.,T-273.16) -! print *,'rslfmp',p,t,x -! ESL=612.2*EXP(17.67*X/(T-29.65)) ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) ESL=MIN(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. RSLF=.622*ESL/max(1.e-4,(P-ESL)) -! ALTERNATIVE -! ; Source: Murphy and Koop, Review of the vapour pressure of ice and -! supercooled water for atmospheric applications, Q. J. R. -! Meteorol. Soc (2005), 131, pp. 1539-1565. -! ESL = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T -! + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22 -! / T - 9.44523 * ALOG(T) + 0.014025 * T)) - END FUNCTION RSLF From 5f43b2b20365edd3055590f409bc7c33eebc6b8e Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 17 Mar 2023 19:51:42 +0000 Subject: [PATCH 06/28] Address reviewers comments in the RUC LSM driver. --- physics/lsm_ruc.F90 | 321 ++++++++++++++++++++------------------------ 1 file changed, 148 insertions(+), 173 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 9215a0ae1..a8afa7f92 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -3,7 +3,7 @@ module lsm_ruc - use machine, only: kind_phys + use machine, only: kind_phys, kind_dbl_prec use namelist_soilveg_ruc use set_soilveg_ruc_mod, only: set_soilveg_ruc @@ -16,8 +16,8 @@ module lsm_ruc public :: lsm_ruc_init, lsm_ruc_run, lsm_ruc_finalize - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys - real(kind=kind_phys), dimension (2), parameter, private :: d = (/0.1,0.25/) + real(kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys + real(kind_phys), dimension (2), parameter, private :: d = (/0.1,0.25/) integer, dimension(20), parameter, private:: & istwe = (/1,1,1,1,1,2,2,1,1,2,2,2,2,2,1,2,2,1,2,2/) ! IGBP 20 classes @@ -57,60 +57,60 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & integer, intent(in) :: kice integer, intent(in) :: nlev integer, intent(in) :: lsm_ruc, lsm - real (kind=kind_phys),intent(in) :: con_fvirt - real (kind=kind_phys),intent(in) :: con_rd + real (kind_phys),intent(in) :: con_fvirt + real (kind_phys),intent(in) :: con_rd - real (kind=kind_phys), dimension(:), intent(in) :: slmsk + real (kind_phys), dimension(:), intent(in) :: slmsk integer, dimension(:), intent(in) :: stype integer, dimension(:), intent(in) :: vtype - real (kind=kind_phys), dimension(:), intent(in) :: landfrac - real (kind=kind_phys), dimension(:), intent(in) :: q1 - real (kind=kind_phys), dimension(:), intent(in) :: prsl1 - real (kind=kind_phys), dimension(:), intent(in) :: tsfc_lnd - real (kind=kind_phys), dimension(:), intent(in) :: tsfc_ice - real (kind=kind_phys), dimension(:), intent(in) :: tsfc_wat - real (kind=kind_phys), dimension(:), intent(in) :: tg3 - real (kind=kind_phys), dimension(:), intent(in) :: sncovr_lnd - real (kind=kind_phys), dimension(:), intent(in) :: sncovr_ice - real (kind=kind_phys), dimension(:), intent(in) :: snoalb - real (kind=kind_phys), dimension(:), intent(in) :: fice - real (kind=kind_phys), dimension(:), intent(in) :: facsf - real (kind=kind_phys), dimension(:), intent(in) :: facwf - real (kind=kind_phys), dimension(:), intent(in) :: alvsf - real (kind=kind_phys), dimension(:), intent(in) :: alvwf - real (kind=kind_phys), dimension(:), intent(in) :: alnsf - real (kind=kind_phys), dimension(:), intent(in) :: alnwf - - real (kind=kind_phys), dimension(:,:), intent(in) :: smc,slc,stc - real (kind=kind_phys), intent(in) :: min_seaice + real (kind_phys), dimension(:), intent(in) :: landfrac + real (kind_phys), dimension(:), intent(in) :: q1 + real (kind_phys), dimension(:), intent(in) :: prsl1 + real (kind_phys), dimension(:), intent(in) :: tsfc_lnd + real (kind_phys), dimension(:), intent(in) :: tsfc_ice + real (kind_phys), dimension(:), intent(in) :: tsfc_wat + real (kind_phys), dimension(:), intent(in) :: tg3 + real (kind_phys), dimension(:), intent(in) :: sncovr_lnd + real (kind_phys), dimension(:), intent(in) :: sncovr_ice + real (kind_phys), dimension(:), intent(in) :: snoalb + real (kind_phys), dimension(:), intent(in) :: fice + real (kind_phys), dimension(:), intent(in) :: facsf + real (kind_phys), dimension(:), intent(in) :: facwf + real (kind_phys), dimension(:), intent(in) :: alvsf + real (kind_phys), dimension(:), intent(in) :: alvwf + real (kind_phys), dimension(:), intent(in) :: alnsf + real (kind_phys), dimension(:), intent(in) :: alnwf + + real (kind_phys), dimension(:,:), intent(in) :: smc,slc,stc + real (kind_phys), intent(in) :: min_seaice ! --- in/out: - real (kind=kind_phys), dimension(:), intent(inout) :: wetness + real (kind_phys), dimension(:), intent(inout) :: wetness ! --- inout - real (kind=kind_phys), dimension(:,:), intent(inout) :: sh2o, smfrkeep - real (kind=kind_phys), dimension(:,:), intent(inout) :: tslb, smois - real (kind=kind_phys), dimension(:), intent(inout) :: semis_lnd - real (kind=kind_phys), dimension(:), intent(inout) :: semis_ice - real (kind=kind_phys), dimension(:), intent(inout) :: & - albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & - albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & - sfcqv_lnd, sfcqv_ice + real (kind_phys), dimension(:,:), intent(inout) :: sh2o, smfrkeep + real (kind_phys), dimension(:,:), intent(inout) :: tslb, smois + real (kind_phys), dimension(:), intent(inout) :: semis_lnd + real (kind_phys), dimension(:), intent(inout) :: semis_ice + real (kind_phys), dimension(:), intent(inout) :: & + albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & + albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & + sfcqv_lnd, sfcqv_ice ! --- out - real (kind=kind_phys), dimension(:), intent(out) :: zs - real (kind=kind_phys), dimension(:), intent(inout) :: sfalb_lnd_bck - real (kind=kind_phys), dimension(:,:), intent(inout) :: tsice - real (kind=kind_phys), dimension(:), intent(out) :: semisbase - real (kind=kind_phys), dimension(:), intent(out) :: pores, resid + real (kind_phys), dimension(:), intent(out) :: zs + real (kind_phys), dimension(:), intent(inout) :: sfalb_lnd_bck + real (kind_phys), dimension(:,:), intent(inout) :: tsice + real (kind_phys), dimension(:), intent(out) :: semisbase + real (kind_phys), dimension(:), intent(out) :: pores, resid character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! --- local - real (kind=kind_phys), dimension(lsoil_ruc) :: dzs - real (kind=kind_phys) :: alb_lnd, alb_ice - real (kind=kind_phys) :: q0, qs1 + real (kind_phys), dimension(lsoil_ruc) :: dzs + real (kind_phys) :: alb_lnd, alb_ice + real (kind_phys) :: q0, qs1 integer :: ipr, i, k logical :: debug_print @@ -367,8 +367,8 @@ subroutine lsm_ruc_run & ! inputs implicit none ! --- constant parameters: - real(kind=kind_phys), parameter :: rhoh2o = 1000.0 - real(kind=kind_phys), parameter :: stbolt = 5.670400e-8 + real(kind_phys), parameter :: rhoh2o = 1000.0 + real(kind_phys), parameter :: stbolt = 5.670400e-8 ! --- input: integer, intent(in) :: me, master @@ -377,10 +377,10 @@ subroutine lsm_ruc_run & ! inputs integer, intent(in) :: lsm_ruc, lsm integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_nssl - real (kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlon_d - real (kind=kind_phys), dimension(:), intent(in) :: oro, sigma + real (kind_phys), dimension(:), intent(in) :: xlat_d, xlon_d + real (kind_phys), dimension(:), intent(in) :: oro, sigma - real (kind=kind_phys), dimension(:), intent(in) :: & + real (kind_phys), dimension(:), intent(in) :: & & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & & coszen, prsl1, wind, shdmin, shdmax, & & sfalb_lnd_bck, snoalb, zf, qc, q1, & @@ -391,8 +391,8 @@ subroutine lsm_ruc_run & ! inputs ! for ice & cm_ice, ch_ice - real (kind=kind_phys), intent(in) :: delt, min_seaice, min_lakeice - real (kind=kind_phys), intent(in) :: con_cp, con_rv, con_g, & + real (kind_phys), intent(in) :: delt, min_seaice, min_lakeice + real (kind_phys), intent(in) :: con_cp, con_rv, con_g, & con_pi, con_rd, & con_hvap, con_hfus, con_fvirt @@ -409,12 +409,12 @@ subroutine lsm_ruc_run & ! inputs integer, dimension(:), intent(inout) :: stype integer, dimension(:), intent(in) :: vtype - real (kind=kind_phys), dimension(:,:), intent(in) :: vegtype_frac - real (kind=kind_phys), dimension(:,:), intent(in) :: soiltype_frac + real (kind_phys), dimension(:,:), intent(in) :: vegtype_frac + real (kind_phys), dimension(:,:), intent(in) :: soiltype_frac - real (kind=kind_phys), dimension(:), intent(in) :: zs - real (kind=kind_phys), dimension(:), intent(in) :: srflag - real (kind=kind_phys), dimension(:), intent(inout) :: & + real (kind_phys), dimension(:), intent(in) :: zs + real (kind_phys), dimension(:), intent(in) :: srflag + real (kind_phys), dimension(:), intent(inout) :: & & canopy, trans, smcwlt2, smcref2, & ! for land & weasd_lnd, snwdph_lnd, tskin_lnd, & @@ -426,15 +426,15 @@ subroutine lsm_ruc_run & ! inputs & sfcqc_ice, sfcqv_ice, fice ! --- in - real (kind=kind_phys), dimension(:), intent(in) :: & + real (kind_phys), dimension(:), intent(in) :: & & rainnc, rainc, ice, snow, graupel, rhonewsn1 ! --- in/out: ! --- on RUC levels - real (kind=kind_phys), dimension(:,:), intent(inout) :: & + real (kind_phys), dimension(:,:), intent(inout) :: & & smois, tsice, tslb, sh2o, keepfr, smfrkeep ! --- output: - real (kind=kind_phys), dimension(:), intent(inout) :: & + real (kind_phys), dimension(:), intent(inout) :: & & rhosnf, runof, drain, runoff, srunoff, evbs, evcw, & & stm, wetness, semisbase, semis_lnd, semis_ice, & & sfalb_lnd, sfalb_ice, & @@ -447,7 +447,7 @@ subroutine lsm_ruc_run & ! inputs & cmm_ice, chh_ice, hflx_ice, & & snowfallac_ice, acsnow_ice, snowmt_ice - real (kind=kind_phys), dimension(:), intent( out) :: & + real (kind_phys), dimension(:), intent( out) :: & & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice @@ -457,10 +457,10 @@ subroutine lsm_ruc_run & ! inputs ! --- SPP - should be INTENT(IN) integer :: spp_lsm - real(kind=kind_phys), dimension(im,nlev) :: pattern_spp + real(kind_phys), dimension(im,nlev) :: pattern_spp ! --- locals: - real (kind=kind_phys), dimension(im) :: rho, rhonewsn_ex, & + real (kind_phys), dimension(im) :: rho, rhonewsn_ex, & & q0, qs1, albbcksol, srunoff_old, runoff_old, & & tprcp_old, srflag_old, sr_old, canopy_old, wetness_old, & ! for land @@ -475,26 +475,26 @@ subroutine lsm_ruc_run & ! inputs & sncovr1_ice_old,snowmt_ice_old !-- local spp pattern array - real (kind=kind_phys), dimension(im,lsoil_ruc,1) :: pattern_spp_lsm + real (kind_phys), dimension(im,lsoil_ruc,1) :: pattern_spp_lsm - real (kind=kind_phys), dimension(lsoil_ruc) :: et + real (kind_phys), dimension(lsoil_ruc) :: et - real (kind=kind_phys), dimension(im,lsoil_ruc,1) :: smsoil, & + real (kind_phys), dimension(im,lsoil_ruc,1) :: smsoil, & slsoil, stsoil, smfrsoil, keepfrsoil, stsice - real (kind=kind_phys), dimension(im,lsoil_ruc,1) :: smice, & + real (kind_phys), dimension(im,lsoil_ruc,1) :: smice, & slice, stice, smfrice, keepfrice - real (kind=kind_phys), dimension(im,lsoil_ruc) :: smois_old, & - & tsice_old, tslb_old, sh2o_old, & + real (kind_phys), dimension(im,lsoil_ruc) :: smois_old, & + & tsice_old, tslb_old, sh2o_old, & & keepfr_old, smfrkeep_old - real (kind=kind_phys), dimension(im,nlcat,1) :: landusef - real (kind=kind_phys), dimension(im,nscat,1) :: soilctop + real (kind_phys), dimension(im,nlcat,1) :: landusef + real (kind_phys), dimension(im,nscat,1) :: soilctop - real (kind=kind_phys),dimension (im,1,1) :: & + real (kind_phys),dimension (im,1,1) :: & & conflx2, sfcprs, sfctmp, q2, qcatm, rho2 - real (kind=kind_phys),dimension (im,1) :: orog, stdev - real (kind=kind_phys),dimension (im,1) :: & + real (kind_phys),dimension (im,1) :: orog, stdev + real (kind_phys),dimension (im,1) :: & & albbck_lnd, alb_lnd, chs_lnd, flhc_lnd, flqc_lnd, & & wet, wet_ice, smmax, cmc, drip, ec, edir, ett, & & dew_lnd, lh_lnd, esnow_lnd, etp, qfx_lnd, acceta, & @@ -510,7 +510,7 @@ subroutine lsm_ruc_run & ! inputs & precipfr, snfallac_lnd, acsn_lnd, & & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq ! ice - real (kind=kind_phys),dimension (im,1) :: & + real (kind_phys),dimension (im,1) :: & & albbck_ice, alb_ice, chs_ice, flhc_ice, flqc_ice, & & dew_ice, lh_ice, esnow_ice, qfx_ice, & & solnet_ice, sfcems_ice, hfx_ice, & @@ -520,8 +520,8 @@ subroutine lsm_ruc_run & ! inputs & qsfc_ice, qsg_ice, qvg_ice, qcg_ice, soilt1_ice - real (kind=kind_phys) :: xice_threshold - real (kind=kind_phys) :: fwat, qsw, evapw, hfxw + real (kind_phys) :: xice_threshold + real (kind_phys) :: fwat, qsw, evapw, hfxw character(len=256) :: llanduse !< Land-use dataset. Valid values are : !! "USGS" (USGS 24/27 category dataset) and @@ -536,13 +536,13 @@ subroutine lsm_ruc_run & ! inputs ! local integer :: ims,ime, its,ite, jms,jme, jts,jte, kms,kme, kts,kte integer :: l, k, i, j, fractional_seaice, ilst - real (kind=kind_phys) :: dm, cimin(im) + real (kind_phys) :: dm, cimin(im) logical :: flag(im), flag_ice(im), flag_ice_uncoupled(im) logical :: rdlai2d, myj, frpcpn logical :: debug_print !-- diagnostic point - real (kind=kind_phys) :: testptlat, testptlon + real (kind_phys) :: testptlat, testptlon ! ! Initialize CCPP error handling variables errmsg = '' @@ -637,8 +637,7 @@ subroutine lsm_ruc_run & ! inputs if ( fractional_seaice == 0 ) then xice_threshold = 0.5 else if ( fractional_seaice == 1 ) then - xice_threshold = 0.02 ! HRRR value - !xice_threshold = 0.15 ! consistent with GFS physics + xice_threshold = 0.15 ! consistent with GFS physics, 0.02 in HRRR endif nsoil = lsoil_ruc @@ -659,10 +658,8 @@ subroutine lsm_ruc_run & ! inputs do i = 1, im ! i - horizontal loop if (flag(i) .and. flag_guess(i)) then !> - Save land-related prognostic fields for guess run. - !if(me==0 .and. i==ipr) write (0,*)'before call to RUC guess run', i wetness_old(i) = wetness(i) canopy_old(i) = canopy(i) - !srflag_old(i) = srflag(i) ! for land weasd_lnd_old(i) = weasd_lnd(i) snwdph_lnd_old(i) = snwdph_lnd(i) @@ -704,7 +701,7 @@ subroutine lsm_ruc_run & ! inputs ! --- ... initialization block - do j = 1, 1 + do j = jms, jme do i = 1, im ! i - horizontal loop if (flag_iter(i) .and. flag(i)) then evap_lnd(i) = 0.0 @@ -790,7 +787,7 @@ subroutine lsm_ruc_run & ! inputs frpcpn = .false. endif - do j = 1, 1 ! 1:1 + do j = jms, jme do i = 1, im ! i - horizontal loop orog(i,j) = oro(i) !topography stdev(i,j) = sigma(i) ! st. deviation (m) @@ -803,7 +800,7 @@ subroutine lsm_ruc_run & ! inputs enddo enddo - do j = 1, 1 ! 1:1 + do j = jms, jme do i = 1, im ! i - horizontal loop xice(i,j) = 0. if (flag_iter(i) .and. flag(i)) then @@ -866,9 +863,9 @@ subroutine lsm_ruc_run & ! inputs rhonewsn_ex(i) = rhonewsn1(i) if (debug_print) then !-- diagnostics for a test point with known lat/lon - if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & + if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & abs(xlon_d(i)-testptlon).lt.0.2)then - !if(weasd_lnd(i) > 0.) & + !if(weasd_lnd(i) > 0.) & print 100,'(ruc_lsm_drv) i=',i, & ' lat,lon=',xlat_d(i),xlon_d(i), & 'rainc',rainc(i),'rainnc',rainnc(i), & @@ -876,7 +873,6 @@ subroutine lsm_ruc_run & ! inputs 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& 'prsl1',prsl1(i),'t1',t1(i), & - !'snow',snow(i), 'snowncv',snowncv(i,j), & 'srflag',srflag(i),'weasd mm ',weasd_lnd(i), & 'tsnow_lnd',tsnow_lnd(i),'snwdph mm',snwdph_lnd(i), & 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) @@ -885,12 +881,6 @@ subroutine lsm_ruc_run & ! inputs 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es9.2))) !-- - ! ice precipitation is not used - ! precipfr(i,j) = rainncv(i,j) * ffrozp(i,j) - - ! ice not used - ! precipfr(i,j) = rainncv(i,j) * ffrozp(i,j) - tbot(i,j) = tg3(i) !> - 3. canopy/soil characteristics (s): @@ -913,9 +903,7 @@ subroutine lsm_ruc_run & ! inputs stype_ice(i,j) = 16 ! STASGO endif !> - Prepare land/ice/water masks for RUC LSM - !SLMSK0 - SEA(0),LAND(1),ICE(2) MASK - !if(islmsk(i) == 0.) then - !elseif(islmsk(i) == 1.) then ! land + ! SLMSK0 - SEA(0),LAND(1),ICE(2) MASK if(land(i)) then ! some land xland(i,j) = 1. @@ -1051,56 +1039,56 @@ subroutine lsm_ruc_run & ! inputs endif !> -- sanity checks on sneqv and snowh - if (sneqv_lnd(i,j) /= 0.0d0 .and. snowh_lnd(i,j) == 0.0d0) then + if (sneqv_lnd(i,j) /= 0.0_kind_dbl_prec .and. snowh_lnd(i,j) == 0.0_kind_dbl_prec) then if (debug_print) print *,'bad sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) - if(sneqv_lnd(i,j) < 1.e-7.or.soilt_lnd(i,j)>273.15d0) then - sneqv_lnd(i,j) = 0.d0 - snowh_lnd(i,j) = 0.d0 + if(sneqv_lnd(i,j) < 1.e-7_kind_dbl_prec.or.soilt_lnd(i,j)>273.15_kind_dbl_prec) then + sneqv_lnd(i,j) = 0._kind_dbl_prec + snowh_lnd(i,j) = 0._kind_dbl_prec else - sneqv_lnd(i,j) = 300.d0 * snowh_lnd(i,j) ! snow density ~300 kg m-3 + sneqv_lnd(i,j) = 300._kind_dbl_prec * snowh_lnd(i,j) ! snow density ~300 kg m-3 endif if (debug_print) print *,'fixed sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) - elseif (snowh_lnd(i,j) /= 0.0d0 .and. sneqv_lnd(i,j) == 0.0d0) then + elseif (snowh_lnd(i,j) /= 0.0_kind_dbl_prec .and. sneqv_lnd(i,j) == 0.0_kind_dbl_prec) then if (debug_print) print *,'bad snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) - if(snowh_lnd(i,j) < 3.d-10.or.soilt_lnd(i,j)>273.15d0) then - snowh_lnd(i,j) = 0.d0 - sneqv_lnd(i,j) = 0.d0 + if(snowh_lnd(i,j) < 3.e-10_kind_dbl_prec.or.soilt_lnd(i,j)>273.15_kind_dbl_prec) then + snowh_lnd(i,j) = 0._kind_dbl_prec + sneqv_lnd(i,j) = 0._kind_dbl_prec else - snowh_lnd(i,j) = 0.003d0 * sneqv_lnd(i,j) ! snow density ~300 kg m-3 + snowh_lnd(i,j) = 0.003_kind_dbl_prec * sneqv_lnd(i,j) ! snow density ~300 kg m-3 endif if (debug_print) print *,'fixed snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) - elseif (sneqv_lnd(i,j) > 0.d0 .and. snowh_lnd(i,j) > 0.d0) then - if (debug_print .and. abs(xlat_d(i)-testptlat).lt.2.5 .and. & - abs(xlon_d(i)-testptlon).lt.2.5)then + elseif (sneqv_lnd(i,j) > 0._kind_dbl_prec .and. snowh_lnd(i,j) > 0._kind_dbl_prec) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then print *,'sneqv_lnd(i,j)/snowh_lnd(i,j)',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) endif - if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 500.d0) then + if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 500._kind_dbl_prec) then if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then print *,'large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) print *,'large snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) endif - if(soilt_lnd(i,j)>273.15d0) then - snowh_lnd(i,j) = 0.d0 - sneqv_lnd(i,j) = 0.d0 + if(soilt_lnd(i,j)>273.15_kind_dbl_prec) then + snowh_lnd(i,j) = 0._kind_dbl_prec + sneqv_lnd(i,j) = 0._kind_dbl_prec else - snowh_lnd(i,j) = 0.002d0 * sneqv_lnd(i,j) + snowh_lnd(i,j) = 0.002_kind_dbl_prec * sneqv_lnd(i,j) endif if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then print *,'fixed large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) endif - elseif(sneqv_lnd(i,j)/snowh_lnd(i,j) < 58.d0) then + elseif(sneqv_lnd(i,j)/snowh_lnd(i,j) < 58._kind_dbl_prec) then if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then print *,'small snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) print *,'small snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) endif - if(soilt_lnd(i,j)>273.15d0) then - snowh_lnd(i,j) = 0.d0 - sneqv_lnd(i,j) = 0.d0 + if(soilt_lnd(i,j)>273.15_kind_dbl_prec) then + snowh_lnd(i,j) = 0._kind_dbl_prec + sneqv_lnd(i,j) = 0._kind_dbl_prec else - sneqv_lnd(i,j) = 58.d0 * snowh_lnd(i,j) + sneqv_lnd(i,j) = 58._kind_dbl_prec * snowh_lnd(i,j) endif if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then @@ -1132,12 +1120,11 @@ subroutine lsm_ruc_run & ! inputs if (kdt < 10) then if (abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then - !if(weasd_lnd(i) > 0.) & + !if(weasd_lnd(i) > 0.) & print 100,'(ruc_lsm_drv before RUC land call) i=',i, & ' lat,lon=',xlat_d(i),xlon_d(i), & 'rainc',rainc(i),'rainnc',rainnc(i),'prcp',prcp(i,j), & 'graupel',graupel(i),'qc',qc(i),'sfcqv_lnd',sfcqv_lnd(i),& - !'snow',snow(i), 'snowncv',snowncv(i,j), & 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& 'albbcksol',albbcksol(i),'alb_lnd',alb_lnd(i,j), & @@ -1336,12 +1323,10 @@ subroutine lsm_ruc_run & ! inputs if (debug_print) then if (abs(xlat_d(i)-testptlat).lt.0.1 .and. & abs(xlon_d(i)-testptlon).lt.0.1)then - !if(weasd_ice(i) > 0.) & - print 101,'(ruc_lsm_drv_ice) i=',i, & - ' lat,lon=',xlat_d(i),xlon_d(i), & - !'rainc',rainc(i),'rainnc',rainnc(i), & - 'sfcqv_ice',sfcqv_ice(i),& - !'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & + !if(weasd_ice(i) > 0.) & + print 101,'(ruc_lsm_drv_ice) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'sfcqv_ice',sfcqv_ice(i), & 'sncovr1_ice',sncovr1_ice(i),'sfalb_ice',sfalb_ice(i),& 'sfcqc_ice',sfcqc_ice(i),'tsnow_ice',tsnow_ice(i), & 'prsl1',prsl1(i),'t1',t1(i),'snwdph_ice ',snwdph_ice(i), & @@ -1536,7 +1521,7 @@ subroutine lsm_ruc_run & ! inputs enddo ! i !> - Restore land-related prognostic fields for guess run. - do j = 1, 1 + do j = jms, jme do i = 1, im if (flag(i)) then if(debug_print) write (0,*)'end ',i,flag_guess(i),flag_iter(i) @@ -1547,7 +1532,6 @@ subroutine lsm_ruc_run & ! inputs snwdph_lnd(i) = snwdph_lnd_old(i) tskin_lnd(i) = tskin_lnd_old(i) canopy(i) = canopy_old(i) - !srflag(i) = srflag_old(i) tsnow_lnd(i) = tsnow_lnd_old(i) snowfallac_lnd(i) = snowfallac_lnd_old(i) acsnow_lnd(i) = acsnow_lnd_old(i) @@ -1612,24 +1596,24 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in integer, intent(in ) :: im, nlev integer, intent(in ) :: lsoil_ruc integer, intent(in ) :: lsoil - real (kind=kind_phys), intent(in ) :: min_seaice - real (kind=kind_phys), dimension(im), intent(in ) :: slmsk - real (kind=kind_phys), dimension(im), intent(in ) :: landfrac - real (kind=kind_phys), dimension(im), intent(in ) :: fice - real (kind=kind_phys), dimension(im), intent(in ) :: tskin_lnd, tskin_wat - real (kind=kind_phys), dimension(im), intent(in ) :: tg3 - real (kind=kind_phys), dimension(1:lsoil_ruc), intent(in ) :: zs - real (kind=kind_phys), dimension(1:lsoil_ruc), intent(in ) :: dzs - real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: smc ! Noah - real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: stc ! Noah - real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: slc ! Noah + real (kind_phys), intent(in ) :: min_seaice + real (kind_phys), dimension(im), intent(in ) :: slmsk + real (kind_phys), dimension(im), intent(in ) :: landfrac + real (kind_phys), dimension(im), intent(in ) :: fice + real (kind_phys), dimension(im), intent(in ) :: tskin_lnd, tskin_wat + real (kind_phys), dimension(im), intent(in ) :: tg3 + real (kind_phys), dimension(1:lsoil_ruc), intent(in ) :: zs + real (kind_phys), dimension(1:lsoil_ruc), intent(in ) :: dzs + real (kind_phys), dimension(im,lsoil), intent(in ) :: smc ! Noah + real (kind_phys), dimension(im,lsoil), intent(in ) :: stc ! Noah + real (kind_phys), dimension(im,lsoil), intent(in ) :: slc ! Noah integer, dimension(im), intent(in) :: stype, vtype - real (kind=kind_phys), dimension(im), intent(inout) :: wetness - real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smois! ruc - real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb ! ruc - real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: sh2o ! ruc - real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smfrkeep ! ruc + real (kind_phys), dimension(im), intent(inout) :: wetness + real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smois! ruc + real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb ! ruc + real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: sh2o ! ruc + real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smfrkeep ! ruc integer, intent(in ) :: me integer, intent(in ) :: master @@ -1642,28 +1626,28 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in logical :: swi_init ! for initialization in terms of SWI (soil wetness index) integer :: flag_soil_layers, flag_soil_levels, flag_sst - real (kind=kind_phys), dimension(1:lsoil_ruc) :: factorsm - real (kind=kind_phys), dimension(im) :: smcref2 - real (kind=kind_phys), dimension(im) :: smcwlt2 + real (kind_phys), dimension(1:lsoil_ruc) :: factorsm + real (kind_phys), dimension(im) :: smcref2 + real (kind_phys), dimension(im) :: smcwlt2 integer , dimension( 1:im , 1:1 ) :: ivgtyp integer , dimension( 1:im , 1:1) :: isltyp - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: mavail - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: sst - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: landmask - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: tsk - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: tbot - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: smtotn - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: smtotr - real (kind=kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: dumsm - real (kind=kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: dumt - real (kind=kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: smfr - real (kind=kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soilm - real (kind=kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soiltemp - real (kind=kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soilh2o - - real (kind=kind_phys) :: st_input(1:im,1:lsoil_ruc*3,1:1) - real (kind=kind_phys) :: sm_input(1:im,1:lsoil_ruc*3,1:1) + real (kind_phys), dimension( 1:im , 1:1 ) :: mavail + real (kind_phys), dimension( 1:im , 1:1 ) :: sst + real (kind_phys), dimension( 1:im , 1:1 ) :: landmask + real (kind_phys), dimension( 1:im , 1:1 ) :: tsk + real (kind_phys), dimension( 1:im , 1:1 ) :: tbot + real (kind_phys), dimension( 1:im , 1:1 ) :: smtotn + real (kind_phys), dimension( 1:im , 1:1 ) :: smtotr + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: dumsm + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: dumt + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: smfr + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soilm + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soiltemp + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soilh2o + + real (kind_phys) :: st_input(1:im,1:lsoil_ruc*3,1:1) + real (kind_phys) :: sm_input(1:im,1:lsoil_ruc*3,1:1) integer :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -1976,15 +1960,6 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in enddo enddo - !do i=1,im - ! wetness (i) = 1. - ! do k=1,min(lsoil,lsoil_ruc) - ! smois(i,k) = smc(i,k) - ! tslb(i,k) = stc(i,k) - ! sh2o(i,k) = slc(i,k) - ! enddo - !enddo - if(debug_print) then do i=1,im write (0,*)'End of RUC LSM initialization' From ebb0c17e31794edfecb0546b7746b34f88ebe558 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 17 Mar 2023 19:52:30 +0000 Subject: [PATCH 07/28] Clean-up print statements. --- physics/module_sf_ruclsm.F90 | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 4e44bbffd..13d81eb43 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -8,7 +8,7 @@ !! and all terms of the surface energy balance and surface water balance. MODULE module_sf_ruclsm - use machine , only : kind_phys, kind_dbl_prec + use machine , only : kind_phys use namelist_soilveg_ruc implicit none @@ -970,6 +970,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & !tgs - turn off "irrigation" while there is no fractional landuse and LAI !climatology. + if(1==2) then IF (lufrac(crop) > 0 .and. lai(i,j) > 1.1) THEN ! cropland do k=1,nroot @@ -1004,6 +1005,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif enddo ENDIF + endif ! 1==2 !*** DIAGNOSTICS !--- available and maximum soil moisture content in the soil @@ -1091,11 +1093,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT GRDFLX (I,J) = -1. * sflx(I,J) -! if(smf(i,j) .ne.0.) then !tgs - SMF.NE.0. when there is phase change in the top soil layer ! The heat of soil water freezing/thawing is not computed explicitly ! and is responsible for the residual in the energy budget. -! print *,'Budget',budget(i,j),i,j,smf(i,j) ! endif !--- SNOWC snow cover flag @@ -1136,18 +1136,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & 'smelt ',smelt(i,j)*dt*1.e3_kind_phys,'smc change ',wb, & 'snwe change ',as,'canw change ',ac,'runoff2 ',runoff2(i,j), & 'qfx*dt ',qfx(i,j)*dt,'smavail ',smavail(i,j),'smcold',smtotold(i,j) - !-- - waterbudget(i,j)=rainbl(i,j)-qfx(i,j)*dt-(smavail(i,j)-smtotold(i,j)) & - + !-- print *,'Smf=',smf(i,j),i,j - print *,'Budget',budget(i,j),i,j - print *,'RUNOFF2= ', i,j,runoff2(i,j) - print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb - print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & - i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & - smelt(i,j)*dt*1.e3_kind_phys, & - (smavail(i,j)-smtotold(i,j)) -! print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) print *,'SNOW-SNOWold',i,j,max(0._kind_phys,snwe-snowold(i,j)) print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) From af1e1bcd2ead2ef488187aaafe06a27cdd0f43cd Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 17 Mar 2023 19:53:18 +0000 Subject: [PATCH 08/28] Added table parameters for option 3 of snow cover fraction computation. --- physics/set_soilveg_ruc.F90 | 35 +++++++++++++++++++++++++++++++---- 1 file changed, 31 insertions(+), 4 deletions(-) diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index f29726645..79c1be310 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -30,8 +30,9 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) NAMELIST /SOIL_VEG_RUC/ SLOPE_DATA, ALBTBL, Z0TBL, LEMITBL, & & PCTBL, SHDTBL, & & IFORTBL, RSTBL, RGLTBL, HSTBL, SNUPTBL, LAITBL, MAXALB, & + & MFSNO, SNCOVFAC, & & LPARAM, TOPT_DATA, CMCMAX_DATA, CFACTR_DATA, & - & RSMAX_DATA, BARE, NATURAL, CROP, URBAN, & + & RSMAX_DATA, BARE, GLACIER, NATURAL, CROP, URBAN, & & DEFINED_VEG, DEFINED_SOIL, DEFINED_SLOPE, & & BB, DRYSMC, HC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, & & WLTSMC, QTZ, mosaic_soil, mosaic_lu, & @@ -200,15 +201,41 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) & 70., 55., 60., 75., 70., 0., 0., 0., & & 0., 0., 0., 0., 0., 0./) + mfsno = & !< modified for RRFS Noah_MP snowmelt curve parameter () + & (/ 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, & + & 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, & + & 3.00, 3.00, 2.00, 2.00, 2.00, 2.00, & + & 2.00, 2.00, 0.00, 0.00, 0.00, 0.00, & +! & 3.00, 3.00, 2.00, 3.00, 3.00, 3.00, & +! & 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) + +!-- Noah MP snowmelt curve values +! & (/ 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, & +! & 2.00, 2.00, 2.00, 2.00, 3.00, 3.00, & +! & 4.00, 4.00, 2.50, 3.00, 3.00, 3.50, & +! & 3.50, 3.50, 0.00, 0.00, 0.00, 0.00, & +! & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) + + sncovfac = & !< Noah_MP snow cover factor (m), first 5 categories are modified for RRFS + & (/ 0.030, 0.030, 0.030, 0.030, 0.030, & + !& (/ 0.008, 0.008, 0.008, 0.008, 0.008, & + & 0.016, 0.016, 0.020, 0.020, 0.020, & + & 0.020, 0.014, 0.042, 0.026, 0.030, & + & 0.016, 0.030, 0.030, 0.030, 0.030, & + & 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000 /) + natural = 10 - bare = 16 crop = 12 urban = 13 + glacier = 15 + bare = 16 endif ! end if veg table ! - set mosaic_lu=1 when info for fractional landuse is available - mosaic_lu = 1 + mosaic_lu = 0 topt_data =298.0 cmcmax_data =0.2e-3 @@ -413,7 +440,7 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) END DO ! - set mosaic_soil=1 when info for fractional landuse is available - mosaic_soil = 1 + mosaic_soil = 0 ! PT 5/18/2015 - changed to FALSE to match atm_namelist setting ! PT LPARAM is not used anywhere From eb9b6b682d78751a0a667fc53c9b4c4bd5a82521 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 17 Mar 2023 19:54:25 +0000 Subject: [PATCH 09/28] Updated the sfc_diag.f that computes 2-m diagnostics. Should not affect results for physics suites not using RUC LSM. --- physics/sfc_diag.f | 187 +++++++++++++++++++++++++++++++++++------- physics/sfc_diag.meta | 120 ++++++++++++++++++++++++++- 2 files changed, 277 insertions(+), 30 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 045ad75b0..f5bd081e0 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -1,39 +1,61 @@ !> \file sfc_diag.f !! This file contains the land surface diagnose calculation scheme. +!> \defgroup Sfc_diag Land Surface Diagnose Calculation +!! @{ + module sfc_diag contains - -!> \defgroup sfc_diag_mod GFS sfc_diag module -!! This module contains the land surface diagose calculation. -!> @{ -!! \section arg_table_sfc_diag_run Argument Table + + subroutine sfc_diag_init + end subroutine sfc_diag_init + + subroutine sfc_diag_finalize + end subroutine sfc_diag_finalize + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_sfc_diag_run Arguments !! \htmlinclude sfc_diag_run.html !! - subroutine sfc_diag_run & - & (im,grav,cp,eps,epsm1,ps,u1,v1,t1,q1,prslki, & - & evap,fm,fh,fm10,fh2,tskin,qsurf,thsfc_loc, & - & f10m,u10m,v10m,t2m,q2m,errmsg,errflg & +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ + subroutine sfc_diag_run (im,xlat_d,xlon_d, & + & lsm,lsm_ruc,grav,cp,eps,epsm1,rocp, & + & wet,shflx,chs2,cqs2,cdq,wind, & + & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & + & tskin,qsurf,thsfc_loc,diag_flux,diag_log, & + & f10m,u10m,v10m,t2m,q2m,dpt2m,errmsg,errflg & & ) ! use machine , only : kind_phys use funcphys, only : fpvs implicit none ! - integer, intent(in) :: im + integer, intent(in) :: im, lsm, lsm_ruc logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. - real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1 - real(kind=kind_phys), dimension(:), intent(in) :: & - & ps, u1, v1, t1, q1, tskin, & - & qsurf, prslki, evap, fm, fh, fm10, fh2 + logical, intent(in) :: diag_flux ! Flag for flux method in 2-m diagnostics + logical, intent(in) :: diag_log ! Flag for 2-m log diagnostics under stable conditions + real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1,rocp + real(kind=kind_phys), dimension(:), intent( in) :: & + & zf, ps, u1, v1, t1, q1, tskin, wet, & + & qsurf, prslki, evap, fm, fh, fm10, fh2, & + & shflx, chs2, cqs2, cdq, wind, xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(out) :: & - & f10m, u10m, v10m, t2m, q2m + & f10m, u10m, v10m, t2m, q2m, dpt2m character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! ! locals ! + logical :: debug_print real(kind=kind_phys), parameter :: qmin=1.0e-8 + real(kind=kind_phys) :: q1c, qv, tem, qv1, th2m, x2m, rho + real(kind=kind_phys) :: dT, dQ, qsfcmr, qsfcprox, ff, fac, dz1 + real(kind=kind_phys) :: t2_alt, q2_alt + real(kind=kind_phys) :: thcon, cqs, chs + real(kind=kind_phys) :: testptlat, testptlon integer :: k,i ! real(kind=kind_phys) :: fhi, qss, wrk @@ -44,6 +66,12 @@ subroutine sfc_diag_run & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + + !-- + testptlat = 35.3 !41.02 !42.05 !39.0 !74.12 !29.5 + testptlon = 273.0 !284.50 !286.75 !280.6 !164.0 !283.0 + !-- + debug_print = .false. ! ! estimate sigma ** k at 2 m ! @@ -53,6 +81,8 @@ subroutine sfc_diag_run & ! ps is in pascals ! !! + + do i = 1, im f10m(i) = fm10(i) / fm(i) ! f10m(i) = min(f10m(i),1.) @@ -64,23 +94,123 @@ subroutine sfc_diag_run & ! t2m(i) = t2m(i) * sig2k wrk = 1.0 - fhi + thcon = (1.e5/ps(i))**rocp + !-- make sure 1st level q is not higher than saturated value + qss = fpvs(t1(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q1c = min(q1(i),qss) ! lev 1 spec. humidity - if(thsfc_loc) then ! Use local potential temperature - t2m(i) = tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp - else ! Use potential temperature referenced to 1000 hPa - t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp - endif + qv1 = q1c / (1. - q1c) ! lev 1 mixing ratio + qsfcmr = qsurf(i)/(1. - qsurf(i)) ! surface mixing ratio + chs = cdq(i) * wind(i) + cqs = chs + qsfcprox = max(qmin,qv1 + evap(i)/cqs) ! surface mix. ratio computed from the flux - if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m - q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi - else ! for dew formation, use saturated q at tskin - qss = fpvs(tskin(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) - q2m(i) = qss*wrk + max(qmin,q1(i))*fhi - endif + if(.not. diag_flux) then + !-- original method + if(lsm /= lsm_ruc) then + if(thsfc_loc) then ! Use local potential temperature + t2m(i)=tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp + else ! Use potential temperature referenced to 1000 hPa + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + endif + if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m + q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi + else ! for dew formation, use saturated q at tskin + qss = fpvs(tskin(i)) + qss = eps * qss/(ps(i) + epsm1 * qss) + q2m(i) = qss*wrk + max(qmin,q1c)*fhi + endif + else + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi + endif ! RUC lsm + + else + !-- flux method + th2m = tskin(i)*thcon - shflx(i)/chs2(i) + t2m(i) = th2m/thcon + + x2m = max(qmin,qsfcprox - evap(i)/cqs2(i)) ! mix. ratio + q2m(i) = x2m/(1. + x2m) ! spec. humidity + endif ! flux method + + if(diag_log) then + !-- Alternative logarithmic diagnostics: + dT = t1(i) - tskin(i) + dQ = qv1 - qsfcmr + dz1= zf(i) ! level of atm. forcing + IF (dT > 0.) THEN + ff = MIN(MAX(1.-dT/10.,0.01), 1.0) + !for now, set zt = 0.05 + fac = LOG((2. + .05)/(0.05 + ff))/ & + & LOG((dz1 + .05)/(0.05 + ff)) + T2_alt = tskin(i) + fac * dT + ELSE + !no alternatives (yet) for unstable conditions + T2_alt = t2m(i) + ENDIF + + IF (dQ > 0.) THEN + ff = MIN(MAX(1.-dQ/0.003,0.01), 1.0) + !-- for now, set zt = 0.05 + fac = LOG((2. + .05)/(0.05 + ff))/ & + & LOG((dz1 + .05)/(0.05 + ff)) + Q2_alt = qsfcmr + fac * dQ ! mix. ratio + Q2_alt = Q2_alt/(1. + Q2_alt) ! spec. humidity + ELSE + !no alternatives (yet) for unstable conditions + Q2_alt = q2m(i) + ENDIF + !-- Note: use of alternative diagnostics will make + ! it cooler and drier with stable stratification + t2m(i) = T2_alt + q2m(i) = Q2_alt + endif ! log method for stable regime + + !-- check that T2m values lie in the range between tskin and t1 + x2m = max(min(tskin(i),t1(i)) , t2m(i)) + t2m(i) = min(max(tskin(i),t1(i)) , x2m) + !-- check that Q2m values lie in the range between qsurf and q1 + x2m = max(min(qsurf(i),q1c) , q2m(i)) + q2m(i) = min(max(qsurf(i),q1c) , x2m) + + !-- make sure q2m is not oversaturated qss = fpvs(t2m(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) + qss = eps * qss/(ps(i) + epsm1 * qss) q2m(i) = min(q2m(i),qss) + + if(diag_flux) then + !-- from WRF, applied in HRRR - Jimy Dudhia + ! Limit Q2m diagnostic to no more than 5 percent higher than lowest level value + ! This prevents unrealistic values when QFX is not mostly surface + ! flux because calculation is based on surface flux only. + ! Problems occurred in transition periods and weak winds and vegetation source + q2m(i) = min(q2m(i),1.05*q1c) ! works if qsurf > q1c, evaporation + endif + + + !-- Compute dew point, using vapor pressure + qv = max(qmin,(q2m(i)/(1.-q2m(i)))) + tem = max(ps(i) * qv/( eps - epsm1 *qv), 1.e-8) + dpt2m(i) = 243.5/( ( 17.67 / log(tem/611.2) ) - 1.) + 273.14 + dpt2m(i) = min(dpt2m(i),t2m(i)) + + + if (debug_print) then + !-- diagnostics for a test point with known lat/lon + if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & + & abs(xlon_d(i)-testptlon).lt.0.2)then + print 100,'(ruc_lsm_diag) i=',i, & + & ' lat,lon=',xlat_d(i),xlon_d(i),'zf ',zf(i), & + & 'tskin ',tskin(i),'t2m ',t2m(i),'t1',t1(i),'shflx',shflx(i),& + & 'qsurf ',qsurf(i),'qsfcprox ',qsfcprox,'q2m ',q2m(i), & + & 'q1 ',q1(i),'evap ',evap(i),'dpt2m ',dpt2m(i), & + & 'chs2 ',chs2(i),'cqs2 ',cqs2(i),'cqs ',cqs,'cdq',cdq(i) + endif + endif + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es11.4))) + enddo return @@ -88,3 +218,4 @@ end subroutine sfc_diag_run !> @} end module sfc_diag +!> @} diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index dd3bf79b8..91a5c8d41 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -14,6 +14,36 @@ dimensions = () type = integer intent = in +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lsm] + standard_name = control_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in +[lsm_ruc] + standard_name = identifier_for_ruc_land_surface_scheme + long_name = flag for RUC land surface model + units = flag + dimensions = () + type = integer + intent = in [grav] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -46,6 +76,30 @@ type = real kind = kind_phys intent = in +[rocp] + standard_name = ratio_of_gas_constant_dry_air_to_specific_heat_of_dry_air_at_constant_pressure + long_name = (rd/cp) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[wet] + standard_name = normalized_soil_wetness_for_land_surface_model + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zf] + standard_name = height_above_ground_at_lowest_model_layer + long_name = layer 1 height above ground (not MSL) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [ps] standard_name = surface_air_pressure long_name = surface pressure @@ -71,7 +125,7 @@ kind = kind_phys intent = in [t1] - standard_name = air_temperature_of_new_state_at_surface_adjacent_layer + standard_name = air_temperature_at_surface_adjacent_layer long_name = 1st model layer air temperature units = K dimensions = (horizontal_loop_extent) @@ -79,7 +133,7 @@ kind = kind_phys intent = in [q1] - standard_name = specific_humidity_of_new_state_at_surface_adjacent_layer + standard_name = specific_humidity_at_surface_adjacent_layer long_name = 1st model layer specific humidity units = kg kg-1 dimensions = (horizontal_loop_extent) @@ -157,6 +211,60 @@ dimensions = () type = logical intent = in +[diag_flux] + standard_name = flag_for_flux_method_in_2m_diagnostics + long_name = flag for flux method in 2-m diagnostics + units = flag + dimensions = () + type = logical + intent = in +[diag_log] + standard_name = flag_for_log_method_in_2m_diagnostics + long_name = flag for log method in 2-m diagnostics + units = flag + dimensions = () + type = logical + intent = in +[shflx] + standard_name = surface_upward_temperature_flux + long_name = kinematic surface upward sensible heat flux + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[chs2] + standard_name = surface_exchange_coefficient_for_heat_at_2m + long_name = exchange coefficient for heat at 2 meters + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cqs2] + standard_name = surface_exchange_coefficient_for_moisture_at_2m + long_name = exchange coefficient for moisture at 2 meters + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cdq] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air + long_name = surface exchange coeff heat & moisture + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [f10m] standard_name = ratio_of_wind_at_surface_adjacent_layer_to_wind_at_10m long_name = ratio of fm10 and fm @@ -197,6 +305,14 @@ type = real kind = kind_phys intent = out +[dpt2m] + standard_name = dewpoint_temperature_at_2m + long_name = 2 meter dewpoint temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 706bc40f5a76c2d77a2cde44fabe3b6db92d579b Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 17 Mar 2023 21:50:47 +0000 Subject: [PATCH 10/28] In module_sf_ruclsm.F90 changes rellated to kind_physics. --- physics/module_sf_ruclsm.F90 | 730 +++++++++++++++---------------- physics/namelist_soilveg_ruc.F90 | 72 +-- physics/set_soilveg_ruc.F90 | 3 +- 3 files changed, 405 insertions(+), 400 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 13d81eb43..dcc4723c3 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -8,7 +8,7 @@ !! and all terms of the surface energy balance and surface water balance. MODULE module_sf_ruclsm - use machine , only : kind_phys + use machine , only : kind_phys, kind_dbl_prec use namelist_soilveg_ruc implicit none @@ -20,11 +20,13 @@ MODULE module_sf_ruclsm !> CONSTANT PARAMETERS !! @{ - real (kind=kind_phys), parameter :: P1000mb = 100000. - real (kind=kind_phys), parameter :: xls = 2.85E6 - real (kind=kind_phys), parameter :: rhowater= 1000. - real (kind=kind_phys), parameter :: piconst = 3.1415926535897931 - real (kind=kind_phys), parameter :: r_v = 4.6150e+2 + real (kind_phys), parameter :: P1000mb = 100000._kind_dbl_prec + real (kind_phys), parameter :: xls = 2.85E6_kind_dbl_prec + real (kind_phys), parameter :: rhowater= 1000._kind_dbl_prec + real (kind_phys), parameter :: piconst = 3.1415926535897931_kind_dbl_prec + real (kind_phys), parameter :: r_v = 461.50_kind_dbl_prec + real (kind_phys), parameter :: zero = 0._kind_dbl_prec + real (kind_phys), parameter :: one = 1._kind_dbl_prec !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 integer, parameter :: isncond_opt = 1 @@ -62,7 +64,7 @@ MODULE module_sf_ruclsm !! @{ INTEGER :: SLPCATS INTEGER, PARAMETER :: NSLOPE=30 - real (kind=kind_phys) :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & + real (kind_phys) :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & CZIL_DATA !! @} @@ -183,8 +185,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! INTEGER, PARAMETER :: nzss=5 ! INTEGER, PARAMETER :: nddzs=2*(nzss-2) - real (kind=kind_phys), INTENT(IN ) :: xlat,xlon - real (kind=kind_phys), INTENT(IN ) :: DT + real (kind_phys), INTENT(IN ) :: xlat,xlon + real (kind_phys), INTENT(IN ) :: DT LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden INTEGER, INTENT(IN ) :: NLCAT, NSCAT INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & @@ -193,7 +195,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! LOGICAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: flag_iter, flag - real (kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ) , & INTENT(IN ) :: QV3D, & QC3D, & p8w, & @@ -201,7 +203,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & T3D, & z3D - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & + real (kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: RAINBL, & GLW, & GSWdn, & @@ -211,31 +213,31 @@ SUBROUTINE LSMRUC(xlat,xlon, & FLQC, & CHS , & XICE, & - XLAND, &! ALBBCK, & + XLAND, & VEGFRA, & TBOT - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & + real (kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: GRAUPELNCV, & SNOWNCV, & RAINCV, & RAINNCV - real (kind=kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: RHONEWSN_ex !externally-calculated srf frz precip density + real (kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: RHONEWSN_ex !externally-calculated srf frz precip density - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev + real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX + real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN + real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt + real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev LOGICAL, intent(in) :: rdlai2d - real (kind=kind_phys), DIMENSION( 1:nsl), INTENT(IN ) :: ZS + real (kind_phys), DIMENSION( 1:nsl), INTENT(IN ) :: ZS - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & + real (kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: & SNOW, & SNOWH, & SNOWC, & - CANWAT, & ! new + CANWAT, & SNOALB, & ALB, & LAI, & @@ -246,23 +248,23 @@ SUBROUTINE LSMRUC(xlat,xlon, & Z0 , & ZNT - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & + real (kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: & FRZFRAC INTEGER, DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: IVGTYP, & ISLTYP - real (kind=kind_phys), DIMENSION( ims:ime , 1:nlcat, jms:jme ), INTENT(IN):: LANDUSEF - real (kind=kind_phys), DIMENSION( ims:ime , 1:nscat, jms:jme ), INTENT(IN):: SOILCTOP + real (kind_phys), DIMENSION( ims:ime , 1:nlcat, jms:jme ), INTENT(IN):: LANDUSEF + real (kind_phys), DIMENSION( ims:ime , 1:nscat, jms:jme ), INTENT(IN):: SOILCTOP - real (kind=kind_phys), INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & - XICE_threshold + real (kind_phys), INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & + XICE_threshold - real (kind=kind_phys), DIMENSION( ims:ime , 1:nsl, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime , 1:nsl, jms:jme ) , & INTENT(INOUT) :: SOILMOIS,SH2O,TSO - real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: SOILT, & HFX, & QFX, & @@ -288,11 +290,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & SOILT1, & TSNAV - real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: SMAVAIL, & SMMAX - real (kind=kind_phys), DIMENSION( its:ite, jts:jte ) :: & + real (kind_phys), DIMENSION( its:ite, jts:jte ) :: & PC, & SFCRUNOFF, & UDRUNOFF, & @@ -310,7 +312,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & SEAICE, & INFILTR ! Energy and water budget variables: - real (kind=kind_phys), DIMENSION( its:ite, jts:jte ) :: & + real (kind_phys), DIMENSION( its:ite, jts:jte ) :: & budget, & acbudget, & waterbudget, & @@ -320,16 +322,16 @@ SUBROUTINE LSMRUC(xlat,xlon, & canwatold - real (kind=kind_phys), DIMENSION( ims:ime, 1:nsl, jms:jme) & + real (kind_phys), DIMENSION( ims:ime, 1:nsl, jms:jme) & :: KEEPFR3DFLAG, & SMFR3D - real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & - RHOSNF, & !RHO of snowfall + real (kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & + RHOSNF, & ! RHO of snowfall PRECIPFR, & ! time-step frozen precip SNOWFALLAC !--- soil/snow properties - real (kind=kind_phys) & + real (kind_phys) & :: RHOCS, & RHONEWSN, & RHOSN, & @@ -347,7 +349,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & SNHEI, & SNWE - real (kind=kind_phys) :: CN, & + real (kind_phys) :: CN, & SAT,CW, & C1SN, & C2SN, & @@ -356,31 +358,31 @@ SUBROUTINE LSMRUC(xlat,xlon, & KWT - real (kind=kind_phys), DIMENSION(1:NSL) :: ZSMAIN, & - ZSHALF, & - DTDZS2 + real (kind_phys), DIMENSION(1:NSL) :: ZSMAIN, & + ZSHALF, & + DTDZS2 - real (kind=kind_phys), DIMENSION(1:2*(nsl-2)) :: DTDZS + real (kind_phys), DIMENSION(1:2*(nsl-2)) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001) :: TBQ + real (kind_phys), DIMENSION(1:5001) :: TBQ - real (kind=kind_phys), DIMENSION( 1:nsl ) :: SOILM1D, & + real (kind_phys), DIMENSION( 1:nsl ) :: SOILM1D, & TSO1D, & SOILICE, & SOILIQW, & SMFRKEEP - real (kind=kind_phys), DIMENSION( 1:nsl ) :: KEEPFR + real (kind_phys), DIMENSION( 1:nsl ) :: KEEPFR - real (kind=kind_phys), DIMENSION( 1:nlcat ) :: lufrac - real (kind=kind_phys), DIMENSION( 1:nscat ) :: soilfrac + real (kind_phys), DIMENSION( 1:nlcat ) :: lufrac + real (kind_phys), DIMENSION( 1:nscat ) :: soilfrac - real (kind=kind_phys) :: RSM, & - SNWEPRINT, & - SNHEIPRINT + real (kind_phys) :: RSM, & + SNWEPRINT, & + SNHEIPRINT - real (kind=kind_phys) :: PRCPMS, & + real (kind_phys) :: PRCPMS, & NEWSNMS, & prcpncliq, & prcpncfr, & @@ -401,10 +403,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & icerat, & curat, & INFILTRP - real (kind=kind_phys) :: cq,r61,r273,arp,brp,x,evs,eis - real (kind=kind_phys) :: cropsm + real (kind_phys) :: cq,r61,r273,arp,brp,x,evs,eis + real (kind_phys) :: cropsm - real (kind=kind_phys) :: meltfactor, ac,as, wb,rovcp + real (kind_phys) :: meltfactor, ac,as, wb,rovcp INTEGER :: NROOT INTEGER :: ILAND,ISOIL,IFOREST @@ -413,7 +415,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & logical :: debug_print !-- diagnostic point - real (kind=kind_phys) :: testptlat, testptlon + real (kind_phys) :: testptlat, testptlon character(len=*),intent(out) :: errmsg integer, intent(out) :: errflg @@ -432,23 +434,23 @@ SUBROUTINE LSMRUC(xlat,xlon, & NDDZS=2*(nzs-2) !-- - testptlat = 48.7074 !39.958 !42.05 !39.0 !74.12 !29.5 - testptlon = 289.03 !271.622 !286.75 !280.6 !164.0 !283.0 + testptlat = 48.7074_kind_phys !39.958 !42.05 !39.0 !74.12 !29.5 + testptlon = 289.03_kind_phys !271.622 !286.75 !280.6 !164.0 !283.0 !-- !> - Table TBQ is for resolution of balance equation in vilka() - CQ=173.15-.05 - R273=1./273.15 - R61=6.1153*0.62198 - ARP=77455.*41.9/461.525 - BRP=64.*41.9/461.525 + CQ=173.15_kind_dbl_prec-.05_kind_dbl_prec + R273=1._kind_dbl_prec/273.15_kind_dbl_prec + R61=6.1153_kind_dbl_prec*0.62198_kind_dbl_prec + ARP=77455._kind_dbl_prec*41.9_kind_dbl_prec/461.525_kind_dbl_prec + BRP=64._kind_dbl_prec*41.9_kind_dbl_prec/461.525_kind_dbl_prec DO K=1,5001 - CQ=CQ+.05 - EVS=EXP(17.67*(CQ-273.15)/(CQ-29.65)) - EIS=EXP(22.514-6.15E3/CQ) - if(CQ.ge.273.15) then + CQ=CQ+.05_kind_dbl_prec + EVS=EXP(17.67_kind_dbl_prec*(CQ-273.15_kind_dbl_prec)/(CQ-29.65_kind_dbl_prec)) + EIS=EXP(22.514_kind_phys-6.15E3_kind_dbl_prec/CQ) + if(CQ.ge.273.15_kind_dbl_prec) then ! tbq is in mb tbq(k) = R61*evs else @@ -468,9 +470,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & DO i=its,ite ! !> - Initializing inside-snow temp if it is not defined - IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN - IF(snowc(i,j).gt.0.) THEN - soilt1(i,j)=min(273.15,0.5*(soilt(i,j)+tso(i,1,j)) ) + IF((soilt1(i,j) .LT. 170._kind_phys) .or. (soilt1(i,j) .GT.400._kind_phys)) THEN + IF(snowc(i,j).gt.zero) THEN + soilt1(i,j)=min(273.15_kind_phys,0.5_kind_phys*(soilt(i,j)+tso(i,1,j)) ) IF (debug_print ) THEN print *, & 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,xlat,xlon @@ -479,24 +481,24 @@ SUBROUTINE LSMRUC(xlat,xlon, & soilt1(i,j) = tso(i,1,j) ENDIF ENDIF - tsnav(i,j) =min(0.,0.5*(soilt(i,j)+tso(i,1,j))-273.15) + tsnav(i,j) =min(zero,0.5_kind_phys*(soilt(i,j)+tso(i,1,j))-273.15_kind_phys) !- 10feb22 - limit snow albedo at high elevations !- based on Roesch et al., Climate Dynamics (2001),17:933-946 - if(hgt(i,j) > 2500.) then - snoalb(i,j) = min(0.65,snoalb(i,j)) + if(hgt(i,j) > 2500._kind_phys) then + snoalb(i,j) = min(0.65_kind_phys,snoalb(i,j)) endif - patmb=P8w(i,kms,j)*1.e-2 + patmb=P8w(i,kms,j)*1.e-2_kind_phys QSG (i,j) = QSN(SOILT(i,j),TBQ)/PATMB - if((qcg(i,j) < 0.) .or. (qcg(i,j) > 0.1)) then + if((qcg(i,j) < zero) .or. (qcg(i,j) > 0.1_kind_phys)) then qcg (i,j) = qc3d(i,1,j) if (debug_print ) then print *, 'QCG is initialized in RUCLSM ', qcg(i,j),qc3d(i,1,j),i,xlat,xlon endif endif - if((qvg(i,j) .LE. 0.) .or. (qvg(i,j) .GT.0.1)) then + if((qvg(i,j) .LE. zero) .or. (qvg(i,j) .GT.0.1_kind_phys)) then qvg (i,j) = qv3d(i,1,j) if (debug_print ) then print *, 'QVG is initialized in RUCLSM ', qvg(i,j),mavail(i,j),qsg(i,j),i,xlat,xlon @@ -504,64 +506,64 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) - SMELT(i,j) = 0. - SNOM (i,j) = 0. - ACSNOW(i,j) = 0. - SNOWFALLAC(i,j) = 0. - PRECIPFR(i,j) = 0. - RHOSNF(i,j) = -1.e3 ! non-zero flag - SNFLX(i,j) = 0. - DEW (i,j) = 0. - PC (i,j) = 0. - zntl (i,j) = 0. - RUNOFF1(i,j) = 0. - RUNOFF2(i,j) = 0. - SFCRUNOFF(i,j) = 0. - UDRUNOFF(i,j) = 0. - ACRUNOFF(i,j) = 0. - emissl (i,j) = 0. - msnf (i,j) = 0. - facsnf (i,j) = 0. - budget(i,j) = 0. - acbudget(i,j) = 0. - waterbudget(i,j) = 0. - acwaterbudget(i,j) = 0. - smtotold(i,j)=0. - canwatold(i,j)=0. + SMELT(i,j) = zero + SNOM (i,j) = zero + ACSNOW(i,j) = zero + SNOWFALLAC(i,j) = zero + PRECIPFR(i,j) = zero + RHOSNF(i,j) = -1.e3_kind_phys ! non-zero flag + SNFLX(i,j) = zero + DEW (i,j) = zero + PC (i,j) = zero + zntl (i,j) = zero + RUNOFF1(i,j) = zero + RUNOFF2(i,j) = zero + SFCRUNOFF(i,j) = zero + UDRUNOFF(i,j) = zero + ACRUNOFF(i,j) = zero + emissl (i,j) = zero + msnf (i,j) = zero + facsnf (i,j) = zero + budget(i,j) = zero + acbudget(i,j) = zero + waterbudget(i,j) = zero + acwaterbudget(i,j) = zero + smtotold(i,j)=zero + canwatold(i,j)=zero !> - For RUC LSM CHKLOWQ needed for MYJPBL should !! 1 because is actual specific humidity at the surface, and !! not the saturation value - chklowq(i,j) = 1. - infiltr(i,j) = 0. - snoh (i,j) = 0. - edir (i,j) = 0. - ec (i,j) = 0. - ett (i,j) = 0. - sublim(i,j) = 0. - sflx (i,j) = 0. - smf (i,j) = 0. - evapl (i,j) = 0. - prcpl (i,j) = 0. + chklowq(i,j) = one + infiltr(i,j) = zero + snoh (i,j) = zero + edir (i,j) = zero + ec (i,j) = zero + ett (i,j) = zero + sublim(i,j) = zero + sflx (i,j) = zero + smf (i,j) = zero + evapl (i,j) = zero + prcpl (i,j) = zero ENDDO ENDDO - infiltrp = 0. + infiltrp = zero do k=1,nsl - soilice(k)=0. - soiliqw(k)=0. + soilice(k)=zero + soiliqw(k)=zero enddo endif ! cold start endif ! init==.true. !----------------------------------------------------------------- - PRCPMS = 0. - newsnms = 0. - prcpncliq = 0. - prcpculiq = 0. - prcpncfr = 0. - prcpcufr = 0. + PRCPMS = zero + newsnms = zero + prcpncliq = zero + prcpculiq = zero + prcpncfr = zero + prcpcufr = zero DO J=jts,jte @@ -586,66 +588,64 @@ SUBROUTINE LSMRUC(xlat,xlon, & TABS = T3D(i,kms,j) QVATM = QV3D(i,kms,j) QCATM = QC3D(i,kms,j) - PATM = P8w(i,kms,j)*1.e-5 + PATM = P8w(i,kms,j)*1.e-5_kind_phys !> - Z3D(1) is thickness between first full sigma level and the surface, !! but first mass level is at the half of the first sigma level !! (u and v are also at the half of first sigma level) - CONFLX = Z3D(i,kms,j)*0.5 + CONFLX = Z3D(i,kms,j)*0.5_kind_phys RHO = RHO3D(I,kms,J) !> - Initialize snow, graupel and ice fractions in frozen precip - snowrat = 0. - grauprat = 0. - icerat = 0. - curat = 0. + snowrat = zero + grauprat = zero + icerat = zero + curat = zero IF(FRPCPN) THEN prcpncliq = rainncv(i,j)*(1.-frzfrac(i,j)) prcpncfr = rainncv(i,j)*frzfrac(i,j) !> - Apply the same frozen precipitation fraction to convective precip !tgs - 31 mar17 - add temperature check in case Thompson MP produces ! frozen precip at T > 273. - if(frzfrac(i,j) > 0. .and. tabs < 273.) then - prcpculiq = max(0.,raincv(i,j)*(1.-frzfrac(i,j))) - prcpcufr = max(0.,raincv(i,j)*frzfrac(i,j)) -! prcpculiq = max(0.,(rainbl(i,j)-rainncv(i,j))*(1.-frzfrac(i,j))) -! prcpcufr = max(0.,(rainbl(i,j)-rainncv(i,j))*frzfrac(i,j)) + if(frzfrac(i,j) > zero .and. tabs < 273._kind_phys) then + prcpculiq = max(zero,raincv(i,j)*(one-frzfrac(i,j))) + prcpcufr = max(zero,raincv(i,j)*frzfrac(i,j)) else - if(tabs < 273.) then - prcpcufr = max(0.,raincv(i,j)) - prcpculiq = 0. + if(tabs < 273._kind_phys) then + prcpcufr = max(zero,raincv(i,j)) + prcpculiq = zero else - prcpcufr = 0. - prcpculiq = max(0.,raincv(i,j)) + prcpcufr = zero + prcpculiq = max(zero,raincv(i,j)) endif ! tabs < 273. endif ! frzfrac > 0. !--- 1*e-3 is to convert from mm/s to m/s - PRCPMS = (prcpncliq + prcpculiq)/DT*1.e-3 - NEWSNMS = (prcpncfr + prcpcufr)/DT*1.e-3 + PRCPMS = (prcpncliq + prcpculiq)/DT*1.e-3_kind_phys + NEWSNMS = (prcpncfr + prcpcufr)/DT*1.e-3_kind_phys - if((prcpncfr + prcpcufr) > 0.) then + if((prcpncfr + prcpcufr) > zero) then !> - Calculate snow, graupel and ice fractions in falling frozen precip - snowrat=min(1.,max(0.,snowncv(i,j)/(prcpncfr + prcpcufr))) - grauprat=min(1.,max(0.,graupelncv(i,j)/(prcpncfr + prcpcufr))) - icerat=min(1.,max(0.,(prcpncfr-snowncv(i,j)-graupelncv(i,j)) & + snowrat=min(one,max(zero,snowncv(i,j)/(prcpncfr + prcpcufr))) + grauprat=min(one,max(zero,graupelncv(i,j)/(prcpncfr + prcpcufr))) + icerat=min(one,max(zero,(prcpncfr-snowncv(i,j)-graupelncv(i,j)) & /(prcpncfr + prcpcufr))) - curat=min(1.,max(0.,(prcpcufr/(prcpncfr + prcpcufr)))) + curat=min(one,max(zero,(prcpcufr/(prcpncfr + prcpcufr)))) endif ELSE ! .not. FRPCPN - if (tabs.le.273.15) then - PRCPMS = 0. - NEWSNMS = RAINBL(i,j)/DT*1.e-3 + if (tabs.le.273.15_kind_phys) then + PRCPMS = zero + NEWSNMS = RAINBL(i,j)/DT*1.e-3_kind_phys !> - If here no info about constituents of frozen precipitation, !! suppose it is all snow - snowrat = 1. + snowrat = one else - PRCPMS = RAINBL(i,j)/DT*1.e-3 - NEWSNMS = 0. + PRCPMS = RAINBL(i,j)/DT*1.e-3_kind_phys + NEWSNMS = zero endif ENDIF ! -- save time-step water equivalent of frozen precipitation in PRECIPFR array to be used in ! module_diagnostics - precipfr(i,j) = NEWSNMS * DT *1.e3 + precipfr(i,j) = NEWSNMS * DT *1.e3_kind_phys if (myj) then QKMS=CHS(i,j) @@ -654,23 +654,23 @@ SUBROUTINE LSMRUC(xlat,xlon, & !> - Convert exchange coeff QKMS to [m/s] QKMS=FLQC(I,J)/RHO/MAVAIL(I,J) ! TKMS=FLHC(I,J)/RHO/CP - TKMS=FLHC(I,J)/RHO/(CP*(1.+0.84*QVATM)) ! mynnsfc uses CPM + TKMS=FLHC(I,J)/RHO/(CP*(one+0.84_kind_phys*QVATM)) ! mynnsfc uses CPM endif !> - Convert incoming snow and canwat from mm to m - SNWE=SNOW(I,J)*1.E-3 + SNWE=SNOW(I,J)*1.E-3_kind_phys SNHEI=SNOWH(I,J) - CANWATR=CANWAT(I,J)*1.E-3 + CANWATR=CANWAT(I,J)*1.E-3_kind_phys SNOWFRAC=SNOWC(I,J) RHOSNFALL=RHOSNF(I,J) snowold(i,j)=snwe !----- - zsmain(1)=0. - zshalf(1)=0. + zsmain(1)=zero + zshalf(1)=zero do k=2,nzs zsmain(k)= zs(k) - zshalf(k)=0.5*(zsmain(k-1) + zsmain(k)) + zshalf(k)=0.5_kind_phys*(zsmain(k-1) + zsmain(k)) enddo do k=1,nlcat @@ -701,32 +701,32 @@ SUBROUTINE LSMRUC(xlat,xlon, & DTDZS(K2)=X/(ZSMAIN(K+1)-ZSMAIN(K)) END DO - CW =4.183E6 + CW =4.183E6_kind_dbl_prec !--- Constants used in Johansen soil thermal !--- conductivity method - KQWRTZ=7.7 - KICE=2.2 - KWT=0.57 + KQWRTZ=7.7_kind_dbl_prec + KICE=2.2_kind_dbl_prec + KWT=0.57_kind_dbl_prec !*********************************************************************** !--- Constants for snow density calculations C1SN and C2SN - c1sn=0.026 - c2sn=21. + c1sn=0.026_kind_dbl_prec + c2sn=21._kind_dbl_prec !*********************************************************************** NROOT= 4 ! ! rooting depth - RHONEWSN = 200. - if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.02) then + RHONEWSN = 200._kind_phys + if(SNOW(i,j).gt.zero .and. SNOWH(i,j).gt.0.02_kind_phys) then RHOSN = SNOW(i,j)/SNOWH(i,j) else - RHOSN = 300. + RHOSN = 300._kind_phys endif IF (debug_print ) THEN @@ -1210,17 +1210,17 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: isice,i,j,nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon - real (kind=kind_phys), INTENT(IN ) :: testptlat,testptlon - real (kind=kind_phys), INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon + real (kind_phys), INTENT(IN ) :: testptlat,testptlon + real (kind_phys), INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex LOGICAL, INTENT(IN ) :: myj, debug_print, exticeden !--- 3-D Atmospheric variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: PATM, & TABS, & QVATM, & QCATM - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & GSWdn, & @@ -1237,7 +1237,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP !--- 2-D variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: EMISS, & EMISBCK, & MAVAIL, & @@ -1247,7 +1247,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia CST !--- soil properties - real (kind=kind_phys) :: & + real (kind_phys) :: & RHOCS, & BCLH, & DQM, & @@ -1259,7 +1259,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SAT, & WILT - real (kind=kind_phys), INTENT(IN ) :: CN, & + real (kind_phys), INTENT(IN ) :: CN, & CW, & CP, & ROVCP, & @@ -1270,26 +1270,26 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia KICE, & KWT - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TS1D, & SOILM1D, & SMFRKEEP - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(INOUT) :: SOILICE, & + real (kind_phys), DIMENSION(1:NZS), INTENT(INOUT) :: SOILICE, & SOILIQW @@ -1297,7 +1297,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER :: ILANDs !-------- 2-d variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & EDIR1, & EC1, & @@ -1337,7 +1337,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia TSNAV, & ZNT - real (kind=kind_phys), DIMENSION(1:NZS) :: & + real (kind_phys), DIMENSION(1:NZS) :: & tice, & rhosice, & capice, & @@ -1349,7 +1349,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SOILICES, & KEEPFRS !-------- 1-d variables - real (kind=kind_phys) :: & + real (kind_phys) :: & DEWS, & MAVAILS, & EDIR1s, & @@ -1374,23 +1374,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia - real (kind=kind_phys), INTENT(INOUT) :: RSM, & + real (kind_phys), INTENT(INOUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables INTEGER :: K,ILNB - real (kind=kind_phys) :: BSN, XSN , & + real (kind_phys) :: BSN, XSN , & RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & T3, UPFLUX, XINET, snowfrac2, m - real (kind=kind_phys) :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn - real (kind=kind_phys) :: newsnowratio, dd1 + real (kind_phys) :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn + real (kind_phys) :: newsnowratio, dd1 - real (kind=kind_phys) :: rhonewgr,rhonewice + real (kind_phys) :: rhonewgr,rhonewice - real (kind=kind_phys) :: RNET,GSWNEW,GSWIN,EMISSN,ZNTSN,EMISS_snowfree - real (kind=kind_phys) :: VEGFRAC, snow_mosaic, snfr, vgfr + real (kind_phys) :: RNET,GSWNEW,GSWIN,EMISSN,ZNTSN,EMISS_snowfree + real (kind_phys) :: VEGFRAC, snow_mosaic, snfr, vgfr real :: cice, albice, albsn, drip, dripsn, dripliq real :: interw, intersn, infwater, intwratio @@ -2267,10 +2267,10 @@ END SUBROUTINE SFCTMP !! the precomputed table and a given temperature. FUNCTION QSN(TN,T) !**************************************************************** - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN ) :: T - real (kind=kind_phys), INTENT(IN ) :: TN + real (kind_phys), DIMENSION(1:5001), INTENT(IN ) :: T + real (kind_phys), INTENT(IN ) :: TN - real (kind=kind_phys) QSN, R,R1,R2 + real (kind_phys) QSN, R,R1,R2 INTEGER I R=(TN-173.15)/.05+1. @@ -2373,15 +2373,15 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: GLW, & GSW, & GSWin, & @@ -2395,7 +2395,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & TKMS !--- soil properties - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -2406,7 +2406,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & REF, & WILT - real (kind=kind_phys), INTENT(IN ) :: CN, & + real (kind_phys), INTENT(IN ) :: CN, & CW, & KQWRTZ, & KICE, & @@ -2415,27 +2415,27 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & g0_p - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO, & SOILMOIS, & SMFRKEEP - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR !-------- 2-d variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(INOUT) :: DEW, & CST, & DRIP, & @@ -2459,27 +2459,27 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & SOILT !-------- 1-d variables - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & SOILIQW !--- Local variables - real (kind=kind_phys) :: INFILTRP, transum , & + real (kind_phys) :: INFILTRP, transum , & RAINF, PRCPMS , & TABS, T3, UPFLUX, XINET - real (kind=kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & + real (kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & can,epot,fac,fltot,ft,fq,hft , & q1,ras,rhoice,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW, X - real (kind=kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & + real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold - real (kind=kind_phys) :: soiltold,smf - real (kind=kind_phys) :: soilres, alfa, fex, fex_fc, fc, psit + real (kind_phys) :: soiltold,smf + real (kind_phys) :: soilres, alfa, fex, fex_fc, fc, psit INTEGER :: nzs1,nzs2,k @@ -2927,15 +2927,15 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: GLW, & GSW, & EMISS, & @@ -2943,7 +2943,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & QKMS, & TKMS !--- sea ice properties - real (kind=kind_phys), DIMENSION(1:NZS) , & + real (kind_phys), DIMENSION(1:NZS) , & INTENT(IN ) :: & tice, & rhosice, & @@ -2951,25 +2951,25 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & thdifice - real (kind=kind_phys), INTENT(IN ) :: & + real (kind_phys), INTENT(IN ) :: & CW, & XLV - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !----soil temperature - real (kind=kind_phys), DIMENSION( 1:nzs ), INTENT(INOUT) :: TSO + real (kind_phys), DIMENSION( 1:nzs ), INTENT(INOUT) :: TSO !-------- 2-d variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(INOUT) :: DEW, & EETA, & EVAPL, & @@ -2984,21 +2984,21 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & SOILT !--- Local variables - real (kind=kind_phys) :: x,x1,x2,x4,tn,denom - real (kind=kind_phys) :: RAINF, PRCPMS , & + real (kind_phys) :: x,x1,x2,x4,tn,denom + real (kind_phys) :: RAINF, PRCPMS , & TABS, T3, UPFLUX, XINET - real (kind=kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & + real (kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & epot,fltot,ft,fq,hft,ras,cvw - real (kind=kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & + real (kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & TDENOM,QGOLD,SNOH - real (kind=kind_phys) :: AA1,RHCS, icemelt + real (kind_phys) :: AA1,RHCS, icemelt - real (kind=kind_phys), DIMENSION(1:NZS) :: cotso,rhtso + real (kind_phys), DIMENSION(1:NZS) :: cotso,rhtso INTEGER :: nzs1,nzs2,k,k1,kn,kk @@ -3268,7 +3268,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,isoil - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & RAINF,NEWSNOW,RHONEWSN, & testptlat,testptlon, & SNHEI_CRIT,meltfactor,xlat,xlon @@ -3276,12 +3276,12 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & GSWin, & @@ -3295,7 +3295,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: IVGTYP !--- soil properties - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -3307,7 +3307,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & SAT, & WILT - real (kind=kind_phys), INTENT(IN ) :: CN, & + real (kind_phys), INTENT(IN ) :: CN, & CW, & XLV, & G0_P, & @@ -3316,23 +3316,23 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & KWT - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO, & SOILMOIS, & SMFRKEEP - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR @@ -3340,7 +3340,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !-------- 2-d variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & CST, & DRIP, & @@ -3377,10 +3377,10 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER, INTENT(INOUT) :: ILNB !-------- 1-d variables - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & SOILIQW - real (kind=kind_phys), INTENT(OUT) :: RSM, & + real (kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables @@ -3388,24 +3388,24 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER :: nzs1,nzs2,k - real (kind=kind_phys) :: INFILTRP, TRANSUM , & + real (kind_phys) :: INFILTRP, TRANSUM , & SNTH, NEWSN , & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP - real (kind=kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt,dzstop, & + real (kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt,dzstop, & can,epot,fac,fltot,ft,fq,hft , & q1,ras,rhoice,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW,DELTSN,H,UMVEG - real (kind=kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & + real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold - real (kind=kind_phys) :: soiltold, qgold + real (kind_phys) :: soiltold, qgold - real (kind=kind_phys) :: RNET, X + real (kind_phys) :: RNET, X !----------------------------------------------------------------- @@ -3869,19 +3869,19 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,isoil - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & RAINF,NEWSNOW,RHONEWSN, & meltfactor,snhei_crit,xlat,xlon real :: rhonewcsn LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & RHO, & @@ -3889,35 +3889,35 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & TKMS !--- sea ice properties - real (kind=kind_phys), DIMENSION(1:NZS) , & + real (kind_phys), DIMENSION(1:NZS) , & INTENT(IN ) :: & tice, & rhosice, & capice, & thdifice - real (kind=kind_phys), INTENT(IN ) :: & + real (kind_phys), INTENT(IN ) :: & CW, & XLV - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO INTEGER, INTENT(INOUT) :: ILAND !-------- 2-d variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & EETA, & RHOSN, & @@ -3945,37 +3945,37 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & INTEGER, INTENT(INOUT) :: ILNB - real (kind=kind_phys), INTENT(OUT) :: RSM, & + real (kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables INTEGER :: nzs1,nzs2,k,k1,kn,kk - real (kind=kind_phys) :: x,x1,x2,dzstop,ft,tn,denom + real (kind_phys) :: x,x1,x2,dzstop,ft,tn,denom - real (kind=kind_phys) :: SNTH, NEWSN , & + real (kind_phys) :: SNTH, NEWSN , & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP - real (kind=kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & + real (kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & epot,fltot,fq,hft,q1,ras,rhoice,ci,cvw , & RIW,DELTSN,H - real (kind=kind_phys) :: rhocsn,thdifsn, & + real (kind_phys) :: rhocsn,thdifsn, & xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn - real (kind=kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - real (kind=kind_phys) :: fso,fsn, & + real (kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn + real (kind_phys) :: fso,fsn, & FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & FKQ,R210,AA,BB,QS1,TS1,TQ2,TX2, & TDENOM,AA1,RHCS,H1,TSOB, SNPRIM, & SNODIF,SOH,TNOLD,QGOLD,SNOHGNEW - real (kind=kind_phys), DIMENSION(1:NZS) :: cotso,rhtso + real (kind_phys), DIMENSION(1:NZS) :: cotso,rhtso - real (kind=kind_phys) :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr + real (kind_phys) :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr integer :: nmelt - real (kind=kind_phys) :: keff, fact + real (kind_phys) :: keff, fact !----------------------------------------------------------------- XLMELT=3.35E+5 @@ -4726,15 +4726,15 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon - real (kind=kind_phys), INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon + real (kind_phys), INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & EMISS, & RHO, & @@ -4747,17 +4747,17 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & TKMS !--- soil properties - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & BCLH, & DQM, & QMIN - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & soilres,alfa - real (kind=kind_phys), INTENT(IN ) :: CP, & + real (kind_phys), INTENT(IN ) :: CP, & CVW, & XLV, & STBOLT, & @@ -4765,23 +4765,23 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & G0_P - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & THDIF, & CAP - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO !-------- 2-d variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: & MAVAIL, & QVG, & @@ -4792,16 +4792,16 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & !--- Local variables - real (kind=kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph , & + real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph , & tn,trans,umveg,denom,fex - real (kind=kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & + real (kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & TDENOM - real (kind=kind_phys) :: C,CC,AA1,RHCS,H1, QGOLD + real (kind_phys) :: C,CC,AA1,RHCS,H1, QGOLD - real (kind=kind_phys), DIMENSION(1:NZS) :: cotso,rhtso + real (kind_phys), DIMENSION(1:NZS) :: cotso,rhtso INTEGER :: nzs1,nzs2,k,k1,kn,kk, iter @@ -5032,7 +5032,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & testptlat,testptlon , & @@ -5040,12 +5040,12 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & real :: rhonewcsn !--- 3-D Atmospheric variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & RHO, & @@ -5055,14 +5055,14 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & TKMS !--- soil properties - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & BCLH, & DQM, & PSIS, & QMIN - real (kind=kind_phys), INTENT(IN ) :: CP, & + real (kind_phys), INTENT(IN ) :: CP, & ROVCP, & CVW, & STBOLT, & @@ -5070,25 +5070,25 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & G0_P - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & THDIF, & CAP, & TRANF - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO !-------- 2-d variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & CST, & RHOSN, & @@ -5108,9 +5108,9 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & SOILT1, & TSNAV - real (kind=kind_phys), INTENT(INOUT) :: DRYCAN, WETCAN + real (kind_phys), INTENT(INOUT) :: DRYCAN, WETCAN - real (kind=kind_phys), INTENT(OUT) :: RSM, & + real (kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & SNHEIPRINT INTEGER, INTENT(OUT) :: ilnb @@ -5119,16 +5119,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & INTEGER :: nzs1,nzs2,k,k1,kn,kk - real (kind=kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph, & + real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph, & tn,trans,umveg,denom - real (kind=kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn + real (kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - real (kind=kind_phys) :: t3,upflux,xinet,ras, & + real (kind_phys) :: t3,upflux,xinet,ras, & xlmelt,rhocsn,thdifsn, & beta,epot,xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn - real (kind=kind_phys) :: fso,fsn, & + real (kind_phys) :: fso,fsn, & FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2, & TDENOM,C,CC,AA1,RHCS,H1, & @@ -5136,15 +5136,15 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & smeltg,snohg,snodif,soh, & CMC2MS,TNOLD,QGOLD,SNOHGNEW - real (kind=kind_phys), DIMENSION(1:NZS) :: transp,cotso,rhtso - real (kind=kind_phys) :: edir1, & + real (kind_phys), DIMENSION(1:NZS) :: transp,cotso,rhtso + real (kind_phys) :: edir1, & ec1, & ett1, & eeta, & qfx, & hfx - real (kind=kind_phys) :: RNET,rsmfrac,soiltfrac,hsn,rr,keff,fact + real (kind_phys) :: RNET,rsmfrac,soiltfrac,hsn,rr,keff,fact integer :: nmelt, iter !----------------------------------------------------------------- @@ -6006,12 +6006,12 @@ SUBROUTINE SOILMOIST ( debug_print, & !------------------------------------------------------------------ !--- input variables LOGICAL, INTENT(IN ) :: debug_print - real (kind=kind_phys), INTENT(IN ) :: DELT + real (kind_phys), INTENT(IN ) :: DELT INTEGER, INTENT(IN ) :: NZS,NDDZS ! input variables - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN ) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN ) :: ZSMAIN, & ZSHALF, & DIFFU, & HYDRO, & @@ -6019,33 +6019,33 @@ SUBROUTINE SOILMOIST ( debug_print, & SOILICE, & DTDZS2 - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM, & + real (kind_phys), INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM, & QKMS,VEGFRAC,DRIP,PRCP , & DEW,SMELT,SNOWFRAC , & DQM,QMIN,REF,KSAT,RAS,RIW,SOILRES ! output - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: SOILMOIS,SOILIQW - real (kind=kind_phys), INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & + real (kind_phys), INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & INFMAX ! local variables - real (kind=kind_phys), DIMENSION( 1:nzs ) :: COSMC,RHSMC + real (kind_phys), DIMENSION( 1:nzs ) :: COSMC,RHSMC - real (kind=kind_phys) :: DZS,R1,R2,R3,R4,R5,R6,R7,R8,R9,R10 - real (kind=kind_phys) :: REFKDT,REFDK,DELT1,F1MAX,F2MAX - real (kind=kind_phys) :: F1,F2,FD,KDT,VAL,DDT,PX,FK,FKMAX - real (kind=kind_phys) :: QQ,UMVEG,INFMAX1,TRANS - real (kind=kind_phys) :: TOTLIQ,FLX,FLXSAT,QTOT - real (kind=kind_phys) :: DID,X1,X2,X4,DENOM,Q2,Q4 - real (kind=kind_phys) :: dice,fcr,acrt,frzx,sum,cvfrz + real (kind_phys) :: DZS,R1,R2,R3,R4,R5,R6,R7,R8,R9,R10 + real (kind_phys) :: REFKDT,REFDK,DELT1,F1MAX,F2MAX + real (kind_phys) :: F1,F2,FD,KDT,VAL,DDT,PX,FK,FKMAX + real (kind_phys) :: QQ,UMVEG,INFMAX1,TRANS + real (kind_phys) :: TOTLIQ,FLX,FLXSAT,QTOT + real (kind_phys) :: DID,X1,X2,X4,DENOM,Q2,Q4 + real (kind_phys) :: dice,fcr,acrt,frzx,sum,cvfrz INTEGER :: NZS1,NZS2,K,KK,K1,KN,ialp1,jj,jk @@ -6136,10 +6136,10 @@ SUBROUTINE SOILMOIST ( debug_print, & ! ----------- FROZEN GROUND VERSION ------------------------- ! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF -! Areal (kind=kind_phys) DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. +! Areal (kind_phys) DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. ! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. -! BASED ON FIELD DATA CV DEPENDS ON Areal (kind=kind_phys) MEAN OF FROZEN DEPTH, AND IT -! CLOSE TO CONSTANT = 0.6 IF Areal (kind=kind_phys) MEAN FROZEN DEPTH IS ABOVE 20 CM. +! BASED ON FIELD DATA CV DEPENDS ON Areal (kind_phys) MEAN OF FROZEN DEPTH, AND IT +! CLOSE TO CONSTANT = 0.6 IF Areal (kind_phys) MEAN FROZEN DEPTH IS ABOVE 20 CM. ! THAT IS WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}) ! ! Current logic doesn't allow CVFRZ be bigger than 3 @@ -6327,7 +6327,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- soil properties LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: NZS - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -6336,12 +6336,12 @@ SUBROUTINE SOILPROP( debug_print, & QWRTZ, & QMIN - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(IN ) :: SOILMOIS, & keepfr - real (kind=kind_phys), INTENT(IN ) :: CP, & + real (kind_phys), INTENT(IN ) :: CP, & CVW, & RIW, & kqwrtz, & @@ -6353,7 +6353,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- output variables - real (kind=kind_phys), DIMENSION(1:NZS) , & + real (kind_phys), DIMENSION(1:NZS) , & INTENT(INOUT) :: cap,diffu,hydro , & thdif,tav , & soilmoism , & @@ -6362,14 +6362,14 @@ SUBROUTINE SOILPROP( debug_print, & fwsat,lwsat !--- local variables - real (kind=kind_phys), DIMENSION(1:NZS) :: hk,detal,kasat,kjpl + real (kind_phys), DIMENSION(1:NZS) :: hk,detal,kasat,kjpl - real (kind=kind_phys) :: x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci - real (kind=kind_phys) :: tln,tavln,tn,pf,a,am,ame,h + real (kind_phys) :: x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci + real (kind_phys) :: tln,tavln,tn,pf,a,am,ame,h INTEGER :: nzs1,k !-- for Johansen thermal conductivity - real (kind=kind_phys) :: kzero,gamd,kdry,kas,x5,sr,ke + real (kind_phys) :: kzero,gamd,kdry,kas,x5,sr,ke nzs1=nzs-1 @@ -6524,31 +6524,31 @@ SUBROUTINE TRANSF( debug_print, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: nroot,nzs,iland - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GSWin, TABS, lai !--- soil properties - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: DQM, & QMIN, & REF, & PC, & WILT - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & ZSHALF !-- output - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: TRANF - real (kind=kind_phys), INTENT(OUT) :: TRANSUM + real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: TRANF + real (kind_phys), INTENT(OUT) :: TRANSUM !-- local variables - real (kind=kind_phys) :: totliq, did + real (kind_phys) :: totliq, did INTEGER :: k !-- for non-linear root distribution - real (kind=kind_phys) :: gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4 - real (kind=kind_phys) :: FTEM, PCtot, fsol, f1, cmin, cmax, totcnd - real (kind=kind_phys), DIMENSION(1:NZS) :: PART + real (kind_phys) :: gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4 + real (kind_phys) :: FTEM, PCtot, fsol, f1, cmin, cmax, totcnd + real (kind_phys), DIMENSION(1:NZS) :: PART !-------------------------------------------------------------------- do k=1,nzs @@ -6689,13 +6689,13 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) !--- VILKA finds the solution of energy budget at the surface !--- using table T,QS computed from Clausius-Klapeiron !-------------------------------------------------------------- - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN ) :: TT - real (kind=kind_phys), INTENT(IN ) :: TN,D1,D2,PP,xlat,xlon + real (kind_phys), DIMENSION(1:5001), INTENT(IN ) :: TT + real (kind_phys), INTENT(IN ) :: TN,D1,D2,PP,xlat,xlon INTEGER, INTENT(IN ) :: NSTEP,ii,j,iland,isoil - real (kind=kind_phys), INTENT(OUT ) :: QS, TS + real (kind_phys), INTENT(OUT ) :: QS, TS - real (kind=kind_phys) :: F1,T1,T2,RN + real (kind_phys) :: F1,T1,T2,RN INTEGER :: I,I1 I=(TN-1.7315E2)/.05+1 @@ -6787,7 +6787,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & ! 19 White Sand ! !---------------------------------------------------------------------- - real (kind=kind_phys) LQMA(nsoilclas),LRHC(nsoilclas), & + real (kind_phys) LQMA(nsoilclas),LRHC(nsoilclas), & LPSI(nsoilclas),LQMI(nsoilclas), & LBCL(nsoilclas),LKAS(nsoilclas), & LWIL(nsoilclas),LREF(nsoilclas), & @@ -6924,7 +6924,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & !---- Below are the arrays for the vegetation parameters - real (kind=kind_phys) LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & + real (kind_phys) LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & LROU(nvegclas),LTHI(nvegclas),LSIG(nvegclas), & LPC(nvegclas) @@ -6959,24 +6959,24 @@ SUBROUTINE SOILVEGIN ( debug_print, & ISLTYP LOGICAL, INTENT(IN ) :: myj - real (kind=kind_phys), INTENT(IN ) :: SHDMAX - real (kind=kind_phys), INTENT(IN ) :: SHDMIN - real (kind=kind_phys), INTENT(IN ) :: VEGFRAC - real (kind=kind_phys), DIMENSION( 1:NLCAT ), INTENT(IN):: LUFRAC - real (kind=kind_phys), DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC + real (kind_phys), INTENT(IN ) :: SHDMAX + real (kind_phys), INTENT(IN ) :: SHDMIN + real (kind_phys), INTENT(IN ) :: VEGFRAC + real (kind_phys), DIMENSION( 1:NLCAT ), INTENT(IN):: LUFRAC + real (kind_phys), DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC - real (kind=kind_phys) , & + real (kind_phys) , & INTENT ( OUT) :: pc, & msnf, & facsnf - real (kind=kind_phys) , & + real (kind_phys) , & INTENT (INOUT ) :: emiss, & lai, & znt LOGICAL, intent(in) :: rdlai2d !--- soil properties - real (kind=kind_phys) , & + real (kind_phys) , & INTENT( OUT) :: RHOCS, & BCLH, & DQM, & @@ -6991,8 +6991,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & integer, intent(out) :: errflg INTEGER :: kstart, kfin, lstart, lfin INTEGER :: k - real (kind=kind_phys) :: area, factor, znt1, lb - real (kind=kind_phys), DIMENSION( 1:NLCAT ) :: ZNTtoday, LAItoday, deltalai + real (kind_phys) :: area, factor, znt1, lb + real (kind_phys), DIMENSION( 1:NLCAT ) :: ZNTtoday, LAItoday, deltalai !*********************************************************************** ! DATA ZS1/0.0,0.05,0.20,0.40,1.6,3.0/ ! o - levels in soil @@ -7203,33 +7203,33 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & #endif IMPLICIT NONE LOGICAL, INTENT(IN ) :: debug_print - real (kind=kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: landfrac, fice - real (kind=kind_phys), INTENT(IN ) :: min_seaice + real (kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: landfrac, fice + real (kind_phys), INTENT(IN ) :: min_seaice INTEGER, INTENT(IN ) :: & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & nzs - real (kind=kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ), & + real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ), & INTENT(IN) :: TSLB, & SMOIS INTEGER, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: ISLTYP,IVGTYP - real (kind=kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , & INTENT(OUT) :: SMFR3D, & SH2O - real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: MAVAIL !-- local - real (kind=kind_phys), DIMENSION ( 1:nzs ) :: SOILIQW + real (kind_phys), DIMENSION ( 1:nzs ) :: SOILIQW INTEGER :: I,J,L,itf,jtf - real (kind=kind_phys) :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH + real (kind_phys) :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH INTEGER :: errflag @@ -7624,7 +7624,7 @@ SUBROUTINE SOILIN (ISLTYP, DQM, REF, PSIS, QMIN, BCLH ) integer, intent ( in) :: isltyp real, intent ( out) :: dqm,ref,qmin,psis,bclh - real (kind=kind_phys) LQMA(nsoilclas),LREF(nsoilclas),LBCL(nsoilclas), & + real (kind_phys) LQMA(nsoilclas),LREF(nsoilclas),LBCL(nsoilclas), & LPSI(nsoilclas),LQMI(nsoilclas) !-- LQMA Rawls et al.[1982] @@ -7672,20 +7672,20 @@ END SUBROUTINE SOILIN !>\ingroup lsm_ruc_group !> This function calculates the liquid saturation vapor mixing ratio as !! a function of temperature and pressure (from Thompson scheme). - real (kind=kind_phys) FUNCTION RSLF(P,T) + real (kind_phys) FUNCTION RSLF(P,T) IMPLICIT NONE - real (kind=kind_phys), INTENT(IN):: P, T - real (kind=kind_phys):: ESL,X - real (kind=kind_phys), PARAMETER:: C0= .611583699E03 - real (kind=kind_phys), PARAMETER:: C1= .444606896E02 - real (kind=kind_phys), PARAMETER:: C2= .143177157E01 - real (kind=kind_phys), PARAMETER:: C3= .264224321E-1 - real (kind=kind_phys), PARAMETER:: C4= .299291081E-3 - real (kind=kind_phys), PARAMETER:: C5= .203154182E-5 - real (kind=kind_phys), PARAMETER:: C6= .702620698E-8 - real (kind=kind_phys), PARAMETER:: C7= .379534310E-11 - real (kind=kind_phys), PARAMETER:: C8=-.321582393E-13 + real (kind_phys), INTENT(IN):: P, T + real (kind_phys):: ESL,X + real (kind_phys), PARAMETER:: C0= .611583699E03 + real (kind_phys), PARAMETER:: C1= .444606896E02 + real (kind_phys), PARAMETER:: C2= .143177157E01 + real (kind_phys), PARAMETER:: C3= .264224321E-1 + real (kind_phys), PARAMETER:: C4= .299291081E-3 + real (kind_phys), PARAMETER:: C5= .203154182E-5 + real (kind_phys), PARAMETER:: C6= .702620698E-8 + real (kind_phys), PARAMETER:: C7= .379534310E-11 + real (kind_phys), PARAMETER:: C8=-.321582393E-13 X=MAX(-80.,T-273.16) diff --git a/physics/namelist_soilveg_ruc.F90 b/physics/namelist_soilveg_ruc.F90 index 2270d35eb..d71d2ebfd 100644 --- a/physics/namelist_soilveg_ruc.F90 +++ b/physics/namelist_soilveg_ruc.F90 @@ -1,6 +1,10 @@ !>\file namelist_soilveg_ruc.F90 !>\ingroup RUC_lsm + module namelist_soilveg_ruc + + use machine , only : kind_phys + implicit none save @@ -12,27 +16,27 @@ module namelist_soilveg_ruc PARAMETER(MAX_SOILTYP = 30) PARAMETER(MAX_VEGTYP = 30) - REAL SLOPE_DATA(MAX_SLOPETYP) + real(kind_phys) SLOPE_DATA(MAX_SLOPETYP) !> vegetation - REAL ALBTBL(MAX_VEGTYP) - REAL Z0TBL(MAX_VEGTYP) - REAL LEMITBL(MAX_VEGTYP) - REAL PCTBL(MAX_VEGTYP) - REAL SHDTBL(MAX_VEGTYP) + real(kind_phys) ALBTBL(MAX_VEGTYP) + real(kind_phys) Z0TBL(MAX_VEGTYP) + real(kind_phys) LEMITBL(MAX_VEGTYP) + real(kind_phys) PCTBL(MAX_VEGTYP) + real(kind_phys) SHDTBL(MAX_VEGTYP) INTEGER IFORTBL(MAX_VEGTYP) - REAL RSTBL(MAX_VEGTYP) - REAL RGLTBL(MAX_VEGTYP) - REAL HSTBL(MAX_VEGTYP) - REAL SNUPTBL(MAX_VEGTYP) - REAL LAITBL(MAX_VEGTYP) - REAL MAXALB(MAX_VEGTYP) - REAL MFSNO(MAX_VEGTYP) - REAL SNCOVFAC(MAX_VEGTYP) + real(kind_phys) RSTBL(MAX_VEGTYP) + real(kind_phys) RGLTBL(MAX_VEGTYP) + real(kind_phys) HSTBL(MAX_VEGTYP) + real(kind_phys) SNUPTBL(MAX_VEGTYP) + real(kind_phys) LAITBL(MAX_VEGTYP) + real(kind_phys) MAXALB(MAX_VEGTYP) + real(kind_phys) MFSNO(MAX_VEGTYP) + real(kind_phys) SNCOVFAC(MAX_VEGTYP) LOGICAL LPARAM - REAL TOPT_DATA - REAL CMCMAX_DATA - REAL CFACTR_DATA - REAL RSMAX_DATA + real(kind_phys) TOPT_DATA + real(kind_phys) CMCMAX_DATA + real(kind_phys) CFACTR_DATA + real(kind_phys) RSMAX_DATA INTEGER BARE INTEGER GLACIER INTEGER NATURAL @@ -43,21 +47,21 @@ module namelist_soilveg_ruc INTEGER DEFINED_SLOPE INTEGER MOSAIC_LU !> -- soils - REAL BB(MAX_SOILTYP) - REAL DRYSMC(MAX_SOILTYP) - REAL HC(MAX_SOILTYP) - REAL MAXSMC(MAX_SOILTYP) - REAL REFSMC(MAX_SOILTYP) - REAL SATPSI(MAX_SOILTYP) - REAL SATDK(MAX_SOILTYP) - REAL SATDW(MAX_SOILTYP) - REAL WLTSMC(MAX_SOILTYP) - REAL QTZ(MAX_SOILTYP) - REAL REFSMCnoah(MAX_SOILTYP) - REAL WLTSMCnoah(MAX_SOILTYP) - REAL BBnoah(MAX_SOILTYP) - REAL SATDKnoah(MAX_SOILTYP) - REAL SATPSInoah(MAX_SOILTYP) - REAL MAXSMCnoah(MAX_SOILTYP) + real(kind_phys) BB(MAX_SOILTYP) + real(kind_phys) DRYSMC(MAX_SOILTYP) + real(kind_phys) HC(MAX_SOILTYP) + real(kind_phys) MAXSMC(MAX_SOILTYP) + real(kind_phys) REFSMC(MAX_SOILTYP) + real(kind_phys) SATPSI(MAX_SOILTYP) + real(kind_phys) SATDK(MAX_SOILTYP) + real(kind_phys) SATDW(MAX_SOILTYP) + real(kind_phys) WLTSMC(MAX_SOILTYP) + real(kind_phys) QTZ(MAX_SOILTYP) + real(kind_phys) REFSMCnoah(MAX_SOILTYP) + real(kind_phys) WLTSMCnoah(MAX_SOILTYP) + real(kind_phys) BBnoah(MAX_SOILTYP) + real(kind_phys) SATDKnoah(MAX_SOILTYP) + real(kind_phys) SATPSInoah(MAX_SOILTYP) + real(kind_phys) MAXSMCnoah(MAX_SOILTYP) INTEGER MOSAIC_SOIL end module namelist_soilveg_ruc diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index 79c1be310..f04a49648 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -4,6 +4,7 @@ module set_soilveg_ruc_mod + use machine , only : kind_phys use namelist_soilveg_ruc implicit none @@ -25,7 +26,7 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) integer me integer i - real refsmc1, wltsmc1 + real(kind_phys) refsmc1, wltsmc1 NAMELIST /SOIL_VEG_RUC/ SLOPE_DATA, ALBTBL, Z0TBL, LEMITBL, & & PCTBL, SHDTBL, & From 01adfea9672f5cef3edf2e27418d3830ef240ad2 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 21 Mar 2023 18:24:58 +0000 Subject: [PATCH 11/28] Fixed the problem in sfc_daig.f: it was using "surface_exchange_coefficient_for_heat_at_2m" which is provided only by MYNN surface layer scheme and not the others. Now this variable is comuted internally in sfc_diag.f. --- physics/sfc_diag.f | 21 ++++++++++++--------- physics/sfc_diag.meta | 31 +++++++++++++++---------------- 2 files changed, 27 insertions(+), 25 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index f5bd081e0..585bd4b7d 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -22,10 +22,10 @@ end subroutine sfc_diag_finalize !! \section detailed Detailed Algorithm !! @{ subroutine sfc_diag_run (im,xlat_d,xlon_d, & - & lsm,lsm_ruc,grav,cp,eps,epsm1,rocp, & - & wet,shflx,chs2,cqs2,cdq,wind, & + & lsm,lsm_ruc,grav,cp,eps,epsm1,rocp,con_karman,& + & wet,shflx,cdq,wind, & & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & - & tskin,qsurf,thsfc_loc,diag_flux,diag_log, & + & ust,tskin,qsurf,thsfc_loc,diag_flux,diag_log, & & f10m,u10m,v10m,t2m,q2m,dpt2m,errmsg,errflg & & ) ! @@ -38,10 +38,11 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & logical, intent(in) :: diag_flux ! Flag for flux method in 2-m diagnostics logical, intent(in) :: diag_log ! Flag for 2-m log diagnostics under stable conditions real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1,rocp + real(kind=kind_phys), intent(in) :: con_karman real(kind=kind_phys), dimension(:), intent( in) :: & - & zf, ps, u1, v1, t1, q1, tskin, wet, & + & zf, ps, u1, v1, t1, q1, ust, tskin, wet, & & qsurf, prslki, evap, fm, fh, fm10, fh2, & - & shflx, chs2, cqs2, cdq, wind, xlat_d, xlon_d + & shflx, cdq, wind, xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(out) :: & & f10m, u10m, v10m, t2m, q2m, dpt2m character(len=*), intent(out) :: errmsg @@ -54,7 +55,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & real(kind=kind_phys) :: q1c, qv, tem, qv1, th2m, x2m, rho real(kind=kind_phys) :: dT, dQ, qsfcmr, qsfcprox, ff, fac, dz1 real(kind=kind_phys) :: t2_alt, q2_alt - real(kind=kind_phys) :: thcon, cqs, chs + real(kind=kind_phys) :: thcon, cqs, chs, chs2, cqs2 real(kind=kind_phys) :: testptlat, testptlon integer :: k,i ! @@ -104,6 +105,8 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & qsfcmr = qsurf(i)/(1. - qsurf(i)) ! surface mixing ratio chs = cdq(i) * wind(i) cqs = chs + chs2 = ust(i)*con_karman/fh2(i) + cqs2 = chs2 qsfcprox = max(qmin,qv1 + evap(i)/cqs) ! surface mix. ratio computed from the flux if(.not. diag_flux) then @@ -128,10 +131,10 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & else !-- flux method - th2m = tskin(i)*thcon - shflx(i)/chs2(i) + th2m = tskin(i)*thcon - shflx(i)/chs2 t2m(i) = th2m/thcon - x2m = max(qmin,qsfcprox - evap(i)/cqs2(i)) ! mix. ratio + x2m = max(qmin,qsfcprox - evap(i)/cqs2) ! mix. ratio q2m(i) = x2m/(1. + x2m) ! spec. humidity endif ! flux method @@ -206,7 +209,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & & 'tskin ',tskin(i),'t2m ',t2m(i),'t1',t1(i),'shflx',shflx(i),& & 'qsurf ',qsurf(i),'qsfcprox ',qsfcprox,'q2m ',q2m(i), & & 'q1 ',q1(i),'evap ',evap(i),'dpt2m ',dpt2m(i), & - & 'chs2 ',chs2(i),'cqs2 ',cqs2(i),'cqs ',cqs,'cdq',cdq(i) + & 'chs2 ',chs2,'cqs2 ',cqs2,'cqs ',cqs,'cdq',cdq(i) endif endif 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es11.4))) diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index 91a5c8d41..7618a4a00 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -84,6 +84,13 @@ type = real kind = kind_phys intent = in +[con_karman] + standard_name = von_karman_constant + long_name = von karman constant + units = none + dimensions = () + type = real + intent = in [wet] standard_name = normalized_soil_wetness_for_land_surface_model long_name = normalized soil wetness @@ -188,6 +195,14 @@ type = real kind = kind_phys intent = in +[ust] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [tskin] standard_name = surface_skin_temperature long_name = surface skin temperature @@ -233,22 +248,6 @@ type = real kind = kind_phys intent = in -[chs2] - standard_name = surface_exchange_coefficient_for_heat_at_2m - long_name = exchange coefficient for heat at 2 meters - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[cqs2] - standard_name = surface_exchange_coefficient_for_moisture_at_2m - long_name = exchange coefficient for moisture at 2 meters - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [cdq] standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air long_name = surface exchange coeff heat & moisture From faba00461b20c9d1a121a80a44f59f02c59584ff Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 21 Mar 2023 19:34:52 +0000 Subject: [PATCH 12/28] Continue changes for kind_phys with constants. --- physics/module_sf_ruclsm.F90 | 968 +++++++++++++++++------------------ 1 file changed, 483 insertions(+), 485 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index dcc4723c3..ea253ad2a 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -27,6 +27,7 @@ MODULE module_sf_ruclsm real (kind_phys), parameter :: r_v = 461.50_kind_dbl_prec real (kind_phys), parameter :: zero = 0._kind_dbl_prec real (kind_phys), parameter :: one = 1._kind_dbl_prec + real (kind_phys), parameter :: tfrz = 273.15_kind_dbl_prec !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 integer, parameter :: isncond_opt = 1 @@ -190,12 +191,12 @@ SUBROUTINE LSMRUC(xlat,xlon, & LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden INTEGER, INTENT(IN ) :: NLCAT, NSCAT INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & - ims,ime, jms,jme, kms,kme, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ! LOGICAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: flag_iter, flag - real (kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ) , & INTENT(IN ) :: QV3D, & QC3D, & p8w, & @@ -203,7 +204,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & T3D, & z3D - real (kind_phys), DIMENSION( ims:ime , jms:jme ), & + real (kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: RAINBL, & GLW, & GSWdn, & @@ -258,10 +259,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & real (kind_phys), DIMENSION( ims:ime , 1:nlcat, jms:jme ), INTENT(IN):: LANDUSEF real (kind_phys), DIMENSION( ims:ime , 1:nscat, jms:jme ), INTENT(IN):: SOILCTOP - real (kind_phys), INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & + real (kind_phys), INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & XICE_threshold - real (kind_phys), DIMENSION( ims:ime , 1:nsl, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime , 1:nsl, jms:jme ) , & INTENT(INOUT) :: SOILMOIS,SH2O,TSO real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & @@ -326,7 +327,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & :: KEEPFR3DFLAG, & SMFR3D - real (kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & + real (kind_phys),DIMENSION( ims:ime, jms:jme ),INTENT(OUT) :: & RHOSNF, & ! RHO of snowfall PRECIPFR, & ! time-step frozen precip SNOWFALLAC @@ -358,13 +359,13 @@ SUBROUTINE LSMRUC(xlat,xlon, & KWT - real (kind_phys), DIMENSION(1:NSL) :: ZSMAIN, & - ZSHALF, & - DTDZS2 + real (kind_phys), DIMENSION(1:NSL) :: ZSMAIN, & + ZSHALF, & + DTDZS2 - real (kind_phys), DIMENSION(1:2*(nsl-2)) :: DTDZS + real (kind_phys), DIMENSION(1:2*(nsl-2)) :: DTDZS - real (kind_phys), DIMENSION(1:5001) :: TBQ + real (kind_phys), DIMENSION(1:5001) :: TBQ real (kind_phys), DIMENSION( 1:nsl ) :: SOILM1D, & @@ -373,10 +374,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & SOILIQW, & SMFRKEEP - real (kind_phys), DIMENSION( 1:nsl ) :: KEEPFR + real (kind_phys), DIMENSION( 1:nsl ) :: KEEPFR - real (kind_phys), DIMENSION( 1:nlcat ) :: lufrac - real (kind_phys), DIMENSION( 1:nscat ) :: soilfrac + real (kind_phys), DIMENSION( 1:nlcat ) :: lufrac + real (kind_phys), DIMENSION( 1:nscat ) :: soilfrac real (kind_phys) :: RSM, & SNWEPRINT, & @@ -441,22 +442,21 @@ SUBROUTINE LSMRUC(xlat,xlon, & !> - Table TBQ is for resolution of balance equation in vilka() CQ=173.15_kind_dbl_prec-.05_kind_dbl_prec - R273=1._kind_dbl_prec/273.15_kind_dbl_prec + R273=1._kind_dbl_prec/tfrz R61=6.1153_kind_dbl_prec*0.62198_kind_dbl_prec ARP=77455._kind_dbl_prec*41.9_kind_dbl_prec/461.525_kind_dbl_prec BRP=64._kind_dbl_prec*41.9_kind_dbl_prec/461.525_kind_dbl_prec DO K=1,5001 CQ=CQ+.05_kind_dbl_prec - EVS=EXP(17.67_kind_dbl_prec*(CQ-273.15_kind_dbl_prec)/(CQ-29.65_kind_dbl_prec)) - EIS=EXP(22.514_kind_phys-6.15E3_kind_dbl_prec/CQ) - if(CQ.ge.273.15_kind_dbl_prec) then -! tbq is in mb - tbq(k) = R61*evs - else - tbq(k) = R61*eis - endif - + EVS=EXP(17.67_kind_dbl_prec*(CQ-tfrz)/(CQ-29.65_kind_dbl_prec)) + EIS=EXP(22.514_kind_dbl_prec-6.15E3_kind_dbl_prec/CQ) + if(CQ.ge.tfrz) then + ! tbq is in mb + tbq(k) = R61*evs + else + tbq(k) = R61*eis + endif END DO !> - Initialize soil/vegetation parameters @@ -472,7 +472,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & !> - Initializing inside-snow temp if it is not defined IF((soilt1(i,j) .LT. 170._kind_phys) .or. (soilt1(i,j) .GT.400._kind_phys)) THEN IF(snowc(i,j).gt.zero) THEN - soilt1(i,j)=min(273.15_kind_phys,0.5_kind_phys*(soilt(i,j)+tso(i,1,j)) ) + soilt1(i,j)=min(tfrz,0.5_kind_phys*(soilt(i,j)+tso(i,1,j)) ) IF (debug_print ) THEN print *, & 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,xlat,xlon @@ -481,7 +481,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & soilt1(i,j) = tso(i,1,j) ENDIF ENDIF - tsnav(i,j) =min(zero,0.5_kind_phys*(soilt(i,j)+tso(i,1,j))-273.15_kind_phys) + tsnav(i,j) =min(zero,0.5_kind_phys*(soilt(i,j)+tso(i,1,j))-tfrz) !- 10feb22 - limit snow albedo at high elevations !- based on Roesch et al., Climate Dynamics (2001),17:933-946 if(hgt(i,j) > 2500._kind_phys) then @@ -582,7 +582,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif ENDIF - ILAND = IVGTYP(i,j) ISOIL = ISLTYP(I,J) TABS = T3D(i,kms,j) @@ -605,11 +604,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & !> - Apply the same frozen precipitation fraction to convective precip !tgs - 31 mar17 - add temperature check in case Thompson MP produces ! frozen precip at T > 273. - if(frzfrac(i,j) > zero .and. tabs < 273._kind_phys) then + if(frzfrac(i,j) > zero .and. tabs < tfrz) then prcpculiq = max(zero,raincv(i,j)*(one-frzfrac(i,j))) prcpcufr = max(zero,raincv(i,j)*frzfrac(i,j)) else - if(tabs < 273._kind_phys) then + if(tabs < tfrz) then prcpcufr = max(zero,raincv(i,j)) prcpculiq = zero else @@ -631,7 +630,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif ELSE ! .not. FRPCPN - if (tabs.le.273.15_kind_phys) then + if (tabs.le.tfrz) then PRCPMS = zero NEWSNMS = RAINBL(i,j)/DT*1.e-3_kind_phys !> - If here no info about constituents of frozen precipitation, @@ -765,7 +764,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & ENDIF CN=CFACTR_DATA ! exponent - SAT = 5.e-4 ! units [m] + SAT = 5.e-4_kind_phys ! units [m] !-- definition of number of soil levels in the rooting zone IF(iforest.gt.2) THEN @@ -774,10 +773,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! for open areas factor is 2, and for forests - factor is 0.85 ! This will make limit on snow melting smaller and let snow stay ! longer in the forests. - meltfactor = 2.0 + meltfactor = 2.0_kind_phys do k=2,nzs - if(zsmain(k).ge.0.4) then + if(zsmain(k).ge.0.4_kind_phys) then NROOT=K goto 111 endif @@ -789,10 +788,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! 28 March 11 - Previously used value of metfactor= 1.5 needs to be further reduced ! to compensate for low snow albedos in the forested areas. ! Melting rate in forests will reduce. - meltfactor = 0.85 + meltfactor = 0.85_kind_phys do k=2,nzs - if(zsmain(k).ge.1.1) then + if(zsmain(k).ge.1.1_kind_phys) then NROOT=K goto 111 endif @@ -808,29 +807,29 @@ SUBROUTINE LSMRUC(xlat,xlon, & print *,'NROOT, meltfactor, iforest, ivgtyp, i,j ', nroot,meltfactor,iforest,ivgtyp(I,J),I,J ENDIF - IF((XLAND(I,J)-1.5).GE.0.)THEN + IF((XLAND(I,J)-1.5).GE.0._kind_phys)THEN !-- Water - SMAVAIL(I,J)=1.0 - SMMAX(I,J)=1.0 - SNOW(I,J)=0.0 - SNOWH(I,J)=0.0 - SNOWC(I,J)=0.0 - LMAVAIL(I,J)=1.0 + SMAVAIL(I,J)= one + SMMAX(I,J)= one + SNOW(I,J) = zero + SNOWH(I,J)= zero + SNOWC(I,J)= zero + LMAVAIL(I,J)= one ! accumulated water equivalent of frozen precipitation over water [mm] acsnow(i,j)=acsnow(i,j)+precipfr(i,j) ILAND=iswater ISOIL=14 - patmb=P8w(i,1,j)*1.e-2 + patmb=P8w(i,1,j)*1.e-2_kind_phys qvg (i,j) = QSN(SOILT(i,j),TBQ)/PATMB qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) - CHKLOWQ(I,J)=1. + CHKLOWQ(I,J)= one Q2SAT=QSN(TABS,TBQ)/PATMB DO K=1,NZS - SOILMOIS(I,K,J)=1.0 - SH2O (I,K,J)=1.0 + SOILMOIS(I,K,J)=one + SH2O (I,K,J)=one TSO(I,K,J)= SOILT(I,J) ENDDO @@ -843,12 +842,12 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! LAND POINT OR SEA ICE if(xice(i,j).ge.xice_threshold) then - SEAICE(i,j)=1. + SEAICE(i,j)=one else - SEAICE(i,j)=0. + SEAICE(i,j)=zero endif - IF(SEAICE(I,J).GT.0.5)THEN + IF(SEAICE(I,J).GT.0.5_kind_phys)THEN !-- Sea-ice case IF (debug_print ) THEN PRINT*,' sea-ice at water point, I=',I, & @@ -860,25 +859,25 @@ SUBROUTINE LSMRUC(xlat,xlon, & else ISOIL = 16 ! STATSGO endif - ZNT(I,J) = 0.011 + ZNT(I,J) = 0.011_kind_phys ! in FV3 albedo and emiss are defined for ice emissl(i,j) = emisbck(i,j) ! no snow impact, old 0.98 used in WRF - dqm = 1. - ref = 1. - qmin = 0. - wilt = 0. + dqm = one + ref = one + qmin = zero + wilt = zero - patmb=P8w(i,1,j)*1.e-2 + patmb=P8w(i,1,j)*1.e-2_kind_phys qvg (i,j) = QSN(SOILT(i,j),TBQ)/PATMB qsg (i,j) = qvg(i,j) qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) DO K=1,NZS - soilmois(i,k,j) = 1. - smfr3d(i,k,j) = 1. - sh2o(i,k,j) = 0. - keepfr3dflag(i,k,j) = 0. - tso(i,k,j) = min(271.4,tso(i,k,j)) + soilmois(i,k,j) = one + smfr3d(i,k,j) = one + sh2o(i,k,j) = zero + keepfr3dflag(i,k,j) = zero + tso(i,k,j) = min(271.4_kind_phys,tso(i,k,j)) ENDDO ENDIF @@ -887,10 +886,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & DO k=1,nzs ! soilm1d - soil moisture content minus residual [m**3/m**3] - soilm1d (k) = min(max(0.,soilmois(i,k,j)-qmin),dqm) + soilm1d (k) = min(max(zero,soilmois(i,k,j)-qmin),dqm) tso1d (k) = tso(i,k,j) - soiliqw (k) = min(max(0.,sh2o(i,k,j)-qmin),soilm1d(k)) - soilice (k) =(soilm1d (k) - soiliqw (k))/0.9 + soiliqw (k) = min(max(zero,sh2o(i,k,j)-qmin),soilm1d(k)) + soilice (k) =(soilm1d (k) - soiliqw (k))/0.9_kind_phys ENDDO do k=1,nzs @@ -898,7 +897,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & keepfr (k) = keepfr3dflag(i,k,j) enddo - LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/(ref-qmin))) + LMAVAIL(I,J)=max(0.00001_kind_phys,min(one,soilm1d(1)/(ref-qmin))) IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.2 .and. & @@ -971,10 +970,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & !tgs - turn off "irrigation" while there is no fractional landuse and LAI !climatology. if(1==2) then - IF (lufrac(crop) > 0 .and. lai(i,j) > 1.1) THEN + IF (lufrac(crop) > zero .and. lai(i,j) > 1.1_kind_phys) THEN ! cropland do k=1,nroot - cropsm=1.1*wilt - qmin + cropsm=1.1_kind_phys*wilt - qmin if(soilm1d(k) < cropsm*lufrac(crop)) then IF (debug_print ) THEN print * ,'Soil moisture is below wilting in cropland category at time step',ktau & @@ -991,14 +990,14 @@ SUBROUTINE LSMRUC(xlat,xlon, & ELSEIF (ivgtyp(i,j) == natural .and. lai(i,j) > 0.7) THEN ! grassland: assume that 40% of grassland is irrigated cropland do k=1,nroot - cropsm=1.2*wilt - qmin + cropsm=1.2_kind_phys*wilt - qmin if(soilm1d(k) < cropsm*lufrac(natural)*0.4) then IF (debug_print ) THEN print * ,'Soil moisture is below wilting in mixed grassland/cropland category at time step',ktau & ,'i,j,lufrac(natural),k,soilm1d(k),wilt', & i,j,lufrac(natural),k,soilm1d(k),wilt ENDIF - soilm1d(k) = cropsm * lufrac(natural)*0.4 + soilm1d(k) = cropsm * lufrac(natural)*0.4_kind_phys IF (debug_print ) THEN print * ,'Added soil water to grassland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) ENDIF @@ -1011,8 +1010,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & !--- available and maximum soil moisture content in the soil !--- domain - smavail(i,j) = 0. - smmax (i,j) = 0. + smavail(i,j) = zero + smmax (i,j) = zero !do k=1,nzs-1 !-- root-zone soil moisture @@ -1033,10 +1032,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & !--- Convert the water unit into mm !-- three lines below are commented because accumulation ! happens in sfc_drv_ruc - ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 - SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. ! mm - SMMAX (I,J) = SMMAX(I,J) * 1000. - smtotold (I,J) = smtotold(I,J) * 1000. ! mm + ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*rhowater + SMAVAIL (I,J) = SMAVAIL(I,J) * rhowater ! mm + SMMAX (I,J) = SMMAX(I,J) * rhowater + smtotold (I,J) = smtotold(I,J) * rhowater ! mm do k=1,nzs @@ -1058,24 +1057,24 @@ SUBROUTINE LSMRUC(xlat,xlon, & Z0 (I,J) = ZNT (I,J) SFCEXC (I,J) = TKMS - patmb=P8w(i,1,j)*1.e-2 + patmb=P8w(i,1,j)*1.e-2_kind_phys Q2SAT=QSN(TABS,TBQ)/PATMB - QSFC(I,J) = QVG(I,J)/(1.+QVG(I,J)) + QSFC(I,J) = QVG(I,J)/(one+QVG(I,J)) ! for MYJ surface and PBL scheme ! if (myj) then ! MYJSFC expects QSFC as actual specific humidity at the surface - IF((QVATM.GE.Q2SAT*0.95).AND.QVATM.LT.qvg(I,J))THEN - CHKLOWQ(I,J)=0. + IF((QVATM.GE.Q2SAT*0.95_kind_phys).AND.QVATM.LT.qvg(I,J))THEN + CHKLOWQ(I,J)=zero ELSE - CHKLOWQ(I,J)=1. + CHKLOWQ(I,J)=one ENDIF - if(snow(i,j)==0.) EMISSL(i,j) = EMISBCK(i,j) + if(snow(i,j)==zero) EMISSL(i,j) = EMISBCK(i,j) EMISS (I,J) = EMISSL(I,J) ! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m - SNOW (i,j) = SNWE*1000. + SNOW (i,j) = SNWE*1000._kind_phys SNOWH (I,J) = SNHEI - CANWAT (I,J) = CANWATR*1000. + CANWAT (I,J) = CANWATR*1000._kind_phys if (debug_print) then if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then @@ -1091,7 +1090,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif ENDIF SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT - GRDFLX (I,J) = -1. * sflx(I,J) + GRDFLX (I,J) = -one * sflx(I,J) !tgs - SMF.NE.0. when there is phase change in the top soil layer ! The heat of soil water freezing/thawing is not computed explicitly @@ -1117,16 +1116,16 @@ SUBROUTINE LSMRUC(xlat,xlon, & if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then !-- compute budget for a test point - ac=0. - as=0. - wb=0. + ac=zero + as=zero + wb=zero - ac=canwat(i,j)-canwatold(i,j)*1.e3 ! canopy water change + ac=canwat(i,j)-canwatold(i,j)*rhowater ! canopy water change as=snwe-snowold(i,j) ! SWE change wb = smavail(i,j)-smtotold(i,j) - waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3_kind_phys & ! source + waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*rhowater & ! source -qfx(i,j)*dt & - -runoff1(i,j)*dt*1.e3_kind_phys-runoff2(i,j)*dt*1.e3_kind_phys & + -runoff1(i,j)*dt*rhowater-runoff2(i,j)*dt*rhowater & -ac-as ! - (smavail(i,j)-smtotold(i,j)) print *,'soilm1d ',i,soilm1d @@ -1139,9 +1138,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & !-- print *,'Smf=',smf(i,j),i,j print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) - print *,'SNOW-SNOWold',i,j,max(0._kind_phys,snwe-snowold(i,j)) + print *,'SNOW-SNOWold',i,j,max(zero,snwe-snowold(i,j)) print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) - print *,'canwat(i,j)-canwatold(i,j)',max(0._kind_phys,canwat(i,j)-canwatold(i,j)) + print *,'canwat(i,j)-canwatold(i,j)',max(zero,canwat(i,j)-canwatold(i,j)) endif endif @@ -1215,12 +1214,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia real (kind_phys), INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex LOGICAL, INTENT(IN ) :: myj, debug_print, exticeden !--- 3-D Atmospheric variables - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: PATM, & TABS, & QVATM, & QCATM - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & GSWdn, & @@ -1237,7 +1236,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP !--- 2-D variables - real (kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: EMISS, & EMISBCK, & MAVAIL, & @@ -1247,7 +1246,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia CST !--- soil properties - real (kind_phys) :: & + real (kind_phys) :: & RHOCS, & BCLH, & DQM, & @@ -1259,7 +1258,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SAT, & WILT - real (kind_phys), INTENT(IN ) :: CN, & + real (kind_phys), INTENT(IN ) :: CN, & CW, & CP, & ROVCP, & @@ -1270,34 +1269,34 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia KICE, & KWT - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TS1D, & SOILM1D, & SMFRKEEP - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR - real (kind_phys), DIMENSION(1:NZS), INTENT(INOUT) :: SOILICE, & - SOILIQW + real (kind_phys), DIMENSION(1:NZS),INTENT(INOUT) :: SOILICE, & + SOILIQW INTEGER, INTENT(INOUT) :: ILAND,ISOIL INTEGER :: ILANDs !-------- 2-d variables - real (kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & EDIR1, & EC1, & @@ -1337,7 +1336,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia TSNAV, & ZNT - real (kind_phys), DIMENSION(1:NZS) :: & + real (kind_phys), DIMENSION(1:NZS) :: & tice, & rhosice, & capice, & @@ -1374,14 +1373,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia - real (kind_phys), INTENT(INOUT) :: RSM, & + real (kind_phys), INTENT(INOUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables INTEGER :: K,ILNB - real (kind_phys) :: BSN, XSN , & + real (kind_phys) :: BSN, XSN , & RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & T3, UPFLUX, XINET, snowfrac2, m real (kind_phys) :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn @@ -1410,23 +1409,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! with vegetation dependent parameters from Noah MP (personal ! communication with Mike Barlage) !-- SNHEI_CRIT is a threshold for fractional snow in isncovr_opt=1 - snhei_crit=0.01601_kind_phys*1.e3_kind_phys/rhosn - snhei_crit_newsn=0.0005*1.e3_kind_phys/rhosn + snhei_crit=0.01601_kind_phys*rhowater/rhosn + snhei_crit_newsn=0.0005_kind_phys*rhowater/rhosn !-- zntsn = z0tbl(isice) - snow_mosaic=0._kind_phys - snfr = 1._kind_phys - NEWSN=0._kind_phys - newsnowratio = 0._kind_phys - snowfracnewsn=0._kind_phys - snowfrac2=0._kind_phys + snow_mosaic = zero + snfr = one + NEWSN= zero + newsnowratio = zero + snowfracnewsn= zero + snowfrac2= zero rhonewsn = 100._kind_phys - if(snhei == 0._kind_phys) snowfrac=0._kind_phys - smelt = 0._kind_phys - RAINF = 0._kind_phys - RSM=0._kind_phys - DD1=0._kind_phys - INFILTR=0._kind_phys + if(snhei == zero) snowfrac=zero + smelt = zero + RAINF = zero + RSM = zero + DD1 = zero + INFILTR = zero ! Jul 2016 - Avissar and Pielke (1989) ! This formulation depending on LAI defines relative contribution of the vegetation to ! the total heat fluxes between surface and atmosphere. @@ -1435,21 +1434,21 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! VGFR=0.01*VEGFRA ! % --> fraction ! VEGFRAC=2.*lai*vgfr/(1.+2.*lai*vgfr) VEGFRAC=0.01_kind_phys*VEGFRA - drip = 0._kind_phys - dripsn = 0._kind_phys - dripliq = 0._kind_phys - smf = 0._kind_phys - interw=0._kind_phys - intersn=0._kind_phys - infwater=0._kind_phys + drip = zero + dripsn = zero + dripliq = zero + smf = zero + interw = zero + intersn = zero + infwater = zero !---initialize local arrays for sea ice do k=1,nzs - tice(k) = 0._kind_phys - rhosice(k) = 0._kind_phys - cice = 0._kind_phys - capice(k) = 0._kind_phys - thdifice(k) = 0._kind_phys + tice(k) = zero + rhosice(k) = zero + cice = zero + capice(k) = zero + thdifice(k) = zero enddo GSWnew=GSW @@ -1463,20 +1462,20 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !--- N.N Zubov "Arctic Ice" !--- no salinity dependence because we consider the ice pack !--- to be old and to have low salinity (0.0002) - if(SEAICE.ge.0.5) then + if(SEAICE.ge.0.5_kind_phys) then do k=1,nzs - tice(k) = ts1d(k) - 273.15 - rhosice(k) = 917.6/(1-0.000165*tice(k)) - cice = 2115.85 +7.7948*tice(k) + tice(k) = ts1d(k) - tfrz + rhosice(k) = 917.6_kind_phys/(one-0.000165_kind_phys*tice(k)) + cice = 2115.85_kind_phys +7.7948_kind_phys*tice(k) capice(k) = cice*rhosice(k) - thdifice(k) = 2.260872/capice(k) + thdifice(k) = 2.260872_kind_phys/capice(k) enddo !-- SEA ICE ALB dependence on ice temperature. When ice temperature is !-- below critical value of -10C - no change to albedo. !-- If temperature is higher that -10C then albedo is decreasing. !-- The minimum albedo at t=0C for ice is 0.1 less. - ALBice = MIN(ALB_SNOW_FREE,MAX(ALB_SNOW_FREE - 0.05, & - ALB_SNOW_FREE - 0.1*(tice(1)+10.)/10. )) + ALBice = MIN(ALB_SNOW_FREE,MAX(ALB_SNOW_FREE - 0.05_kind_phys, & + ALB_SNOW_FREE - 0.1_kind_phys*(tice(1)+10._kind_phys)/10._kind_phys )) endif IF (debug_print ) THEN @@ -1485,29 +1484,29 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE ENDIF - if(snhei.gt.0.0081*1.e3/rhosn) then + if(snhei.gt.0.0081_kind_phys*rhowater/rhosn) then !*** Update snow density for current temperature (Koren et al. 1999) - BSN=delt/3600.*c1sn*exp(0.08*min(0.,tsnav)-c2sn*rhosn*1.e-3) - if(bsn*snwe*100..lt.1.e-4) goto 777 - XSN=rhosn*(exp(bsn*snwe*100.)-1.)/(bsn*snwe*100.) - rhosn=MIN(MAX(58.8,XSN),500.) + BSN=delt/3600._kind_phys*c1sn*exp(0.08_kind_phys*min(zero,tsnav)-c2sn*rhosn*1.e-3_kind_phys) + if(bsn*snwe*100._kind_phys.lt.1.e-4_kind_phys) goto 777 + XSN=rhosn*(exp(bsn*snwe*100._kind_phys)-one)/(bsn*snwe*100._kind_phys) + rhosn=MIN(MAX(58.8_kind_phys,XSN),500._kind_phys) 777 continue endif !-- snow_mosaic from the previous time step - if(snowfrac < 0.75) snow_mosaic = 1. + if(snowfrac < 0.75_kind_phys) snow_mosaic = one newsn=newsnms*delt !---- ACSNOW - run-total snowfall water [mm] - acsnow=acsnow+newsn*1.e3 + acsnow=acsnow+newsn*rhowater - IF(NEWSN.GT.0.) THEN + IF(NEWSN.GT.zero) THEN IF (debug_print ) THEN print *, 'THERE IS NEW SNOW, newsn', newsn ENDIF - newsnowratio = min(1.,newsn/(snwe+newsn)) + newsnowratio = min(one,newsn/(snwe+newsn)) !if(isncovr_opt == 2) then !-- update snow fraction for fresh snowfall (Swenson&Lawrence,JGR,2012) @@ -1522,14 +1521,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if (exticeden) then rhonewsn = rhonewsn_ex else - rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-Tabs)*0.15)))) - rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-Tabs)*0.3333)))) + rhonewsn=min(125._kind_phys,rhowater/max(8._kind_phys,(17._kind_phys*tanh((276.65_kind_phys-Tabs)*0.15_kind_phys)))) + rhonewgr=min(500._kind_phys,rhowater/max(2._kind_phys,(3.5_kind_phys*tanh((274.15_kind_phys-Tabs)*0.3333_kind_phys)))) rhonewice=rhonewsn !--- compute density of "snowfall" from weighted contribution ! of snow, graupel and ice fractions - rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & + rhosnfall = min(500._kind_phys,max(58.8_kind_phys,(rhonewsn*snowrat + & rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) if (debug_print) then @@ -1548,10 +1547,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !*** without snow melt ) xsn=(rhosn*snwe+rhonewsn*newsn)/ & (snwe+newsn) - rhosn=MIN(MAX(58.8,XSN),500.) + rhosn=MIN(MAX(58.8_kind_phys,XSN),500._kind_phys) ENDIF ! end NEWSN > 0. - IF(PRCPMS.NE.0.) THEN + IF(PRCPMS > zero) THEN ! PRCPMS is liquid precipitation rate ! RAINF is a flag used for calculation of rain water @@ -1559,18 +1558,18 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! is set equal to air temperature at the first atmospheric ! level. - RAINF=1. + RAINF=one ENDIF - drip = 0. - intwratio=0. - if(vegfrac > 0.01) then + drip = zero + intwratio= zero + if(vegfrac > 0.01_kind_phys) then ! compute intercepted precipitation - Eq. 1 Lawrence et al., ! J. of Hydrometeorology, 2006, CLM. - interw=0.25*DELT*PRCPMS*(1.-exp(-0.5*lai))*vegfrac - intersn=0.25*NEWSN*(1.-exp(-0.5*lai))*vegfrac + interw=0.25_kind_phys*DELT*PRCPMS*(one-exp(-0.5_kind_phys*lai))*vegfrac + intersn=0.25_kind_phys*NEWSN*(one-exp(-0.5_kind_phys*lai))*vegfrac infwater=PRCPMS - interw/delt - if((interw+intersn) > 0.) then + if((interw+intersn) > zero) then intwratio=interw/(interw+intersn) endif @@ -1582,26 +1581,26 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia DRIP=DD1-SAT ENDIF else - CST=0. - DRIP=0. - interw=0. - intersn=0. + CST=zero + DRIP=zero + interw=zero + intersn=zero infwater=PRCPMS endif ! vegfrac > 0.01 - IF(NEWSN.GT.0.) THEN + IF(NEWSN.GT.zero) THEN !Update snow on the ground - snwe=max(0.,snwe+newsn-intersn) + snwe=max(zero,snwe+newsn-intersn) ! Add drip to snow on the ground - if(drip > 0.) then - if (snow_mosaic==1.) then + if(drip > zero) then + if (snow_mosaic==one) then dripliq=drip*intwratio dripsn = drip - dripliq snwe=snwe+dripsn infwater=infwater+dripliq - dripliq=0. - dripsn = 0. + dripliq=zero + dripsn = zero else snwe=snwe+drip endif @@ -1610,7 +1609,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia NEWSN=NEWSN*rhowater/rhonewsn ENDIF - IF(SNHEI.GT.0.0) THEN + IF(SNHEI.GT.zero) THEN !-- SNOW on the ground !--- Land-use category should be changed to snow/ice for grid points with snow>0 ILAND=ISICE @@ -1626,48 +1625,48 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! endif !-- update snow cover with accounting for fresh snow - m = 1.0_kind_phys ! m=1.6 in Niu&Yang, m=1 in CLM + m = one ! m=1.6 in Niu&Yang, m=1 in CLM if(isncovr_opt == 1) then - snowfrac=min(1._kind_phys,snhei/(2.*snhei_crit)) + snowfrac=min(one,snhei/(2._kind_phys*snhei_crit)) elseif(isncovr_opt == 2) then - snowfrac=min(1.,snhei/(2._kind_phys*snhei_crit)) + snowfrac=min(one,snhei/(2._kind_phys*snhei_crit)) if(ivgtyp == glacier .or. ivgtyp == bare) then !-- sparsely vegetated or land ice - snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**m)) + snowfrac2 = tanh( snhei/(2.5_kind_phys * 0.2_kind_phys *(rhosn/rhonewsn)**m)) else !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests ! on 3-km scale use actual roughness, but not higher than 0.2 m. ! The factor is 20 for forests (~100/dx = 33.) - snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m)) + snowfrac2 = tanh( snhei/(2.5_kind_phys *min(0.2_kind_phys,znt) *(rhosn/rhonewsn)**m)) endif !-- snow fraction is average between method 1 and 2 - snowfrac = 0.5*(snowfrac+snowfrac2) + snowfrac = 0.5_kind_phys*(snowfrac+snowfrac2) else !-- isncovr_opt=3 !m = msnf ! vegetation dependent facsnf/msnf from Noah MP !-- for RRFS a factor 10. was added to 'facsnf' to get reasonal values of ! snow cover fractions on the 3-km scale. ! This factor is scale dependent. - snowfrac = tanh( snhei/(10. * facsnf *(rhosn/rhonewsn)**m)) + snowfrac = tanh( snhei/(10._kind_phys * facsnf *(rhosn/rhonewsn)**m)) endif - if(newsn > 0. ) then - SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) + if(newsn > zero ) then + SNOWFRACnewsn=MIN(one,SNHEI/SNHEI_CRIT_newsn) endif !-- due to steep slopes and blown snow, limit snow fraction in the !-- mountains to 0.85 (based on Swiss weather model over the Alps) - if(hgt > 2500. .and. ivgtyp == glacier) snowfrac=min(0.85,snowfrac) + if(hgt > 2500._kind_phys .and. ivgtyp == glacier) snowfrac=min(0.85_kind_phys,snowfrac) !24nov15 - SNOWFRAC for urban category < 0.75 - if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + if(ivgtyp == urban) snowfrac=min(0.75_kind_phys,snowfrac) - if(snowfrac < 0.75) snow_mosaic = 1. + if(snowfrac < 0.75_kind_phys) snow_mosaic = one - KEEP_SNOW_ALBEDO = 0. - IF (NEWSN > 0. .and. snowfracnewsn > 0.99 .and. rhosnfall < 450.) THEN + KEEP_SNOW_ALBEDO = zero + IF (NEWSN > zero .and. snowfracnewsn > 0.99_kind_phys .and. rhosnfall < 450._kind_phys) THEN ! new snow - KEEP_SNOW_ALBEDO = 1. + KEEP_SNOW_ALBEDO = one !snow_mosaic=0. ! ??? ENDIF @@ -1678,33 +1677,33 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- Set znt for snow from VEGPARM table (snow/ice landuse), except for !-- land-use types with higher roughness (forests, urban). - IF(newsn.eq.0. .and. znt.le.0.2 .and. IVGTYP.ne.isice) then - if( snhei .le. 2.*ZNT)then + IF(newsn.eq.zero .and. znt.le.0.2_kind_phys .and. IVGTYP.ne.isice) then + if( snhei .le. 2._kind_phys*ZNT)then ! shallow snow - znt=0.55*znt+0.45*z0tbl(iland) - elseif( snhei .gt. 2.*ZNT .and. snhei .le. 4.*ZNT)then - znt=0.2*znt+0.8*z0tbl(iland) - elseif(snhei > 4.*ZNT) then + znt=0.55_kind_phys*znt+0.45_kind_phys*z0tbl(iland) + elseif( snhei .gt. 2._kind_phys*ZNT .and. snhei .le. 4._kind_phys*ZNT)then + znt=0.2_kind_phys*znt+0.8_kind_phys*z0tbl(iland) + elseif(snhei > 4._kind_phys*ZNT) then ! deep snow znt=z0tbl(iland) endif ENDIF - IF(SEAICE .LT. 0.5) THEN + IF(SEAICE .LT. 0.5_kind_phys) THEN !----- SNOW on soil !-- ALB dependence on snow depth ! ALB_SNOW across Canada's forested areas is very low - 0.27-0.35, this ! causes significant warm biases. Limiting ALB in these areas to be higher than 0.4 ! hwlps with these biases.. - if( snow_mosaic == 1.) then + if( snow_mosaic == one) then ALBsn=alb_snow - if(newsn > 0. .and. KEEP_SNOW_ALBEDO > 0.9 .and. albsn < 0.4) then + if(newsn > zero .and. KEEP_SNOW_ALBEDO > 0.9_kind_phys .and. albsn < 0.4_kind_phys) then !-- Albedo correction with fresh snow and deep snow pack !-- will reduce warm bias in western Canada !-- and US West coast, where max snow albedo is low (0.3-0.5). !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j - !ALBsn = 0.7 + !ALBsn = 0.7_kind_phys endif Emiss= emissn @@ -1712,12 +1711,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ALBsn = MAX(keep_snow_albedo*alb_snow, & MIN((alb_snow_free + & (alb_snow - alb_snow_free) * snowfrac), alb_snow)) - if(newsn > 0. .and. KEEP_SNOW_ALBEDO > 0.9 .and. albsn < 0.4) then + if(newsn > zero .and. KEEP_SNOW_ALBEDO > 0.9_kind_phys .and. albsn < 0.4_kind_phys) then !-- Albedo correction with fresh snow and deep snow pack !-- will reduce warm bias in western Canada !-- and US West coast, where max snow albedo is low (0.3-0.5). !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j - !ALBsn = 0.7 + !ALBsn = 0.7_kind_phys !print *,'NO mosaic ALB increase to 0.7',alb_snow,snhei,snhei_crit,alb,i,j endif @@ -1739,16 +1738,16 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- If temperature is higher that -10C then albedo is decreasing. !-- The minimum albedo at t=0C for snow on land is 15% less than !-- albedo of temperatures below -10C. - if(albsn.lt.0.4 .or. keep_snow_albedo==1) then + if(albsn.lt.0.4_kind_phys .or. keep_snow_albedo==1) then ALB=ALBsn else !-- change albedo when no fresh snow and snow albedo is higher than 0.5 - ALB = MIN(ALBSN,MAX(ALBSN - 0.1*(soilt - 263.15)/ & - (273.15-263.15)*ALBSN, ALBSN - 0.05)) + ALB = MIN(ALBSN,MAX(ALBSN - 0.1_kind_phys*(soilt - 263.15_kind_phys)/ & + (tfrz-263.15_kind_phys)*ALBSN, ALBSN - 0.05_kind_phys)) endif ELSE !----- SNOW on ice - if( snow_mosaic == 1.) then + if( snow_mosaic == one) then ALBsn=alb_snow Emiss= emissn else @@ -1766,25 +1765,25 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- ALB dependence on snow temperature. When snow temperature is !-- below critical value of -10C - no change to albedo. !-- If temperature is higher that -10C then albedo is decreasing. - if(albsn.lt.alb_snow .or. keep_snow_albedo .eq.1.)then + if(albsn.lt.alb_snow .or. keep_snow_albedo .eq.one)then ALB=ALBsn else !-- change albedo when no fresh snow - ALB = MIN(ALBSN,MAX(ALBSN - 0.15*ALBSN*(soilt - 263.15)/ & - (273.15-263.15), ALBSN - 0.1)) + ALB = MIN(ALBSN,MAX(ALBSN - 0.15_kind_phys*ALBSN*(soilt - 263.15_kind_phys)/ & + (tfrz-263.15_kind_phys), ALBSN - 0.1_kind_phys)) endif ENDIF - if (snow_mosaic==1.) then + if (snow_mosaic==one) then !may 2014 - treat separately snow-free and snow-covered areas - if(SEAICE .LT. 0.5) then + if(SEAICE .LT. 0.5_kind_phys) then ! LAND ! portion not covered with snow ! compute absorbed GSW for snow-free portion - gswnew=GSWin*(1.-alb_snow_free) + gswnew=GSWin*(one-alb_snow_free) !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT @@ -1808,9 +1807,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia qcgs = qcg csts = cst mavails = mavail - smelt=0. - runoff1s=0. - runoff2s=0. + smelt=zero + runoff1s=zero + runoff2s=zero ilands = ivgtyp @@ -1838,7 +1837,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! portion not covered with snow ! compute absorbed GSW for snow-free portion - gswnew=GSWin*(1.-albice) + gswnew=GSWin*(one-albice) !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT @@ -1855,15 +1854,15 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia qvgs = qvg qsgs = qsg qcgs = qcg - smelt=0. - runoff1s=0. - runoff2s=0. + smelt=zero + runoff1s=zero + runoff2s=zero CALL SICE(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & - 0.98,RNET,QKMS,TKMS,rho,myj, & + 0.98_kind_phys,RNET,QKMS,TKMS,rho,myj, & !--- sea ice parameters tice,rhosice,capice,thdifice, & zsmain,zshalf,DTDZS,DTDZS2,tbq, & @@ -1873,20 +1872,20 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ts1ds,dews,soilts,qvgs,qsgs,qcgs, & eetas,qfxs,hfxs,ss,evapls,prcpls,fltots & ) - edir1 = eeta*1.e-3 - ec1 = 0. - ett1 = 0. + edir1 = eeta*1.e-3_kind_phys + ec1 = zero + ett1 = zero runoff1 = prcpms - runoff2 = 0. - mavail = 1. - infiltr=0. - cst=0. + runoff2 = zero + mavail = one + infiltr= zero + cst= zero do k=1,nzs - soilm1d(k)=1. - soiliqw(k)=0. - soilice(k)=1. - smfrkeep(k)=1. - keepfr(k)=0. + soilm1d(k)=one + soiliqw(k)=zero + soilice(k)=one + smfrkeep(k)=one + keepfr(k)=zero enddo endif ! seaice < 0.5 @@ -1894,7 +1893,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !--- recompute absorbed solar radiation and net radiation !--- for updated value of snow albedo - ALB - gswnew=GSWin*(1.-alb) + gswnew=GSWin*(one-alb) !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT @@ -1908,10 +1907,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia print *,'GSWnew',gswnew,'alb=',alb ENDIF - if (SEAICE .LT. 0.5) then + if (SEAICE .LT. 0.5_kind_phys) then ! LAND - if(snow_mosaic==1.)then - snfr=1. + if(snow_mosaic==one)then + snfr=one else snfr=snowfrac endif @@ -1939,8 +1938,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia mavail,soilice,soiliqw,infiltr ) else ! SEA ICE - if(snow_mosaic==1.)then - snfr=1. + if(snow_mosaic==one)then + snfr=one else snfr=snowfrac endif @@ -1964,28 +1963,28 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SMELT,SNOH,SNFLX,SNOM,eeta, & qfx,hfx,s,sublim,prcpl,fltot & ) - edir1 = eeta*1.e-3 - ec1 = 0. - ett1 = 0. + edir1 = eeta*1.e-3_kind_phys + ec1 = zero + ett1 = zero runoff1 = smelt - runoff2 = 0. - mavail = 1. - infiltr=0. - cst=0. + runoff2 = zero + mavail = one + infiltr = zero + cst = zero do k=1,nzs - soilm1d(k)=1. - soiliqw(k)=0. - soilice(k)=1. - smfrkeep(k)=1. - keepfr(k)=0. + soilm1d(k)=one + soiliqw(k)=zero + soilice(k)=one + smfrkeep(k)=one + keepfr(k)=zero enddo endif - if (snow_mosaic==1.) then + if (snow_mosaic==one) then ! May 2014 - now combine snow covered and snow-free land fluxes, soil temp, moist, ! etc. - if(SEAICE .LT. 0.5) then + if(SEAICE .LT. 0.5_kind_phys) then ! LAND IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then @@ -2004,7 +2003,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia soilm1d(k) = soilm1ds(k)*(1.-snowfrac) + soilm1d(k)*snowfrac ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac smfrkeep(k) = smfrkeeps(k)*(1.-snowfrac) + smfrkeep(k)*snowfrac - if(snowfrac > 0.5) then + if(snowfrac > 0.5_kind_phys) then keepfr(k) = keepfr(k) else keepfr(k) = keepfrs(k) @@ -2012,23 +2011,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia soilice(k) = soilices(k)*(1.-snowfrac) + soilice(k)*snowfrac soiliqw(k) = soiliqws(k)*(1.-snowfrac) + soiliqw(k)*snowfrac enddo - dew = dews*(1.-snowfrac) + dew*snowfrac - soilt = soilts*(1.-snowfrac) + soilt*snowfrac - qvg = qvgs*(1.-snowfrac) + qvg*snowfrac - qsg = qsgs*(1.-snowfrac) + qsg*snowfrac - qcg = qcgs*(1.-snowfrac) + qcg*snowfrac - edir1 = edir1s*(1.-snowfrac) + edir1*snowfrac - ec1 = ec1s*(1.-snowfrac) + ec1*snowfrac - cst = csts*(1.-snowfrac) + cst*snowfrac - ett1 = ett1s*(1.-snowfrac) + ett1*snowfrac - eeta = eetas*(1.-snowfrac) + eeta*snowfrac - qfx = qfxs*(1.-snowfrac) + qfx*snowfrac - hfx = hfxs*(1.-snowfrac) + hfx*snowfrac - s = ss*(1.-snowfrac) + s*snowfrac - evapl = evapls*(1.-snowfrac) + dew = dews*(one-snowfrac) + dew*snowfrac + soilt = soilts*(one-snowfrac) + soilt*snowfrac + qvg = qvgs*(one-snowfrac) + qvg*snowfrac + qsg = qsgs*(one-snowfrac) + qsg*snowfrac + qcg = qcgs*(one-snowfrac) + qcg*snowfrac + edir1 = edir1s*(one-snowfrac) + edir1*snowfrac + ec1 = ec1s*(one-snowfrac) + ec1*snowfrac + cst = csts*(one-snowfrac) + cst*snowfrac + ett1 = ett1s*(one-snowfrac) + ett1*snowfrac + eeta = eetas*(one-snowfrac) + eeta*snowfrac + qfx = qfxs*(one-snowfrac) + qfx*snowfrac + hfx = hfxs*(one-snowfrac) + hfx*snowfrac + s = ss*(one-snowfrac) + s*snowfrac + evapl = evapls*(one-snowfrac) sublim = sublim*snowfrac - prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac - fltot = fltots*(1.-snowfrac) + fltot*snowfrac + prcpl = prcpls*(one-snowfrac) + prcpl*snowfrac + fltot = fltots*(one-snowfrac) + fltot*snowfrac ALB = MAX(keep_snow_albedo*alb, & MIN((alb_snow_free + (alb - alb_snow_free) * snowfrac), alb)) @@ -2036,14 +2035,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia MIN((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) - runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac - runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac + runoff1 = runoff1s*(one-snowfrac) + runoff1*snowfrac + runoff2 = runoff2s*(one-snowfrac) + runoff2*snowfrac smelt = smelt * snowfrac snoh = snoh * snowfrac snflx = snflx * snowfrac snom = snom * snowfrac - mavail = mavails*(1.-snowfrac) + 1.*snowfrac - infiltr = infiltrs*(1.-snowfrac) + infiltr*snowfrac + mavail = mavails*(one-snowfrac) + one*snowfrac + infiltr = infiltrs*(one-snowfrac) + infiltr*snowfrac IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. & abs(xlon-272.55).lt.0.2)then @@ -2058,27 +2057,27 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia print *,'SOILT snow on ice', soilt ENDIF do k=1,nzs - ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac + ts1d(k) = ts1ds(k)*(one-snowfrac) + ts1d(k)*snowfrac enddo - dew = dews*(1.-snowfrac) + dew*snowfrac - soilt = soilts*(1.-snowfrac) + soilt*snowfrac - qvg = qvgs*(1.-snowfrac) + qvg*snowfrac - qsg = qsgs*(1.-snowfrac) + qsg*snowfrac - qcg = qcgs*(1.-snowfrac) + qcg*snowfrac + dew = dews*(one-snowfrac) + dew*snowfrac + soilt = soilts*(one-snowfrac) + soilt*snowfrac + qvg = qvgs*(one-snowfrac) + qvg*snowfrac + qsg = qsgs*(one-snowfrac) + qsg*snowfrac + qcg = qcgs*(one-snowfrac) + qcg*snowfrac sublim = eeta*snowfrac - eeta = eetas*(1.-snowfrac) + eeta*snowfrac - qfx = qfxs*(1.-snowfrac) + qfx*snowfrac - hfx = hfxs*(1.-snowfrac) + hfx*snowfrac - s = ss*(1.-snowfrac) + s*snowfrac - prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac - fltot = fltots*(1.-snowfrac) + fltot*snowfrac + eeta = eetas*(one-snowfrac) + eeta*snowfrac + qfx = qfxs*(one-snowfrac) + qfx*snowfrac + hfx = hfxs*(one-snowfrac) + hfx*snowfrac + s = ss*(one-snowfrac) + s*snowfrac + prcpl = prcpls*(one-snowfrac) + prcpl*snowfrac + fltot = fltots*(one-snowfrac) + fltot*snowfrac ALB = MAX(keep_snow_albedo*alb, & MIN((albice + (alb - alb_snow_free) * snowfrac), alb)) Emiss = MAX(keep_snow_albedo*emissn, & MIN((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) - runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac - runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac + runoff1 = runoff1s*(one-snowfrac) + runoff1*snowfrac + runoff2 = runoff2s*(one-snowfrac) + runoff2*snowfrac smelt = smelt * snowfrac snoh = snoh * snowfrac snflx = snflx * snowfrac @@ -2120,23 +2119,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! Limit on znt (<0.25) is needed to avoid very small snow fractions in the ! forested areas with large roughness - IF(snhei == 0.) then + IF(snhei == zero) then !--- all snow is melted iland=ivgtyp - snowfrac = 0. + snowfrac = zero alb = alb_snow_free emiss = emiss_snowfree ELSE !-- update snow cover after possible melting - m = 1.0 ! m=1.6 in Niu&Yang, m=1 in CLM + m = one ! m=1.6_kind_phys in Niu&Yang, m=1 in CLM if(isncovr_opt == 1) then - snowfrac=min(1.,snhei/(2.*snhei_crit)) + snowfrac=min(one,snhei/(2._kind_phys*snhei_crit)) elseif(isncovr_opt == 2) then !-- isncovr_opt=2 - snowfrac=min(1.,snhei/(2.*snhei_crit)) + snowfrac=min(one,snhei/(2._kind_phys*snhei_crit)) if(ivgtyp == glacier .or. ivgtyp == bare) then !-- sparsely vegetated or land ice - snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**m)) + snowfrac2 = tanh( snhei/(2.5_kind_phys * 0.2_kind_phys *(rhosn/rhonewsn)**m)) else !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests ! on 3-km scale use actual roughness, but not higher than 0.2 m. @@ -2144,21 +2143,21 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m)) endif !-- snow fraction is average between method 1 and 2 - snowfrac = 0.5*(snowfrac+snowfrac2) + snowfrac = 0.5_kind_phys*(snowfrac+snowfrac2) else !-- isncovr_opt=3 !m = msnf ! vegetation dependent facsnf/msnf from Noah MP !-- for RRFS a factor 10. was added to 'facsnf' to get reasonal values of ! snow cover fractions on the 3-km scale. ! This factor is scale dependent. - snowfrac = tanh( snhei/(10. * facsnf *(rhosn/rhonewsn)**m)) + snowfrac = tanh( snhei/(10._kind_phys * facsnf *(rhosn/rhonewsn)**m)) endif !-- due to steep slopes and blown snow, limit snow fraction in the !-- mountains ( Swiss weather model) - if(hgt > 2500. .and. ivgtyp == glacier) snowfrac=min(0.85,snowfrac) + if(hgt > 2500._kind_phys .and. ivgtyp == glacier) snowfrac=min(0.85_kind_phys,snowfrac) - if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + if(ivgtyp == urban) snowfrac=min(0.75_kind_phys,snowfrac) ! run-total accumulated snow based on snowfall and snowmelt in [mm] @@ -2171,9 +2170,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia print *,'Time-step sublim: swe,[kg m-2]',sublim*delt endif - snowfallac = snowfallac + max(0.,(newsn*rhonewsn - & ! source of snow (swe) [m] - (smelt+sublim*1.e-3)*delt*newsnowratio) & ! sink: melting and sublimation, (swe) [m] - /rhonewsn)*1.e3 ! snow accumulation in snow depth [mm] + snowfallac = snowfallac + max(zero,(newsn*rhonewsn - & ! source of snow (swe) [m] + (smelt+sublim*1.e-3_kind_phys)*delt*newsnowratio) & ! sink: melting and sublimation, (swe) [m] + /rhonewsn)*rhowater ! snow accumulation in snow depth [mm] IF (debug_print ) THEN !if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then @@ -2183,9 +2182,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ELSE !--- no snow - snheiprint=0. - snweprint=0. - smelt=0. + snheiprint=zero + snweprint=zero + smelt=zero !-------------- T3 = STBOLT*SOILT*SOILT*SOILT @@ -2196,7 +2195,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia print *,'NO snow on the ground GSWnew -',GSWnew,'RNET=',rnet ENDIF - if(SEAICE .LT. 0.5) then + if(SEAICE .LT. 0.5_kind_phys) then ! LAND CALL SOIL(debug_print,xlat,xlon, & !--- input variables @@ -2221,7 +2220,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! SEA ICE ! If current ice albedo is not the same as from the previous time step, then ! update GSW, ALB and RNET for surface energy budget - if(ALB.ne.ALBice) GSWnew=GSW/(1.-ALB)*(1.-ALBice) + if(ALB.ne.ALBice) GSWnew=GSW/(one-ALB)*(one-ALBice) alb=albice RNET = GSWnew + XINET @@ -2237,22 +2236,22 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia lv,CP,rovcp,cw,stbolt,tabs, & !--- output variables ts1d,dew,soilt,qvg,qsg,qcg, & - eeta,qfx,hfx,s,evapl,prcpl,fltot & + eeta,qfx,hfx,s,evapl,prcpl,fltot & ) - edir1 = eeta*1.e-3 - ec1 = 0. - ett1 = 0. + edir1 = eeta*1.e-3_kind_phys + ec1 = zero + ett1 = zero runoff1 = prcpms - runoff2 = 0. - mavail = 1. - infiltr=0. - cst=0. + runoff2 = zero + mavail = one + infiltr = zero + cst = zero do k=1,nzs - soilm1d(k)=1. - soiliqw(k)=0. - soilice(k)=1. - smfrkeep(k)=1. - keepfr(k)=0. + soilm1d(k)= one + soiliqw(k)= zero + soilice(k)= one + smfrkeep(k)= one + keepfr(k)= zero enddo endif @@ -2273,14 +2272,14 @@ FUNCTION QSN(TN,T) real (kind_phys) QSN, R,R1,R2 INTEGER I - R=(TN-173.15)/.05+1. + R=(TN-173.15_kind_dbl_prec)/.05_kind_dbl_prec+one I=INT(R) IF(I.GE.1) goto 10 I=1 R=1. 10 IF(I.LE.5000) GOTO 20 I=5000 - R=5001. + R=5001._kind_dbl_prec 20 R1=T(I) R2=R-I QSN=(T(I+1)-R1)*R2 + R1 @@ -2376,12 +2375,12 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & real (kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: GLW, & GSW, & GSWin, & @@ -2395,7 +2394,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & TKMS !--- soil properties - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -2406,7 +2405,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & REF, & WILT - real (kind_phys), INTENT(IN ) :: CN, & + real (kind_phys), INTENT(IN ) :: CN, & CW, & KQWRTZ, & KICE, & @@ -2415,7 +2414,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & g0_p - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 @@ -2426,16 +2425,16 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO, & SOILMOIS, & SMFRKEEP - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR !-------- 2-d variables - real (kind_phys), & + real (kind_phys), & INTENT(INOUT) :: DEW, & CST, & DRIP, & @@ -2459,12 +2458,12 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & SOILT !-------- 1-d variables - real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & SOILIQW !--- Local variables - real (kind_phys) :: INFILTRP, transum , & + real (kind_phys) :: INFILTRP, transum , & RAINF, PRCPMS , & TABS, T3, UPFLUX, XINET real (kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & @@ -2473,7 +2472,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW, X - real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & + real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold @@ -2486,67 +2485,67 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !----------------------------------------------------------------- !-- define constants - RHOICE=900. - CI=RHOICE*2100. - XLMELT=3.35E+5 + RHOICE=900._kind_phys + CI=RHOICE*2100._kind_phys + XLMELT=3.35E+5_kind_phys cvw=cw prcpl=prcpms - smf=0. + smf = zero soiltold = soilt - wetcan=0. - drycan=1. + wetcan= zero + drycan= one !--- Initializing local arrays DO K=1,NZS - TRANSP (K)=0. - soilmoism(k)=0. - soilice (k)=0. - soiliqw (k)=0. - soilicem (k)=0. - soiliqwm (k)=0. - lwsat (k)=0. - fwsat (k)=0. - tav (k)=0. - cap (k)=0. - thdif (k)=0. - diffu (k)=0. - hydro (k)=0. - tranf (k)=0. - detal (k)=0. - told (k)=0. - smold (k)=0. + TRANSP (K)=zero + soilmoism(k)=zero + soilice (k)=zero + soiliqw (k)=zero + soilicem (k)=zero + soiliqwm (k)=zero + lwsat (k)=zero + fwsat (k)=zero + tav (k)=zero + cap (k)=zero + thdif (k)=zero + diffu (k)=zero + hydro (k)=zero + tranf (k)=zero + detal (k)=zero + told (k)=zero + smold (k)=zero ENDDO NZS1=NZS-1 NZS2=NZS-2 - dzstop=1./(zsmain(2)-zsmain(1)) - RAS=RHO*1.E-3 - RIW=rhoice*1.e-3 + dzstop=one/(zsmain(2)-zsmain(1)) + RAS=RHO*1.E-3_kind_phys + RIW=rhoice*1.e-3_kind_phys !--- Computation of volumetric content of ice in soil DO K=1,NZS !- main levels - tln=log(tso(k)/273.15) - if(tln.lt.0.) then + tln=log(tso(k)/tfrz) + if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-273.15)/tso(k)/9.81/psis) & - **(-1./bclh)-qmin - soiliqw(k)=max(0.,soiliqw(k)) + (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + **(-one/bclh)-qmin + soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) soilice(k)=(soilmois(k)-soiliqw(k))/RIW !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1._kind_phys) then + if(keepfr(k).eq.one) then soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(0._kind_phys,soilmois(k)-soilice(k)*riw) + soiliqw(k)=max(zero,soilmois(k)-soilice(k)*riw) endif else - soilice(k)=0._kind_phys + soilice(k)=zero soiliqw(k)=soilmois(k) endif @@ -2554,39 +2553,39 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & DO K=1,NZS1 !- middle of soil layers - tav(k)=0.5*(tso(k)+tso(k+1)) - soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) - tavln=log(tav(k)/273.15) + tav(k)=0.5_kind_phys*(tso(k)+tso(k+1)) + soilmoism(k)=0.5_kind_phys*(soilmois(k)+soilmois(k+1)) + tavln=log(tav(k)/tfrz) - if(tavln.lt.0._kind_phys) then + if(tavln.lt.zero) then soiliqwm(k)=(dqm+qmin)*(XLMELT* & - (tav(k)-273.15)/tav(k)/9.81/psis) & - **(-1./bclh)-qmin + (tav(k)-tfrz)/tav(k)/9.81_kind_phys/psis) & + **(-one/bclh)-qmin fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin - soiliqwm(k)=max(0._kind_phys,soiliqwm(k)) + soiliqwm(k)=max(zero,soiliqwm(k)) soiliqwm(k)=min(soiliqwm(k), soilmoism(k)) soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1._kind_phys) then + if(keepfr(k).eq.one) then soilicem(k)=min(soilicem(k), & - 0.5*(smfrkeep(k)+smfrkeep(k+1))) - soiliqwm(k)=max(0.,soilmoism(k)-soilicem(k)*riw) + 0.5_kind_phys*(smfrkeep(k)+smfrkeep(k+1))) + soiliqwm(k)=max(zero,soilmoism(k)-soilicem(k)*riw) fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin endif else - soilicem(k)=0._kind_phys + soilicem(k)=zero soiliqwm(k)=soilmoism(k) lwsat(k)=dqm+qmin - fwsat(k)=0._kind_phys + fwsat(k)=zero endif ENDDO do k=1,nzs - if(soilice(k).gt.0._kind_phys) then + if(soilice(k).gt.zero) then smfrkeep(k)=soilice(k) else smfrkeep(k)=soilmois(k)/riw @@ -2617,7 +2616,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & Q1=-QKMS*RAS*(QVATM - QSG) - DEW=0. + DEW=zero IF(QVATM.GE.QSG)THEN DEW=FQ*(QVATM-QSG) ENDIF @@ -2626,8 +2625,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !--- water, and DRYCAN is the fraction of vegetated area where !--- transpiration may take place. - WETCAN=min(0.25,max(0.,(CST/SAT))**CN) - DRYCAN=1.-WETCAN + WETCAN=min(0.25_kind_phys,max(zero,(CST/SAT))**CN) + DRYCAN=one-WETCAN !************************************************************** ! TRANSF computes transpiration function @@ -2648,16 +2647,16 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! Sakaguchi and Zeng (2009) - dry soil resistance to evaporation ! if (vgtype==11) then ! MODIS wetland - alfa=1. + alfa=one ! else - fex=min(1.,soilmois(1)/dqm) - fex=max(fex,0.01) + fex=min(one,soilmois(1)/dqm) + fex=max(fex,0.01_kind_phys) psit=psis*fex ** (-bclh) - psit = max(-1.e5, psit) - alfa=min(1.,exp(G0_P*psit/r_v/SOILT)) + psit = max(-1.e5_kind_phys, psit) + alfa=min(one,exp(G0_P*psit/r_v/SOILT)) ! print *,'alfa=',alfa, exp(G0_P*psit/r_v/SOILT) ! endif - alfa=1. + alfa=one ! field capacity ! 20jun18 - beta in Eq. (5) is called soilres in the code - it limits soil evaporation ! when soil moisture is below field capacity. [Lee and Pielke, 1992] @@ -2672,13 +2671,13 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct ! evaporation. Therefore , it is replaced with ref*0.7. fc=ref - fex_fc=1. - if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then - soilres = 1. + fex_fc=one + if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > zero) then + soilres = one else - fex_fc=min(1.,(soilmois(1)+qmin)/fc) - fex_fc=max(fex_fc,0.01) - soilres=0.25*(1.-cos(piconst*fex_fc))**2. + fex_fc=min(one,(soilmois(1)+qmin)/fc) + fex_fc=max(fex_fc,0.01_kind_phys) + soilres=0.25_kind_phys*(one-cos(piconst*fex_fc))**2._kind_phys endif IF ( debug_print ) THEN print *,'piconst=',piconst @@ -2709,14 +2708,14 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !************************************************************************ !--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW - ETT1=0. - DEW=0. + ETT1=zero + DEW=zero IF(QVATM.GE.QSG)THEN DEW=QKMS*(QVATM-QSG) - ETT1=0. + ETT1=zero DO K=1,NZS - TRANSP(K)=0. + TRANSP(K)=zero ENDDO ELSE @@ -2724,33 +2723,33 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & TRANSP(K)=VEGFRAC*RAS*QKMS* & (QVATM-QSG)* & TRANF(K)*DRYCAN/ZSHALF(NROOT+1) - IF(TRANSP(K).GT.0.) TRANSP(K)=0. + IF(TRANSP(K).GT.zero) TRANSP(K)=zero ETT1=ETT1-TRANSP(K) ENDDO DO k=nroot+1,nzs - transp(k)=0. + transp(k)=zero enddo ENDIF !-- Recalculate volumetric content of frozen water in soil DO K=1,NZS !- main levels - tln=log(tso(k)/273.15) - if(tln.lt.0.) then + tln=log(tso(k)/tfrz) + if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-273.15)/tso(k)/9.81/psis) & - **(-1./bclh)-qmin - soiliqw(k)=max(0.,soiliqw(k)) + (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + **(-one/bclh)-qmin + soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) soilice(k)=(soilmois(k)-soiliqw(k))/riw !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then + if(keepfr(k).eq.one) then soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw) + soiliqw(k)=max(zero,soilmois(k)-soilice(k)*riw) endif else - soilice(k)=0. + soilice(k)=zero soiliqw(k)=soilmois(k) endif ENDDO @@ -2764,8 +2763,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & zsmain,zshalf,diffu,hydro, & QSG,QVG,QCG,QCATM,QVATM,-infwater, & - QKMS,TRANSP,DRIP,DEW,0.,SOILICE,VEGFRAC, & - 0.,soilres, & + QKMS,TRANSP,DRIP,DEW,zero,SOILICE,VEGFRAC, & + zero,soilres, & !-- soil properties DQM,QMIN,REF,KSAT,RAS,INFMAX, & !-- output @@ -2782,11 +2781,11 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !--- frozen soil. do k=1,nzs - if (soilice(k).gt.0.) then + if (soilice(k).gt.zero) then if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then - keepfr(k)=1. + keepfr(k)=one else - keepfr(k)=0. + keepfr(k)=zero endif endif enddo @@ -2794,22 +2793,22 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !--- THE DIAGNOSTICS OF SURFACE FLUXES T3 = STBOLT*SOILTold*SOILTold*SOILTold - UPFLUX = T3 * 0.5*(SOILTold+SOILT) + UPFLUX = T3 * 0.5_kind_phys*(SOILTold+SOILT) XINET = EMISS*(GLW-UPFLUX) HFT=-TKMS*CP*RHO*(TABS-SOILT) HFX=-TKMS*CP*RHO*(TABS-SOILT) & - *(P1000mb*0.00001/Patm)**ROVCP + *(P1000mb*0.00001_kind_phys/Patm)**ROVCP Q1=-QKMS*RAS*(QVATM - QSG) - CMC2MS = 0. - IF (Q1.LE.0.) THEN + CMC2MS = zero + IF (Q1.LE.zero) THEN ! --- condensation - EC1=0. - EDIR1=0. - ETT1=0. + EC1= zero + EDIR1= zero + ETT1= zero if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + EETA=-QKMS*RAS*(QVATM/(one+QVATM) - QSG/(one+QSG))*rhowater CST= CST-EETA*DELT*vegfrac IF (debug_print ) THEN !!! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then @@ -2828,7 +2827,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & EETA= - RHO*DEW ELSE ! --- evaporation - EDIR1 =-soilres*(1.-vegfrac)*QKMS*RAS* & + EDIR1 =-soilres*(one-vegfrac)*QKMS*RAS* & (QVATM-QVG) CMC2MS=CST/DELT*RAS EC1 = Q1 * WETCAN * vegfrac @@ -2839,11 +2838,11 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ENDIF ENDIF - CST=max(0.,CST-EC1 * DELT) + CST=max(zero,CST-EC1 * DELT) if (myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-soilres*QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 + EETA=-soilres*QKMS*RAS*(QVATM/(one+QVATM) - QVG/(one+QVG))*rhowater else ! myj IF (debug_print ) THEN ! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then @@ -2854,14 +2853,14 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & print *,'EC1=',EC1,'ETT1=',ETT1,'CMC2MS=',CMC2MS,'CMC2MS*ras=',CMC2MS*ras ENDIF !-- actual moisture flux from RUC LSM - EETA = (EDIR1 + EC1 + ETT1)*1.E3 + EETA = (EDIR1 + EC1 + ETT1)*rhowater IF (debug_print ) THEN ! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then print *,'RUC LSM EETA',EETA,eeta*xlv ENDIF endif ! myj QFX= XLV * EETA - EETA = (EDIR1 + EC1 + ETT1)*1.E3 + EETA = (EDIR1 + EC1 + ETT1)*rhowater ENDIF IF (debug_print ) THEN print *,'potential temp HFT ',HFT @@ -2878,7 +2877,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac',& edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac ENDIF - if(detal(1) .ne. 0.) then + if(detal(1) .ne. zero) then ! SMF - energy of phase change in the first soil layer smf=fltot IF (debug_print ) THEN @@ -3058,7 +3057,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & AA=XLS*(FKQ+R210)/TDENOM BB=(D10*TABS+R21*TN+XLS*(QVATM*FKQ & +R210*QVG)+D11+D9*(D2+R22*TN) & - +RAINF*CVW*PRCPMS*max(273.15,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & )/TDENOM AA1=AA PP=PATM*1.E3 @@ -3146,7 +3145,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & XLS*rho*r211*(QSG-QGOLD) X=X & ! "heat" from rain - -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + -RAINF*CVW*PRCPMS*(max(tfrz,TABS)-SOILT) !-- excess energy spent on sea ice melt icemelt=RNET-XLS*EETA -HFT -S -X @@ -3486,10 +3485,10 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !tgs - water in soil if there is any DO K=1,NZS - tln=log(tso(k)/273.15) + tln=log(tso(k)/tfrz) if(tln.lt.0.) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-273.15)/tso(k)/9.81/psis) & + (tso(k)-tfrz)/tso(k)/9.81/psis) & **(-1./bclh)-qmin soiliqw(k)=max(0.,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -3512,11 +3511,11 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & tav(k)=0.5*(tso(k)+tso(k+1)) soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) - tavln=log(tav(k)/273.15) + tavln=log(tav(k)/tfrz) if(tavln.lt.0.) then soiliqwm(k)=(dqm+qmin)*(XLMELT* & - (tav(k)-273.15)/tav(k)/9.81/psis) & + (tav(k)-tfrz)/tav(k)/9.81/psis) & **(-1./bclh)-qmin fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin @@ -3674,10 +3673,10 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !-- recalculating of frozen water in soil DO K=1,NZS - tln=log(tso(k)/273.15) + tln=log(tso(k)/tfrz) if(tln.lt.0.) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-273.15)/tso(k)/9.81/psis) & + (tso(k)-tfrz)/tso(k)/9.81/psis) & **(-1./bclh)-qmin soiliqw(k)=max(0.,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -3716,7 +3715,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !-- Restore land-use parameters if all snow is melted IF(SNHEI.EQ.0.) then - tsnav=soilt-273.15 + tsnav=soilt-tfrz ENDIF ! 21apr2009 @@ -4141,7 +4140,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & rhtsn=rhtso(NZS) !*** Average temperature of snow pack (C) tsnav=0.5*(soilt+tso(1)) & - -273.15 + -tfrz else !-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth @@ -4168,7 +4167,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !*** Average temperature of snow pack (C) tsnav=0.5/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15 + -tfrz endif ENDIF @@ -4190,7 +4189,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & cotso(nzs1) = x1sn/denom rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom tsnav=0.5*(soilt+tso(1)) & - -273.15 + -tfrz cotso(nzs)=cotso(NZS1) rhtso(nzs)=rhtso(nzs1) cotsn=cotso(NZS) @@ -4263,8 +4262,8 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & BB=(D10*TABS+R21*TN+XLVM*(QVATM* & (BETA*FKQ) & +R210*QVG)+D11+D9SN*(D2SN+R22SN*TN) & - +RAINF*CVW*PRCPMS*max(273.15,TABS) & - + RHOnewCSN*NEWSNOW/DELT*min(273.15,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & + + RHOnewCSN*NEWSNOW/DELT*min(tfrz,TABS) & )/TDENOM AA1=AA PP=PATM*1.E3 @@ -4288,7 +4287,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !--- SOILT - skin temperature of snow on ice SOILT=TS1 if(nmelt==1 .and. snowfrac==1) then - soilt = min(273.15,soilt) + soilt = min(tfrz,soilt) endif IF (debug_print ) THEN @@ -4299,7 +4298,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & IF(SNHEI.GE.SNTH) THEN if(snhei.gt.DELTSN+SNTH) then !-- 2-layer snow model - SOILT1=min(273.15,rhtsn+cotsn*SOILT) + SOILT1=min(tfrz,rhtsn+cotsn*SOILT) TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT1)) tsob=soilt1 else @@ -4344,18 +4343,17 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(nmelt.eq.1) go to 220 -!--- IF SOILT > 273.15 F then melting of snow can happen +!--- IF SOILT > tfrz F then melting of snow can happen ! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.BETA.EQ.1._kind_phys.AND.SNHEI.GT.0._kind_phys) THEN + IF(SOILT>tfrz .AND. BETA==one .AND. SNHEI>zero) THEN ! nmelt = 1 - soiltfrac=snowfrac*273.15+(1.-snowfrac)*min(271.4,SOILT) + soiltfrac=snowfrac*tfrz+(1.-snowfrac)*min(271.4,SOILT) QSG= QSN(soiltfrac,TBQ)/PP T3 = STBOLT*TNold*TNold*TNold UPFLUX = T3 * 0.5*(TNold+SOILTfrac) XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS @@ -4386,16 +4384,16 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & XLVM*R210*(QSG-QGOLD) !-- SNOH is energy flux of snow phase change SNOH=RNET+QFX +HFX & - +RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac) & + +RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-soiltfrac) & -SOH-X+RAINF*CVW*PRCPMS* & - (max(273.15,TABS)-soiltfrac) + (max(tfrz,TABS)-soiltfrac) IF (debug_print ) THEN print *,'SNOWSEAICE melt I,J,SNOH,RNET,QFX,HFX,SOH,X',i,j,SNOH,RNET,QFX,HFX,SOH,X - print *,'RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac)', & - RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac) - print *,'RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac)', & - RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac) + print *,'RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-soiltfrac)', & + RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-soiltfrac) + print *,'RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac)', & + RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac) ENDIF SNOH=AMAX1(0._kind_phys,SNOH) !-- SMELT is speed of melting in M/S @@ -4407,7 +4405,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & print *,'1-SMELT i,j',smelt,i,j ENDIF !18apr08 - Egglston limit - SMELT= amin1 (smelt,delt/60.* 5.6E-8*meltfactor*max(1.,(soilt-273.15))) ! SnowMIP + SMELT= amin1 (smelt,delt/60.* 5.6E-8*meltfactor*max(1.,(soilt-tfrz))) ! SnowMIP IF (debug_print ) THEN print *,'2-SMELT i,j',smelt,i,j ENDIF @@ -4538,9 +4536,9 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(ilnb.gt.1) then tsnav=0.5/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15 + -tfrz else - tsnav=0.5*(soilt+tso(1)) - 273.15 + tsnav=0.5*(soilt+tso(1)) - tfrz endif ENDIF !--- RECALCULATION OF DEW USING NEW VALUE OF QSG @@ -4624,8 +4622,8 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & R21,D9sn,r22sn,soiltfrac,tnold,qsg,qgold,snprim ENDIF X=X & - -RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-SOILT) & - -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + -RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-SOILT) & + -RAINF*CVW*PRCPMS*(max(tfrz,TABS)-SOILT) ! -- excess energy is spent on ice melt icemelt = RNET-HFT-XLVm*EETA-S-SNOH-X @@ -4642,7 +4640,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ENDIF !-- Restore sea-ice parameters if snow is less than threshold IF(SNHEI.EQ.0.) then - tsnav=soilt-273.15 + tsnav=soilt-tfrz emiss=0.98 znt=0.011 alb=0.55 @@ -4870,7 +4868,7 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & BB=(D10*TABS+R21*TN+XLV*(QVATM* & (FKQ*UMVEG+C) & +R210*QVG)+D11+D9*(D2+R22*TN) & - +RAINF*CVW*PRCPMS*max(273.15,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & )/TDENOM AA1=AA+CC PP=PATM*1.E3 @@ -4944,7 +4942,7 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & ENDIF X=X & ! "heat" from rain - -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + -RAINF*CVW*PRCPMS*(max(tfrz,TABS)-SOILT) IF (debug_print ) THEN print *,'x=',x @@ -5276,7 +5274,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & rhtsn=rhtso(NZS) !*** Average temperature of snow pack (C) tsnav=min(0.,0.5*(soilt+tso(1)) & - -273.15) + -tfrz) else !-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth @@ -5306,7 +5304,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !*** Average temperature of snow pack (C) tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15) + -tfrz) endif ENDIF IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then @@ -5327,7 +5325,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & cotso(nzs1) = x1sn/denom rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom tsnav=min(0.,0.5*(soilt+tso(1)) & - -273.15) + -tfrz) cotso(NZS)=cotso(nzs1) rhtso(NZS)=rhtso(nzs1) cotsn=cotso(NZS) @@ -5425,8 +5423,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & BB=(D10*TABS+R21*TN+XLVM*(QVATM* & (BETA*FKQ*UMVEG+C) & +R210*QGOLD)+D11+D9SN*(D2SN+R22SN*TN) & - +RAINF*CVW*PRCPMS*max(273.15,TABS) & - + RHOnewCSN*NEWSNOW/DELT*min(273.15,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & + + RHOnewCSN*NEWSNOW/DELT*min(tfrz,TABS) & )/TDENOM AA1=AA+CC PP=PATM*1.E3 @@ -5494,15 +5492,15 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !--- SOILT - skin temperature SOILT=TS1 - if(nmelt==1 .and. snowfrac==1 .and. snwe > 0. .and. SOILT > 273.15) then + if(nmelt==1 .and. snowfrac==1 .and. snwe > 0. .and. SOILT > tfrz) then !--7feb22 on the second iteration when SNOH is known and snwe > 0. after melting, - !-- check if the snow skin temperature is =<273.15K + !-- check if the snow skin temperature is = 0.) THEN + IF(TSO(1).GT.tfrz .and. snhei > 0.) THEN !-- melting at the soil/snow interface if (snhei.GT.deltsn+snth) then hsn = snhei - deltsn @@ -5862,7 +5860,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & hsn = snhei endif - soiltfrac=snowfrac*273.15+(1.-snowfrac)*TSO(1) + soiltfrac=snowfrac*tfrz+(1.-snowfrac)*TSO(1) SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & RHOCSN*0.5*hsn) / DELT @@ -5926,8 +5924,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & X=X & ! "heat" from snow and rain - -RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-SOILT) & - -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + -RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-SOILT) & + -RAINF*CVW*PRCPMS*(max(tfrz,TABS)-SOILT) IF (debug_print ) THEN print *,'x=',x print *,'SNHEI=',snhei @@ -5938,12 +5936,12 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & if(ilnb.gt.1) then tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15) + -tfrz) else - tsnav=min(0.,0.5*(soilt+tso(1)) - 273.15) + tsnav=min(0.,0.5*(soilt+tso(1)) - tfrz) endif ELSE - tsnav= min(0.,soilt - 273.15) + tsnav= min(0.,soilt - tfrz) ENDIF !------------------------------------------------------------------------ @@ -6400,7 +6398,7 @@ SUBROUTINE SOILPROP( debug_print, & endif DO K=1,NZS1 - tn=tav(k) - 273.15 + tn=tav(k) - tfrz wd=ws - riw*soilicem(k) psif=psis*100.*(wd/(soiliqwm(k)+qmin))**bclh & * (ws/wd)**3. @@ -6418,7 +6416,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- DETAL is taking care of energy spent on freezing or released from ! melting of soil water - DETAL(K)=273.15*X2/(TAV(K)*TAV(K))* & + DETAL(K)=tfrz*X2/(TAV(K)*TAV(K))* & (TAV(K)/(X1*TN))**X4 if(keepfr(k).eq.1.) then @@ -7279,11 +7277,11 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & DO L=1,NZS !-- for land points initialize soil ice - tln=log(TSLB(i,l,j)/273.15) + tln=log(TSLB(i,l,j)/tfrz) if(tln.lt.0.) then soiliqw(l)=(dqm+qmin)*(XLMELT* & - (tslb(i,l,j)-273.15)/tslb(i,l,j)/9.81/psis) & + (tslb(i,l,j)-tfrz)/tslb(i,l,j)/9.81/psis) & **(-1./bclh) soiliqw(l)=max(0.,soiliqw(l)) soiliqw(l)=min(soiliqw(l),smois(i,l,j)) From 4a74783b79a33d80dfdb7cd85853c7902b456910 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 21 Mar 2023 20:34:04 +0000 Subject: [PATCH 13/28] More changes related to kin_phys. --- physics/module_sf_ruclsm.F90 | 292 +++++++++++++++++------------------ 1 file changed, 146 insertions(+), 146 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index ea253ad2a..653323419 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -2846,9 +2846,9 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & else ! myj IF (debug_print ) THEN ! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then - print *,'QKMS,RAS,QVATM/(1.+QVATM),QVG/(1.+QVG),QSG ', & - QKMS,RAS,QVATM/(1.+QVATM),QVG/(1.+QVG),QSG - print *,'Q1*(1.-vegfrac),EDIR1',Q1*(1.-vegfrac),EDIR1 + print *,'QKMS,RAS,QVATM/(one+QVATM),QVG/(one+QVG),QSG ', & + QKMS,RAS,QVATM/(one+QVATM),QVG/(one+QVG),QSG + print *,'Q1*(1.-vegfrac),EDIR1',Q1*(one-vegfrac),EDIR1 print *,'CST,WETCAN,DRYCAN',CST,WETCAN,DRYCAN print *,'EC1=',EC1,'ETT1=',ETT1,'CMC2MS=',CMC2MS,'CMC2MS*ras=',CMC2MS*ras ENDIF @@ -2929,12 +2929,12 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & real (kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: GLW, & GSW, & EMISS, & @@ -2942,7 +2942,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & QKMS, & TKMS !--- sea ice properties - real (kind_phys), DIMENSION(1:NZS) , & + real (kind_phys), DIMENSION(1:NZS) , & INTENT(IN ) :: & tice, & rhosice, & @@ -2950,16 +2950,16 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & thdifice - real (kind_phys), INTENT(IN ) :: & + real (kind_phys), INTENT(IN ) :: & CW, & XLV - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ @@ -2968,7 +2968,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !----soil temperature real (kind_phys), DIMENSION( 1:nzs ), INTENT(INOUT) :: TSO !-------- 2-d variables - real (kind_phys), & + real (kind_phys), & INTENT(INOUT) :: DEW, & EETA, & EVAPL, & @@ -2984,15 +2984,15 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !--- Local variables real (kind_phys) :: x,x1,x2,x4,tn,denom - real (kind_phys) :: RAINF, PRCPMS , & + real (kind_phys) :: RAINF, PRCPMS , & TABS, T3, UPFLUX, XINET real (kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & epot,fltot,ft,fq,hft,ras,cvw - real (kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & - PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & - TDENOM,QGOLD,SNOH + real (kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & + PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & + TDENOM,QGOLD,SNOH real (kind_phys) :: AA1,RHCS, icemelt @@ -3004,7 +3004,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !----------------------------------------------------------------- !-- define constants - XLMELT=3.35E+5 + XLMELT=3.35E+5_kind_dbl_prec cvw=cw prcpl=prcpms @@ -3012,14 +3012,14 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & NZS1=NZS-1 NZS2=NZS-2 dzstop=1./(zsmain(2)-zsmain(1)) - RAS=RHO*1.E-3 + RAS=RHO*1.E-3_kind_phys do k=1,nzs - cotso(k)=0. - rhtso(k)=0. + cotso(k)=zero + rhtso(k)=zero enddo - cotso(1)=0. + cotso(1)=zero rhtso(1)=TSO(NZS) DO 33 K=1,NZS2 @@ -3037,20 +3037,20 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !************************************************************************ !--- THE HEAT BALANCE EQUATION (Smirnova et al., 1996, EQ. 21,26) RHCS=CAPICE(1) - H=1. + H=one FKT=TKMS D1=cotso(NZS1) D2=rhtso(NZS1) TN=TSO(1) D9=THDIFICE(1)*RHCS*dzstop D10=TKMS*CP*RHO - R211=.5*CONFLX/DELT + R211=.5_kind_phys*CONFLX/DELT R21=R211*CP*RHO - R22=.5/(THDIFICE(1)*DELT*dzstop**2) - R6=EMISS *STBOLT*.5*TN**4 + R22=.5_kind_phys/(THDIFICE(1)*DELT*dzstop**2) + R6=EMISS *STBOLT*.5_kind_phys*TN**4 R7=R6/TN D11=RNET+R6 - TDENOM=D9*(1.-D1+R22)+D10+R21+R7 & + TDENOM=D9*(one-D1+R22)+D10+R21+R7 & +RAINF*CVW*PRCPMS FKQ=QKMS*RHO R210=R211*RHO @@ -3060,7 +3060,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & +RAINF*CVW*PRCPMS*max(tfrz,TABS) & )/TDENOM AA1=AA - PP=PATM*1.E3 + PP=PATM*rhowater AA1=AA1/PP IF (debug_print ) THEN PRINT *,' VILKA-SEAICE1' @@ -3077,32 +3077,32 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !--- it is saturation over sea ice QVG=QS1 QSG=QS1 - TSO(1)=min(271.4,TS1) - QCG=0. + TSO(1)=min(271.4_kind_phys,TS1) + QCG=zero !--- sea ice melting is not included in this simple approach !--- SOILT - skin temperature SOILT=TSO(1) !---- Final solution for soil temperature - TSO DO K=2,NZS KK=NZS-K+1 - TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1)) + TSO(K)=min(271.4_kind_phys,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO !--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW - DEW=0. + DEW=zero !--- THE DIAGNOSTICS OF SURFACE FLUXES T3 = STBOLT*TN*TN*TN - UPFLUX = T3 *0.5*(TN+SOILT) + UPFLUX = T3 *0.5_kind_phys*(TN+SOILT) XINET = EMISS*(GLW-UPFLUX) HFT=-TKMS*CP*RHO*(TABS-SOILT) HFX=-TKMS*CP*RHO*(TABS-SOILT) & - *(P1000mb*0.00001/Patm)**ROVCP + *(P1000mb*0.00001_kind_phys/Patm)**ROVCP Q1=-QKMS*RAS*(QVATM - QSG) - IF (Q1.LE.0.) THEN + IF (Q1.LE.zero) THEN ! --- condensation if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*rhowater IF (debug_print ) THEN print *,'MYJ EETA',eeta ENDIF @@ -3120,28 +3120,28 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & ! --- evaporation if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*rhowater IF (debug_print ) THEN print *,'MYJ EETA',eeta ENDIF else ! myj ! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************ !-- actual moisture flux from RUC LSM - EETA = Q1*1.E3 + EETA = Q1*rhowater IF (debug_print ) THEN print *,'RUC LSM EETA',eeta ENDIF endif ! myj QFX= XLS * EETA - EETA = Q1*1.E3 + EETA = Q1*rhowater ENDIF EVAPL=EETA S=THDIFICE(1)*CAPICE(1)*DZSTOP*(TSO(1)-TSO(2)) ! heat storage in surface layer - SNOH=0. + SNOH=zero ! There is ice melt - X= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) + & + X= (cp*rho*r211+rhcs*zsmain(2)*0.5_kind_phys/delt)*(SOILT-TN) + & XLS*rho*r211*(QSG-QGOLD) X=X & ! "heat" from rain @@ -3188,7 +3188,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & dew,soilt,soilt1,tsnav, & qvg,qsg,qcg,SMELT,SNOH,SNFLX,SNOM, & edir1,ec1,ett1,eeta,qfx,hfx,s,sublim, & - prcpl,fltot,runoff1,runoff2,mavail,soilice, & + prcpl,fltot,runoff1,runoff2,mavail,soilice, & soiliqw,infiltrp ) !*************************************************************** @@ -3275,12 +3275,12 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & GSWin, & @@ -3294,7 +3294,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: IVGTYP !--- soil properties - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -3306,7 +3306,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & SAT, & WILT - real (kind_phys), INTENT(IN ) :: CN, & + real (kind_phys), INTENT(IN ) :: CN, & CW, & XLV, & G0_P, & @@ -3315,23 +3315,23 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & KWT - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO, & SOILMOIS, & SMFRKEEP - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR @@ -3339,7 +3339,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !-------- 2-d variables - real (kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & CST, & DRIP, & @@ -3376,10 +3376,10 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER, INTENT(INOUT) :: ILNB !-------- 1-d variables - real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & - SOILIQW + real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + SOILIQW - real (kind_phys), INTENT(OUT) :: RSM, & + real (kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables @@ -3387,7 +3387,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER :: nzs1,nzs2,k - real (kind_phys) :: INFILTRP, TRANSUM , & + real (kind_phys) :: INFILTRP, TRANSUM , & SNTH, NEWSN , & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP @@ -3398,7 +3398,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW,DELTSN,H,UMVEG - real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & + real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold @@ -3409,7 +3409,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !----------------------------------------------------------------- cvw=cw - XLMELT=3.35E+5 + XLMELT=3.35E+5_kind_dbl_prec !-- heat of water vapor sublimation XLVm=XLV+XLMELT @@ -3426,48 +3426,48 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & soiltold=soilt qgold=qvg - x=0. + x=zero ! increase thinkness of top snow layer from 3 cm SWE to 5 cm SWE - DELTSN=0.05*1.e3/rhosn - snth=0.01*1.e3/rhosn + DELTSN=0.05_kind_phys*rhowater/rhosn + snth=0.01_kind_phys*rhowater/rhosn ! For 2-layer snow model when the snow depth is marginally higher than DELTSN, ! reset DELTSN to half of snow depth. IF(SNHEI.GE.DELTSN+SNTH) THEN - if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth) + if(snhei-deltsn-snth.lt.snth) deltsn=0.5_kind_phys*(snhei-snth) IF (debug_print ) THEN print *,'DELTSN is changed,deltsn,snhei,snth',i,j,deltsn,snhei,snth ENDIF ENDIF - RHOICE=900. - CI=RHOICE*2100. - RAS=RHO*1.E-3 - RIW=rhoice*1.e-3 - RSM=0. + RHOICE=900._kind_dbl_prec + CI=RHOICE*2100._kind_dbl_prec + RAS=RHO*1.E-3_kind_dbl_prec + RIW=rhoice*1.e-3_kind_dbl_prec + RSM=zero DO K=1,NZS - TRANSP (K)=0. - soilmoism (k)=0. - soiliqwm (k)=0. - soilice (k)=0. - soilicem (k)=0. - lwsat (k)=0. - fwsat (k)=0. - tav (k)=0. - cap (k)=0. - diffu (k)=0. - hydro (k)=0. - thdif (k)=0. - tranf (k)=0. - detal (k)=0. - told (k)=0. - smold (k)=0. + TRANSP (K)=zero + soilmoism (k)=zero + soiliqwm (k)=zero + soilice (k)=zero + soilicem (k)=zero + lwsat (k)=zero + fwsat (k)=zero + tav (k)=zero + cap (k)=zero + diffu (k)=zero + hydro (k)=zero + thdif (k)=zero + tranf (k)=zero + detal (k)=zero + told (k)=zero + smold (k)=zero ENDDO - snweprint=0. - snheiprint=0. + snweprint=zero + snheiprint=zero prcpl=prcpms !*** DELTSN is the depth of the top layer of snow where @@ -3477,7 +3477,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & NZS1=NZS-1 NZS2=NZS-2 - DZSTOP=1./(zsmain(2)-zsmain(1)) + DZSTOP=one/(zsmain(2)-zsmain(1)) !----- THE CALCULATION OF THERMAL DIFFUSIVITY, DIFFUSIONAL AND --- !----- HYDRAULIC CONDUCTIVITY (SMIRNOVA ET AL. 1996, EQ.2,5,6) --- @@ -3486,22 +3486,22 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & DO K=1,NZS tln=log(tso(k)/tfrz) - if(tln.lt.0.) then + if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/9.81/psis) & - **(-1./bclh)-qmin - soiliqw(k)=max(0.,soiliqw(k)) + (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + **(-one/bclh)-qmin + soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) soilice(k)=(soilmois(k)-soiliqw(k))/riw !---- melting and freezing is balanced, soil ice cannot increase if(keepfr(k).eq.1.) then soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(0.,soilmois(k)-soilice(k)*rhoice*1.e-3) + soiliqw(k)=max(zero,soilmois(k)-soilice(k)*rhoice*1.e-3_kind_phys) endif else - soilice(k)=0. + soilice(k)=zero soiliqw(k)=soilmois(k) endif @@ -3509,39 +3509,39 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & DO K=1,NZS1 - tav(k)=0.5*(tso(k)+tso(k+1)) - soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) + tav(k)=0.5_kind_phys*(tso(k)+tso(k+1)) + soilmoism(k)=0.5_kind_phys*(soilmois(k)+soilmois(k+1)) tavln=log(tav(k)/tfrz) - if(tavln.lt.0.) then + if(tavln.lt.zero) then soiliqwm(k)=(dqm+qmin)*(XLMELT* & - (tav(k)-tfrz)/tav(k)/9.81/psis) & - **(-1./bclh)-qmin + (tav(k)-tfrz)/tav(k)/9.81_kind_phys/psis) & + **(-one/bclh)-qmin fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin - soiliqwm(k)=max(0.,soiliqwm(k)) + soiliqwm(k)=max(zero,soiliqwm(k)) soiliqwm(k)=min(soiliqwm(k), soilmoism(k)) soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then + if(keepfr(k).eq.one) then soilicem(k)=min(soilicem(k), & - 0.5*(smfrkeep(k)+smfrkeep(k+1))) - soiliqwm(k)=max(0.,soilmoism(k)-soilicem(k)*riw) + 0.5_kind_phys*(smfrkeep(k)+smfrkeep(k+1))) + soiliqwm(k)=max(zero,soilmoism(k)-soilicem(k)*riw) fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin endif else - soilicem(k)=0. + soilicem(k)=zero soiliqwm(k)=soilmoism(k) lwsat(k)=dqm+qmin - fwsat(k)=0. + fwsat(k)=zero endif ENDDO do k=1,nzs - if(soilice(k).gt.0.) then + if(soilice(k).gt.zero) then smfrkeep(k)=soilice(k) else smfrkeep(k)=soilmois(k)/riw @@ -3568,7 +3568,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !******************************************************************** !--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW - SMELT=0. + SMELT=zero H=MAVAIL ! =1. if snowfrac=1 FQ=QKMS @@ -3577,8 +3577,8 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- If vegfrac.ne.0. then part of falling snow can be !--- intercepted by the canopy. - DEW=0. - UMVEG=1.-vegfrac + DEW=zero + UMVEG=one-vegfrac EPOT = -FQ*(QVATM-QSG) IF (debug_print ) THEN @@ -3589,15 +3589,15 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & SNWEPR=SNWE ! check if all snow can evaporate during DT - BETA=1. + BETA=one EPDT = EPOT * RAS *DELT - IF(EPDT.gt.0. .and. SNWEPR.LE.EPDT) THEN + IF(EPDT > zero .and. SNWEPR.LE.EPDT) THEN BETA=SNWEPR/EPDT - SNWE=0. + SNWE=zero ENDIF - WETCAN=min(0.25,max(0.,(CST/SAT))**CN) - DRYCAN=1.-WETCAN + WETCAN=min(0.25_kind_phys,max(zero,(CST/SAT))**CN) + DRYCAN=one-WETCAN !************************************************************** ! TRANSF computes transpiration function @@ -3647,11 +3647,11 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !************************************************************************ !--- RECALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW - DEW=0. - ETT1=0. - PP=PATM*1.E3 + DEW=zero + ETT1=zero + PP=PATM*rhowater EPOT = -FQ*(QVATM-QSG) - IF(EPOT.GT.0.) THEN + IF(EPOT.GT.zero) THEN ! Evaporation DO K=1,NROOT TRANSP(K)=vegfrac*RAS*FQ*(QVATM-QSG) & @@ -3659,36 +3659,36 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ETT1=ETT1-TRANSP(K) ENDDO DO k=nroot+1,nzs - transp(k)=0. + transp(k)=zero enddo ELSE ! Sublimation DEW=-EPOT DO K=1,NZS - TRANSP(K)=0. + TRANSP(K)=zero ENDDO - ETT1=0. + ETT1=zero ENDIF !-- recalculating of frozen water in soil DO K=1,NZS tln=log(tso(k)/tfrz) - if(tln.lt.0.) then + if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/9.81/psis) & - **(-1./bclh)-qmin - soiliqw(k)=max(0.,soiliqw(k)) + (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + **(-one/bclh)-qmin + soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) soilice(k)=(soilmois(k)-soiliqw(k))/riw !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then + if(keepfr(k).eq.one) then soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw) + soiliqw(k)=max(zero,soilmois(k)-soilice(k)*riw) endif else - soilice(k)=0. + soilice(k)=zero soiliqw(k)=soilmois(k) endif ENDDO @@ -3702,9 +3702,9 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & zsmain,zshalf,diffu,hydro, & QSG,QVG,QCG,QCATM,QVATM,-INFWATER, & - QKMS,TRANSP,0., & - 0.,SMELT,soilice,vegfrac, & - snowfrac,1., & + QKMS,TRANSP,zero, & + zero,SMELT,soilice,vegfrac, & + snowfrac,one, & !-- soil properties DQM,QMIN,REF,KSAT,RAS,INFMAX, & !-- output @@ -3714,13 +3714,13 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ! endif !-- Restore land-use parameters if all snow is melted - IF(SNHEI.EQ.0.) then + IF(SNHEI.EQ.zero) then tsnav=soilt-tfrz ENDIF ! 21apr2009 ! SNOM [mm] goes into the passed-in ACSNOM variable in the grid derived type - SNOM=SNOM+SMELT*DELT*1.e3 + SNOM=SNOM+SMELT*DELT*rhowater ! !--- KEEPFR is 1 when the temperature and moisture in soil !--- are both increasing. In this case soil ice should not @@ -3732,21 +3732,21 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- frozen soil. do k=1,nzs - if (soilice(k).gt.0.) then + if (soilice(k).gt.zero) then if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then - keepfr(k)=1. + keepfr(k)=one else - keepfr(k)=0. + keepfr(k)=zero endif endif enddo !--- THE DIAGNOSTICS OF SURFACE FLUXES T3 = STBOLT*SOILTold*SOILTold*SOILTold - UPFLUX = T3 *0.5*(SOILTold+SOILT) + UPFLUX = T3 *0.5_kind_phys*(SOILTold+SOILT) XINET = EMISS*(GLW-UPFLUX) HFX=-TKMS*CP*RHO*(TABS-SOILT) & - *(P1000mb*0.00001/Patm)**ROVCP + *(P1000mb*0.00001_kind_phys/Patm)**ROVCP IF (debug_print ) THEN print *,'potential temp HFX',hfx ENDIF @@ -3755,16 +3755,16 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & print *,'abs temp HFX',hft ENDIF Q1 = - FQ*RAS* (QVATM - QSG) - CMC2MS=0. - IF (Q1.LT.0.) THEN + CMC2MS= zero + IF (Q1.LT.zero) THEN ! --- condensation - EDIR1=0. - EC1=0. - ETT1=0. + EDIR1=zero + EC1=zero + ETT1=zero ! --- condensation if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*rhowater CST= CST-EETA*DELT*vegfrac IF (debug_print ) THEN print *,'MYJ EETA cond', EETA @@ -3786,7 +3786,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & CMC2MS=CST/DELT*RAS EC1 = Q1 * WETCAN * vegfrac - CST=max(0.,CST-EC1 * DELT) + CST=max(zero,CST-EC1 * DELT) IF (debug_print ) THEN print*,'Q1,umveg,beta',Q1,umveg,beta @@ -3796,23 +3796,23 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-(QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3)*BETA + EETA=-(QKMS*RAS*(QVATM/(one+QVATM) - QSG/(one+QSG))*rhowater)*BETA IF (debug_print ) THEN print *,'MYJ EETA', EETA*XLVm,EETA ENDIF else ! myj ! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************ !-- actual moisture flux from RUC LSM - EETA = (EDIR1 + EC1 + ETT1)*1.E3 + EETA = (EDIR1 + EC1 + ETT1)*rhowater IF (debug_print ) THEN print *,'RUC LSM EETA',EETA*XLVm,EETA ENDIF endif ! myj QFX= XLVm * EETA - EETA = (EDIR1 + EC1 + ETT1)*1.E3 + EETA = (EDIR1 + EC1 + ETT1)*rhowater ENDIF S=SNFLX - sublim=Q1*1.E3 !kg m-2 s-1 + sublim=Q1*rhowater !kg m-2 s-1 ! Energy budget FLTOT=RNET-HFT-XLVm*EETA-S-SNOH-x IF (debug_print ) THEN @@ -5578,11 +5578,11 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & IF(SOILT.GT.tfrz.AND.BETA.EQ.1.AND.SNHEI.GT.0.) THEN !-- snow sublimation and melting nmelt = 1 - soiltfrac=snowfrac*tfrz+(1.-snowfrac)*SOILT + soiltfrac=snowfrac*tfrz+(one-snowfrac)*SOILT QSG=min(QSG, QSN(soiltfrac,TBQ)/PP) qvg=qsg T3 = STBOLT*TN*TN*TN - UPFLUX = T3 * 0.5*(TN + SOILTfrac) + UPFLUX = T3 * 0.5_kind_phys*(TN + SOILTfrac) XINET = EMISS*(GLW-UPFLUX) EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS From 94ff8a2f430a55a5848bdb2a7799bc58b41d0f2a Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 22 Mar 2023 14:18:40 +0000 Subject: [PATCH 14/28] More changes in RUC LSM related to kind_phys. --- physics/module_sf_ruclsm.F90 | 313 +++++++++++++++++------------------ 1 file changed, 156 insertions(+), 157 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 653323419..16fb5ef28 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -3875,12 +3875,12 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & RHO, & @@ -3888,35 +3888,35 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & TKMS !--- sea ice properties - real (kind_phys), DIMENSION(1:NZS) , & + real (kind_phys), DIMENSION(1:NZS) , & INTENT(IN ) :: & tice, & rhosice, & capice, & thdifice - real (kind_phys), INTENT(IN ) :: & + real (kind_phys), INTENT(IN ) :: & CW, & XLV - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & - ZSHALF, & - DTDZS2 + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + ZSHALF, & + DTDZS2 - real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO INTEGER, INTENT(INOUT) :: ILAND !-------- 2-d variables - real (kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & EETA, & RHOSN, & @@ -3944,27 +3944,27 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & INTEGER, INTENT(INOUT) :: ILNB - real (kind_phys), INTENT(OUT) :: RSM, & - SNWEPRINT, & - SNHEIPRINT + real (kind_phys), INTENT(OUT) :: RSM, & + SNWEPRINT, & + SNHEIPRINT !--- Local variables INTEGER :: nzs1,nzs2,k,k1,kn,kk real (kind_phys) :: x,x1,x2,dzstop,ft,tn,denom - real (kind_phys) :: SNTH, NEWSN , & + real (kind_phys) :: SNTH, NEWSN , & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP - real (kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & + real (kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & epot,fltot,fq,hft,q1,ras,rhoice,ci,cvw , & RIW,DELTSN,H - real (kind_phys) :: rhocsn,thdifsn, & + real (kind_phys) :: rhocsn,thdifsn, & xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn real (kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - real (kind_phys) :: fso,fsn, & + real (kind_phys) :: fso,fsn, & FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & FKQ,R210,AA,BB,QS1,TS1,TQ2,TX2, & TDENOM,AA1,RHCS,H1,TSOB, SNPRIM, & @@ -3977,14 +3977,14 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & real (kind_phys) :: keff, fact !----------------------------------------------------------------- - XLMELT=3.35E+5 + XLMELT=3.35E+5_kind_dbl_prec !-- heat of sublimation of water vapor XLVm=XLV+XLMELT !-- options for snow conductivity: !-- 1 - constant !-- opt 2 - Sturm et al., 1997 - keff = 0.265 + keff = 0.265_kind_phys !--- SNOW flag -- ISICE !--- DELTSN - is the threshold for splitting the snow layer into 2 layers. @@ -3995,78 +3995,78 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !--- the top sea ice layer. SNTH is computed using snwe=0.016 m, and !--- equals 4 cm for snow density 400 kg/m^3. - DELTSN=0.05*1.e3/rhosn - snth=0.01*1.e3/rhosn + DELTSN=0.05_kind_phys*rhowater/rhosn + snth=0.01_kind_phys*rhowater/rhosn ! For 2-layer snow model when the snow depth is marginlly higher than DELTSN, ! reset DELTSN to half of snow depth. IF(SNHEI.GE.DELTSN+SNTH) THEN - if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth) + if(snhei-deltsn-snth.lt.snth) deltsn=0.5_kind_phys*(snhei-snth) IF (debug_print ) THEN print *,'DELTSN ICE is changed,deltsn,snhei,snth', & i,j, deltsn,snhei,snth ENDIF ENDIF - RHOICE=900. - CI=RHOICE*2100. - RAS=RHO*1.E-3 - RIW=rhoice*1.e-3 - RSM=0. + RHOICE=900._kind_dbl_prec + CI=RHOICE*2100._kind_dbl_prec + RAS=RHO*1.E-3_kind_dbl_prec + RIW=rhoice*1.e-3_kind_dbl_prec + RSM=zero - XLMELT=3.35E+5 - RHOCSN=2090.* RHOSN + XLMELT=3.35E+5_kind_dbl_prec + RHOCSN=2090._kind_dbl_prec * RHOSN !18apr08 - add rhonewcsn - RHOnewCSN=2090.* RHOnewSN + RHOnewCSN=2090._kind_dbl_prec * RHOnewSN if(isncond_opt == 1) then - if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN endif else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) - fact = 1. - if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then - keff = 0.023 + 0.234 * rhosn * 1.e-3 + fact = one + if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then + keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5. + fact = 5._kind_phys else - keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 - fact = 2. + keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys + fact = 2._kind_phys endif - if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else thdifsn = keff/rhocsn * fact endif endif - RAS=RHO*1.E-3 + RAS=RHO*1.E-3_kind_phys SOILTFRAC=SOILT - SMELT=0. - SOH=0. - SNODIF=0. - SNOH=0. - SNOHGNEW=0. - RSM = 0. - RSMFRAC = 0. - fsn=1. - fso=0. + SMELT=zero + SOH=zero + SNODIF=zero + SNOH=zero + SNOHGNEW=zero + RSM=zero + RSMFRAC=zero + fsn=one + fso=zero cvw=cw NZS1=NZS-1 @@ -4074,10 +4074,10 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & QGOLD=QSG TNOLD=SOILT - DZSTOP=1./(ZSMAIN(2)-ZSMAIN(1)) + DZSTOP=one/(ZSMAIN(2)-ZSMAIN(1)) - snweprint=0. - snheiprint=0. + snweprint=zero + snheiprint=zero prcpl=prcpms !*** DELTSN is the depth of the top layer of snow where @@ -4085,27 +4085,27 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !*** is considered to have constant temperature - H=1. - SMELT=0. + H=one + SMELT=zero FQ=QKMS - SNHEI=SNWE*1.e3/RHOSN - SNWEPR=SNWE + SNHEI=SNWE*rhowater/RHOSN + SNWEPR=SNWE ! check if all snow can evaporate during DT - BETA=1. + BETA=one EPOT = -FQ*(QVATM-QSG) EPDT = EPOT * RAS *DELT - IF(EPDT.GT.0. .and. SNWEPR.LE.EPDT) THEN - BETA=SNWEPR/max(1.e-8,EPDT) - SNWE=0. + IF(EPDT.GT.zero .and. SNWEPR.LE.EPDT) THEN + BETA=SNWEPR/max(1.e-8_kind_phys,EPDT) + SNWE=zero ENDIF !****************************************************************************** ! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO !****************************************************************************** - cotso(1)=0. + cotso(1)=zero rhtso(1)=TSO(NZS) DO 33 K=1,NZS2 KN=NZS-K @@ -4127,19 +4127,19 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & snprim=max(snth,snhei) soilt1=tso(1) tsob=tso(1) - XSN = DELT/2./(zshalf(2)+0.5*SNPRIM) + XSN = DELT/2._kind_phys/(zshalf(2)+0.5_kind_phys*SNPRIM) DDZSN = XSN / SNPRIM X1SN = DDZSN * thdifsn X2 = DTDZS(1)*THDIFICE(1) FT = TSO(1)+X1SN*(SOILT-TSO(1)) & -X2*(TSO(1)-TSO(2)) - DENOM = 1. + X1SN + X2 -X2*cotso(NZS1) + DENOM = one + X1SN + X2 -X2*cotso(NZS1) cotso(NZS)=X1SN/DENOM rhtso(NZS)=(FT+X2*rhtso(NZS1))/DENOM cotsn=cotso(NZS) rhtsn=rhtso(NZS) !*** Average temperature of snow pack (C) - tsnav=0.5*(soilt+tso(1)) & + tsnav=0.5_kind_phys*(soilt+tso(1)) & -tfrz else @@ -4147,8 +4147,8 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ilnb=2 snprim=deltsn tsob=soilt1 - XSN = DELT/2./(0.5*SNHEI) - XSN1= DELT/2./(zshalf(2)+0.5*(SNHEI-DELTSN)) + XSN = DELT/2._kind_phys/(0.5_kind_phys*SNHEI) + XSN1= DELT/2._kind_phys/(zshalf(2)+0.5_kind_phys*(SNHEI-DELTSN)) DDZSN = XSN / DELTSN DDZSN1 = XSN1 / (SNHEI-DELTSN) X1SN = DDZSN * thdifsn @@ -4156,7 +4156,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & X2 = DTDZS(1)*THDIFICE(1) FT = TSO(1)+X1SN1*(SOILT1-TSO(1)) & -X2*(TSO(1)-TSO(2)) - DENOM = 1. + X1SN1 + X2 - X2*cotso(NZS1) + DENOM = one + X1SN1 + X2 - X2*cotso(NZS1) cotso(nzs)=x1sn1/denom rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom ftsnow = soilt1+x1sn*(soilt-soilt1) & @@ -4165,30 +4165,30 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & cotsn=x1sn/denomsn rhtsn=(ftsnow+X1SN1*rhtso(NZS))/denomsn !*** Average temperature of snow pack (C) - tsnav=0.5/snhei*((soilt+soilt1)*deltsn & + tsnav=0.5_kind_phys/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & -tfrz endif ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + IF(SNHEI.LT.SNTH.AND.SNHEI.GT.zero) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first sea ice layer. snprim=SNHEI+zsmain(2) fsn=SNHEI/snprim - fso=1.-fsn + fso=one-fsn soilt1=tso(1) tsob=tso(2) - XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) + XSN = DELT/2._kind_phys/((zshalf(3)-zsmain(2))+0.5_kind_phys*snprim) DDZSN = XSN /snprim X1SN = DDZSN * (fsn*thdifsn+fso*thdifice(1)) X2=DTDZS(2)*THDIFICE(2) FT=TSO(2)+X1SN*(SOILT-TSO(2))- & X2*(TSO(2)-TSO(3)) - denom = 1. + x1sn + x2 - x2*cotso(nzs-2) + denom = one + x1sn + x2 - x2*cotso(nzs-2) cotso(nzs1) = x1sn/denom rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom - tsnav=0.5*(soilt+tso(1)) & + tsnav=0.5_kind_phys*(soilt+tso(1)) & -tfrz cotso(nzs)=cotso(NZS1) rhtso(nzs)=rhtso(nzs1) @@ -4200,21 +4200,21 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !--- THE HEAT BALANCE EQUATION !18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes nmelt=0 - SNOH=0. + SNOH=zero EPOT=-QKMS*(QVATM-QSG) RHCS=CAPICE(1) - H=1. + H=one FKT=TKMS D1=cotso(NZS1) D2=rhtso(NZS1) TN=SOILT D9=THDIFICE(1)*RHCS*dzstop D10=TKMS*CP*RHO - R211=.5*CONFLX/DELT + R211=.5_kind_phys*CONFLX/DELT R21=R211*CP*RHO - R22=.5/(THDIFICE(1)*DELT*dzstop**2) - R6=EMISS *STBOLT*.5*TN**4 + R22=.5_kind_phys/(THDIFICE(1)*DELT*dzstop**2) + R6=EMISS *STBOLT*.5_kind_phys*TN**4 R7=R6/TN D11=RNET+R6 @@ -4229,20 +4229,20 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & D2SN = rhtsn endif D9SN= THDIFSN*RHOCSN / SNPRIM - R22SN = SNPRIM*SNPRIM*0.5/(THDIFSN*DELT) + R22SN = SNPRIM*SNPRIM*0.5_kind_phys/(THDIFSN*DELT) ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + IF(SNHEI.LT.SNTH.AND.SNHEI.GT.zero) then !--- thin snow is combined with sea ice D1SN = D1 D2SN = D2 D9SN = (fsn*THDIFSN*RHOCSN+fso*THDIFICE(1)*RHCS)/ & snprim - R22SN = snprim*snprim*0.5 & + R22SN = snprim*snprim*0.5_kind_phys & /((fsn*THDIFSN+fso*THDIFICE(1))*delt) ENDIF - IF(SNHEI.eq.0.)then + IF(SNHEI.eq.zero)then !--- all snow is sublimated D9SN = D9 R22SN = R22 @@ -4252,7 +4252,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !---- TDENOM for snow - TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7 & + TDENOM = D9SN*(one-D1SN +R22SN)+D10+R21+R7 & +RAINF*CVW*PRCPMS & +RHOnewCSN*NEWSNOW/DELT @@ -4262,11 +4262,11 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & BB=(D10*TABS+R21*TN+XLVM*(QVATM* & (BETA*FKQ) & +R210*QVG)+D11+D9SN*(D2SN+R22SN*TN) & - +RAINF*CVW*PRCPMS*max(tfrz,TABS) & - + RHOnewCSN*NEWSNOW/DELT*min(tfrz,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & + + RHOnewCSN*NEWSNOW/DELT*min(tfrz,TABS) & )/TDENOM AA1=AA - PP=PATM*1.E3 + PP=PATM*1.E3_kind_phys AA1=AA1/PP !18apr08 - the iteration start point 212 continue @@ -4282,11 +4282,11 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !--- it is saturation over snow QVG=QS1 QSG=QS1 - QCG=0. + QCG=zero !--- SOILT - skin temperature of snow on ice SOILT=TS1 - if(nmelt==1 .and. snowfrac==1) then + if(nmelt==1 .and. snowfrac==one) then soilt = min(tfrz,soilt) endif @@ -4299,37 +4299,37 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(snhei.gt.DELTSN+SNTH) then !-- 2-layer snow model SOILT1=min(tfrz,rhtsn+cotsn*SOILT) - TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT1)) + TSO(1)=min(271.4_kind_phys,(rhtso(NZS)+cotso(NZS)*SOILT1)) tsob=soilt1 else !-- 1 layer in snow - TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT)) + TSO(1)=min(271.4_kind_phys,(rhtso(NZS)+cotso(NZS)*SOILT)) SOILT1=TSO(1) tsob=tso(1) endif - ELSEIF (SNHEI > 0. .and. SNHEI < SNTH) THEN + ELSEIF (SNHEI > zero .and. SNHEI < SNTH) THEN ! blended - TSO(2)=min(271.4,(rhtso(NZS1)+cotso(NZS1)*SOILT)) - tso(1)=min(271.4,(tso(2)+(soilt-tso(2))*fso)) + TSO(2)=min(271.4_kind_phys,(rhtso(NZS1)+cotso(NZS1)*SOILT)) + tso(1)=min(271.4_kind_phys,(tso(2)+(soilt-tso(2))*fso)) SOILT1=TSO(1) tsob=TSO(2) ELSE ! snow is melted - TSO(1)=min(271.4,SOILT) - SOILT1=min(271.4,SOILT) + TSO(1)=min(271.4_kind_phys,SOILT) + SOILT1=min(271.4_kind_phys,SOILT) tsob=tso(1) ENDIF !---- Final solution for TSO in sea ice - IF (SNHEI > 0. .and. SNHEI < SNTH) THEN + IF (SNHEI > zero .and. SNHEI < SNTH) THEN ! blended or snow is melted DO K=3,NZS KK=NZS-K+1 - TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1)) + TSO(K)=min(271.4_kind_phys,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO ELSE DO K=2,NZS KK=NZS-K+1 - TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1)) + TSO(K)=min(271.4_kind_phys,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO ENDIF !--- For thin snow layer combined with the top soil layer @@ -4348,16 +4348,16 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & IF(SOILT>tfrz .AND. BETA==one .AND. SNHEI>zero) THEN ! nmelt = 1 - soiltfrac=snowfrac*tfrz+(1.-snowfrac)*min(271.4,SOILT) + soiltfrac=snowfrac*tfrz+(1.-snowfrac)*min(271.4_kind_phys,SOILT) QSG= QSN(soiltfrac,TBQ)/PP T3 = STBOLT*TNold*TNold*TNold - UPFLUX = T3 * 0.5*(TNold+SOILTfrac) + UPFLUX = T3 * 0.5_kind_phys*(TNold+SOILTfrac) XINET = EMISS*(GLW-UPFLUX) EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS - IF (Q1.LE.0.) THEN + IF (Q1.LE.zero) THEN ! --- condensation DEW=-EPOT @@ -4365,7 +4365,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & EETA=QFX/XLVM ELSE ! --- evaporation - EETA = Q1 * BETA *1.E3 + EETA = Q1 * BETA * rhowater ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ QFX= - XLVM * EETA ENDIF @@ -4395,17 +4395,17 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & print *,'RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac)', & RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac) ENDIF - SNOH=AMAX1(0._kind_phys,SNOH) + SNOH=AMAX1(zero,SNOH) !-- SMELT is speed of melting in M/S - SMELT= SNOH /XLMELT*1.E-3 + SMELT= SNOH /XLMELT*1.E-3_kind_phys SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) - SMELT=AMAX1(0._kind_phys,SMELT) + SMELT=AMAX1(zero,SMELT) IF (debug_print ) THEN print *,'1-SMELT i,j',smelt,i,j ENDIF !18apr08 - Egglston limit - SMELT= amin1 (smelt,delt/60.* 5.6E-8*meltfactor*max(1.,(soilt-tfrz))) ! SnowMIP + SMELT= amin1 (smelt,delt/60._kind_phys* 5.6E-8_kind_phys*meltfactor*max(one,(soilt-tfrz))) ! SnowMIP IF (debug_print ) THEN print *,'2-SMELT i,j',smelt,i,j ENDIF @@ -4417,7 +4417,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & print *,'3- SMELT i,j,smelt,rr',i,j,smelt,rr ENDIF SNOHGNEW=SMELT*XLMELT*1.E3 - SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) + SNODIF=AMAX1(zero,(SNOH-SNOHGNEW)) SNOH=SNOHGNEW @@ -4428,15 +4428,15 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ENDIF !*** From Koren et al. (1999) 13% of snow melt stays in the snow pack - rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) - if(snhei > 0.01) then + rsmfrac=min(0.18_kind_phys,(max(0.08_kind_phys,snwepr/0.10_kind_phys*0.13_kind_phys))) + if(snhei > 0.01_kind_phys) then rsm=rsmfrac*smelt*delt else ! do not keep melted water if snow depth is less that 1 cm - rsm=0. + rsm=zero endif !18apr08 rsm is part of melted water that stays in snow as liquid - SMELT=AMAX1(0.,SMELT-rsm/delt) + SMELT=AMAX1(zero,SMELT-rsm/delt) IF (debug_print ) THEN print *,'4-SMELT i,j,smelt,rsm,snwepr,rsmfrac', & i,j,smelt,rsm,snwepr,rsmfrac @@ -4444,19 +4444,19 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !-- update liquid equivalent of snow depth !-- for evaporation and snow melt - SNWE = AMAX1(0.,(SNWEPR- & + SNWE = AMAX1(zero,(SNWEPR- & (SMELT+BETA*EPOT*RAS)*DELT & ) ) soilt=soiltfrac !--- If there is no snow melting then just evaporation !--- or condensation changes SNWE ELSE - if(snhei.ne.0..and. beta == 1.) then + if(snhei > zero.and. beta == one) then EPOT=-QKMS*(QVATM-QSG) - SNWE = AMAX1(0.,(SNWEPR- & + SNWE = AMAX1(zero,(SNWEPR- & BETA*EPOT*RAS*DELT)) else - snwe = 0. + snwe = zero endif ENDIF @@ -4466,7 +4466,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ! if(nmelt.eq.1) goto 212 ! second iteration 220 continue - if(smelt > 0..and. rsm > 0.) then + if(smelt > zero .and. rsm > zero) then if(snwe.le.rsm) then IF (debug_print ) THEN print *,'SEAICE SNWE 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN endif else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) - fact = 1. - if(rhosn < 156. .or. (newsn > 0. .and. rhonewsn < 156.)) then - keff = 0.023 + 0.234 * rhosn * 1.e-3 + fact = one + if(rhosn < 156._kind_phys .or. (newsn > zero .and. rhonewsn < 156._kind_phys)) then + keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5. + fact = 5._kind_phys else - keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 - fact = 2. + keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys + fact = 2._kind_phys endif - if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -4522,51 +4522,50 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & endif snweprint=snwe -! & !--- if VEGFRAC.ne.0. then some snow stays on the canopy !--- and should be added to SNWE for water conservation -! 4 Nov 07 +VEGFRAC*cst - snheiprint=snweprint*1.E3 / RHOSN +! +VEGFRAC*cst + snheiprint=snweprint*rhowater / RHOSN IF (debug_print ) THEN print *, 'snweprint : ',snweprint print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB ENDIF - IF(SNHEI.GT.0.) THEN + IF(SNHEI.GT.zero) THEN if(ilnb.gt.1) then - tsnav=0.5/snhei*((soilt+soilt1)*deltsn & + tsnav=0.5_kind_phys/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & -tfrz else - tsnav=0.5*(soilt+tso(1)) - tfrz + tsnav=0.5_kind_phys*(soilt+tso(1)) - tfrz endif ENDIF !--- RECALCULATION OF DEW USING NEW VALUE OF QSG - DEW=0. - PP=PATM*1.E3 + DEW=zero + PP=PATM*1.E3_kind_phys QSG= QSN(SOILT,TBQ)/PP EPOT = -FQ*(QVATM-QSG) - IF(EPOT.LT.0.) THEN + IF(EPOT.LT.zero) THEN ! Sublimation DEW=-EPOT ENDIF - SNOM=SNOM+SMELT*DELT*1.e3 + SNOM=SNOM+SMELT*DELT*rhowater !--- THE DIAGNOSTICS OF SURFACE FLUXES T3 = STBOLT*TNold*TNold*TNold - UPFLUX = T3 *0.5*(SOILT+TNold) + UPFLUX = T3 *0.5_kind_phys*(SOILT+TNold) XINET = EMISS*(GLW-UPFLUX) HFT=-TKMS*CP*RHO*(TABS-SOILT) HFX=-TKMS*CP*RHO*(TABS-SOILT) & - *(P1000mb*0.00001/Patm)**ROVCP + *(P1000mb*0.00001_kind_phys/Patm)**ROVCP Q1 = - FQ*RAS* (QVATM - QSG) - IF (Q1.LT.0.) THEN + IF (Q1.LT.zero) THEN ! --- condensation if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*rhowater else ! myj !-- actual moisture flux from RUC LSM DEW=QKMS*(QVATM-QSG) @@ -4579,22 +4578,22 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ! --- evaporation if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*BETA*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 + EETA=-QKMS*RAS*BETA*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*rhowater else ! myj ! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************ !-- actual moisture flux from RUC LSM - EETA = Q1*BETA*1.E3 + EETA = Q1*BETA*rhowater endif ! myj QFX= XLVm * EETA - EETA = Q1*BETA*1.E3 + EETA = Q1*BETA*rhowater sublim = EETA ENDIF - icemelt=0. + icemelt=zero IF(SNHEI.GE.SNTH)then S=thdifsn*RHOCSN*(soilt-TSOB)/SNPRIM SNFLX=S - ELSEIF(SNHEI.lt.SNTH.and.SNHEI.GT.0.) then + ELSEIF(SNHEI.lt.SNTH.and.SNHEI.GT.zero) then S=(fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)* & (soilt-TSOB)/snprim SNFLX=S @@ -4608,7 +4607,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ENDIF ENDIF - SNHEI=SNWE *1.E3 / RHOSN + SNHEI=SNWE *rhowater / RHOSN IF (debug_print ) THEN print *,'SNHEI,SNOH',i,j,SNHEI,SNOH @@ -4639,11 +4638,11 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ,FLTOT,RNET,HFT,XLVm*EETA,s,SNOH,icemelt,snodif,X,SOILT ENDIF !-- Restore sea-ice parameters if snow is less than threshold - IF(SNHEI.EQ.0.) then + IF(SNHEI.EQ.zero) then tsnav=soilt-tfrz - emiss=0.98 - znt=0.011 - alb=0.55 + emiss=0.98_kind_phys + znt=0.011_kind_phys + alb=0.55_kind_phys ENDIF !------------------------------------------------------------------------ From 0dbe50abdd1895954af6fcca93574c4715d31428 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 22 Mar 2023 19:39:08 +0000 Subject: [PATCH 15/28] In GFS_diag.F90 moved Trans variable from Diag DDT to GFS_diagtoscreen. Uncommented snowd_land, and removed snowd_water. --- physics/GFS_debug.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 0414a553f..f98eec824 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -699,6 +699,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tdomzr ', Diag%tdomzr) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tdomip ', Diag%tdomip) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tdoms ', Diag%tdoms) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%trans ', Diag%trans) ! CCPP/RUC only if (Model%lsm == Model%lsm_ruc) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%wetness ', Sfcprop%wetness) @@ -1318,8 +1319,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmatot ', Interstitial%sigmatot ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowc ', Interstitial%snowc ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_ice ', Interstitial%snowd_ice ) -! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) -! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_water ', Interstitial%snowd_water ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snohf ', Interstitial%snohf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowmt ', Interstitial%snowmt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress ', Interstitial%stress ) @@ -1332,7 +1332,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_ice ', Interstitial%tprcp_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_land ', Interstitial%tprcp_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_water ', Interstitial%tprcp_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%trans ', Interstitial%trans ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tseal ', Interstitial%tseal ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfa ', Interstitial%tsfa ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_water ', Interstitial%tsfc_water ) From 777637ba73974134991bee2b730791bc8cf2a893 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 22 Mar 2023 22:05:00 +0000 Subject: [PATCH 16/28] More changes related to kind_phys. Use constants from Physcons. --- physics/module_sf_ruclsm.F90 | 849 +++++++++++++++++------------------ 1 file changed, 417 insertions(+), 432 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 16fb5ef28..66f4cb660 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -10,6 +10,8 @@ MODULE module_sf_ruclsm use machine , only : kind_phys, kind_dbl_prec use namelist_soilveg_ruc + use physcons, only : rhowater, con_t0c, con_hfus, con_hvap, & + con_pi, con_rv, con_g, con_csol, con_tice implicit none @@ -20,14 +22,19 @@ MODULE module_sf_ruclsm !> CONSTANT PARAMETERS !! @{ - real (kind_phys), parameter :: P1000mb = 100000._kind_dbl_prec - real (kind_phys), parameter :: xls = 2.85E6_kind_dbl_prec - real (kind_phys), parameter :: rhowater= 1000._kind_dbl_prec - real (kind_phys), parameter :: piconst = 3.1415926535897931_kind_dbl_prec - real (kind_phys), parameter :: r_v = 461.50_kind_dbl_prec - real (kind_phys), parameter :: zero = 0._kind_dbl_prec - real (kind_phys), parameter :: one = 1._kind_dbl_prec - real (kind_phys), parameter :: tfrz = 273.15_kind_dbl_prec + real (kind_phys), parameter :: tfrz = con_t0c + real (kind_phys), parameter :: xls = con_hvap + con_hfus + real (kind_phys), parameter :: piconst = con_pi + real (kind_phys), parameter :: r_v = con_rv + real (kind_phys), parameter :: grav = con_g + real (kind_phys), parameter :: sheatice = con_csol + + real (kind_phys), parameter :: rhoice = 917._kind_phys ! ice density + real (kind_phys), parameter :: sheatsn = 2090._kind_phys ! snow heat capacity + real (kind_phys), parameter :: P1000mb = 100000._kind_phys + + real (kind_phys), parameter :: zero = 0._kind_dbl_prec + real (kind_phys), parameter :: one = 1._kind_dbl_prec !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 integer, parameter :: isncond_opt = 1 @@ -877,7 +884,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & smfr3d(i,k,j) = one sh2o(i,k,j) = zero keepfr3dflag(i,k,j) = zero - tso(i,k,j) = min(271.4_kind_phys,tso(i,k,j)) + tso(i,k,j) = min(con_tice,tso(i,k,j)) ENDDO ENDIF @@ -2468,7 +2475,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & TABS, T3, UPFLUX, XINET real (kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & can,epot,fac,fltot,ft,fq,hft , & - q1,ras,rhoice,sph , & + q1,ras,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW, X @@ -2485,9 +2492,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !----------------------------------------------------------------- !-- define constants - RHOICE=900._kind_phys - CI=RHOICE*2100._kind_phys - XLMELT=3.35E+5_kind_phys + CI=RHOICE*sheatice + XLMELT=con_hfus cvw=cw prcpl=prcpms @@ -2522,8 +2528,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & NZS1=NZS-1 NZS2=NZS-2 dzstop=one/(zsmain(2)-zsmain(1)) - RAS=RHO*1.E-3_kind_phys - RIW=rhoice*1.e-3_kind_phys + RAS=RHO*1.E-3_kind_phys ! rho/rhowater + RIW=rhoice*1.e-3_kind_phys ! rhoice/rhowater !--- Computation of volumetric content of ice in soil @@ -2532,7 +2538,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & tln=log(tso(k)/tfrz) if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + (tso(k)-tfrz)/tso(k)/grav/psis) & **(-one/bclh)-qmin soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -2559,7 +2565,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & if(tavln.lt.zero) then soiliqwm(k)=(dqm+qmin)*(XLMELT* & - (tav(k)-tfrz)/tav(k)/9.81_kind_phys/psis) & + (tav(k)-tfrz)/tav(k)/grav/psis) & **(-one/bclh)-qmin fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin @@ -2737,7 +2743,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & tln=log(tso(k)/tfrz) if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + (tso(k)-tfrz)/tso(k)/grav/psis) & **(-one/bclh)-qmin soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -3004,7 +3010,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !----------------------------------------------------------------- !-- define constants - XLMELT=3.35E+5_kind_dbl_prec + XLMELT=con_hfus cvw=cw prcpl=prcpms @@ -3077,7 +3083,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !--- it is saturation over sea ice QVG=QS1 QSG=QS1 - TSO(1)=min(271.4_kind_phys,TS1) + TSO(1)=min(con_tice,TS1) QCG=zero !--- sea ice melting is not included in this simple approach !--- SOILT - skin temperature @@ -3085,7 +3091,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !---- Final solution for soil temperature - TSO DO K=2,NZS KK=NZS-K+1 - TSO(K)=min(271.4_kind_phys,rhtso(KK)+cotso(KK)*TSO(K-1)) + TSO(K)=min(con_tice,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO !--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW DEW=zero @@ -3393,7 +3399,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & BETA, SNWEPR,EPDT,PP real (kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt,dzstop, & can,epot,fac,fltot,ft,fq,hft , & - q1,ras,rhoice,sph , & + q1,ras,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW,DELTSN,H,UMVEG @@ -3409,7 +3415,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !----------------------------------------------------------------- cvw=cw - XLMELT=3.35E+5_kind_dbl_prec + XLMELT=con_hfus !-- heat of water vapor sublimation XLVm=XLV+XLMELT @@ -3441,10 +3447,9 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ENDIF ENDIF - RHOICE=900._kind_dbl_prec - CI=RHOICE*2100._kind_dbl_prec - RAS=RHO*1.E-3_kind_dbl_prec - RIW=rhoice*1.e-3_kind_dbl_prec + CI=RHOICE*sheatice + RAS=RHO*1.E-3_kind_dbl_prec ! rho/rhowater + RIW=rhoice*1.e-3_kind_dbl_prec ! rhoice/rhowater RSM=zero DO K=1,NZS @@ -3488,7 +3493,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & tln=log(tso(k)/tfrz) if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + (tso(k)-tfrz)/tso(k)/grav/psis) & **(-one/bclh)-qmin soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -3497,7 +3502,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !---- melting and freezing is balanced, soil ice cannot increase if(keepfr(k).eq.1.) then soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(zero,soilmois(k)-soilice(k)*rhoice*1.e-3_kind_phys) + soiliqw(k)=max(zero,soilmois(k)-soilice(k)*riw) endif else @@ -3515,7 +3520,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & if(tavln.lt.zero) then soiliqwm(k)=(dqm+qmin)*(XLMELT* & - (tav(k)-tfrz)/tav(k)/9.81_kind_phys/psis) & + (tav(k)-tfrz)/tav(k)/grav/psis) & **(-one/bclh)-qmin fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin @@ -3676,7 +3681,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & tln=log(tso(k)/tfrz) if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + (tso(k)-tfrz)/tso(k)/grav/psis) & **(-one/bclh)-qmin soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -3957,7 +3962,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP real (kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & - epot,fltot,fq,hft,q1,ras,rhoice,ci,cvw , & + epot,fltot,fq,hft,q1,ras,ci,cvw , & RIW,DELTSN,H real (kind_phys) :: rhocsn,thdifsn, & @@ -3977,7 +3982,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & real (kind_phys) :: keff, fact !----------------------------------------------------------------- - XLMELT=3.35E+5_kind_dbl_prec + XLMELT=con_hfus !-- heat of sublimation of water vapor XLVm=XLV+XLMELT @@ -4008,16 +4013,15 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ENDIF ENDIF - RHOICE=900._kind_dbl_prec - CI=RHOICE*2100._kind_dbl_prec - RAS=RHO*1.E-3_kind_dbl_prec - RIW=rhoice*1.e-3_kind_dbl_prec + CI=RHOICE*sheatice + RAS=RHO*1.E-3_kind_dbl_prec ! rho/rhowater + RIW=rhoice*1.e-3_kind_dbl_prec ! rhoice/rhowater RSM=zero - XLMELT=3.35E+5_kind_dbl_prec - RHOCSN=2090._kind_dbl_prec * RHOSN + XLMELT=con_hfus + RHOCSN=sheatsn * RHOSN !18apr08 - add rhonewcsn - RHOnewCSN=2090._kind_dbl_prec * RHOnewSN + RHOnewCSN=sheatsn * RHOnewSN if(isncond_opt == 1) then if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then @@ -4299,24 +4303,24 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(snhei.gt.DELTSN+SNTH) then !-- 2-layer snow model SOILT1=min(tfrz,rhtsn+cotsn*SOILT) - TSO(1)=min(271.4_kind_phys,(rhtso(NZS)+cotso(NZS)*SOILT1)) + TSO(1)=min(con_tice,(rhtso(NZS)+cotso(NZS)*SOILT1)) tsob=soilt1 else !-- 1 layer in snow - TSO(1)=min(271.4_kind_phys,(rhtso(NZS)+cotso(NZS)*SOILT)) + TSO(1)=min(con_tice,(rhtso(NZS)+cotso(NZS)*SOILT)) SOILT1=TSO(1) tsob=tso(1) endif ELSEIF (SNHEI > zero .and. SNHEI < SNTH) THEN ! blended - TSO(2)=min(271.4_kind_phys,(rhtso(NZS1)+cotso(NZS1)*SOILT)) - tso(1)=min(271.4_kind_phys,(tso(2)+(soilt-tso(2))*fso)) + TSO(2)=min(con_tice,(rhtso(NZS1)+cotso(NZS1)*SOILT)) + tso(1)=min(con_tice,(tso(2)+(soilt-tso(2))*fso)) SOILT1=TSO(1) tsob=TSO(2) ELSE ! snow is melted - TSO(1)=min(271.4_kind_phys,SOILT) - SOILT1=min(271.4_kind_phys,SOILT) + TSO(1)=min(con_tice,SOILT) + SOILT1=min(con_tice,SOILT) tsob=tso(1) ENDIF !---- Final solution for TSO in sea ice @@ -4324,12 +4328,12 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ! blended or snow is melted DO K=3,NZS KK=NZS-K+1 - TSO(K)=min(271.4_kind_phys,rhtso(KK)+cotso(KK)*TSO(K-1)) + TSO(K)=min(con_tice,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO ELSE DO K=2,NZS KK=NZS-K+1 - TSO(K)=min(271.4_kind_phys,rhtso(KK)+cotso(KK)*TSO(K-1)) + TSO(K)=min(con_tice,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO ENDIF !--- For thin snow layer combined with the top soil layer @@ -4348,7 +4352,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & IF(SOILT>tfrz .AND. BETA==one .AND. SNHEI>zero) THEN ! nmelt = 1 - soiltfrac=snowfrac*tfrz+(1.-snowfrac)*min(271.4_kind_phys,SOILT) + soiltfrac=snowfrac*tfrz+(1.-snowfrac)*min(con_tice,SOILT) QSG= QSN(soiltfrac,TBQ)/PP T3 = STBOLT*TNold*TNold*TNold @@ -4482,7 +4486,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & snwe rhosn=MIN(MAX(58.8_kind_phys,XSN),500._kind_phys) - RHOCSN=2090._kind_phys* RHOSN + RHOCSN=sheatsn* RHOSN if(isncond_opt == 1) then if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically @@ -4726,12 +4730,12 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon real (kind_phys), INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & EMISS, & RHO, & @@ -4744,17 +4748,17 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & TKMS !--- soil properties - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & BCLH, & DQM, & QMIN - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & soilres,alfa - real (kind_phys), INTENT(IN ) :: CP, & + real (kind_phys), INTENT(IN ) :: CP, & CVW, & XLV, & STBOLT, & @@ -4762,23 +4766,23 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & G0_P - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & THDIF, & CAP - real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO !-------- 2-d variables - real (kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: & MAVAIL, & QVG, & @@ -4789,12 +4793,12 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & !--- Local variables - real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph , & + real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph , & tn,trans,umveg,denom,fex real (kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & - PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & - TDENOM + PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & + TDENOM real (kind_phys) :: C,CC,AA1,RHCS,H1, QGOLD @@ -4814,13 +4818,13 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & qgold=qvg do k=1,nzs - cotso(k)=0. - rhtso(k)=0. + cotso(k)=zero + rhtso(k)=zero enddo !****************************************************************************** ! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO !****************************************************************************** - cotso(1)=0. + cotso(1)=zero rhtso(1)=TSO(NZS) DO 33 K=1,NZS2 KN=NZS-K @@ -4851,13 +4855,13 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & TN=SOILT D9=THDIF(1)*RHCS*dzstop D10=TKMS*CP*RHO - R211=.5*CONFLX/DELT + R211=.5_kind_phys*CONFLX/DELT R21=R211*CP*RHO - R22=.5/(THDIF(1)*DELT*dzstop**2) - R6=EMISS *STBOLT*.5*TN**4 + R22=.5_kind_phys/(THDIF(1)*DELT*dzstop**2) + R6=EMISS *STBOLT*.5_kind_phys*TN**4 R7=R6/TN D11=RNET+R6 - TDENOM=D9*(1.-D1+R22)+D10+R21+R7 & + TDENOM=D9*(one-D1+R22)+D10+R21+R7 & +RAINF*CVW*PRCPMS FKQ=QKMS*RHO R210=R211*RHO @@ -4867,14 +4871,14 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & BB=(D10*TABS+R21*TN+XLV*(QVATM* & (FKQ*UMVEG+C) & +R210*QVG)+D11+D9*(D2+R22*TN) & - +RAINF*CVW*PRCPMS*max(tfrz,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & )/TDENOM AA1=AA+CC - PP=PATM*1.E3 + PP=PATM*1.E3_kind_phys AA1=AA1/PP CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) TQ2=QVATM - TX2=TQ2*(1.-H) + TX2=TQ2*(one-H) Q1=TX2+H*QS1 IF (debug_print ) THEN print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 @@ -4885,7 +4889,7 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & 90 QVG=QS1 QSG=QS1 TSO(1)=TS1 - QCG=max(0.,Q1-QS1) + QCG=max(zero,Q1-QS1) IF (debug_print ) THEN print *,'90 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) ENDIF @@ -4909,7 +4913,7 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & ! QVG = QVATM ! endif TSO(1)=TS1 - QCG=0. + QCG=zero 200 CONTINUE IF (debug_print ) THEN print *,'200 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) @@ -4929,14 +4933,14 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) END DO - X= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) + & + X= (cp*rho*r211+rhcs*zsmain(2)*0.5_kind_phys/delt)*(SOILT-TN) + & XLV*rho*r211*(QVG-QGOLD) IF (debug_print ) THEN print*,'SOILTEMP storage, i,j,x,soilt,tn,qvg,qvgold', & i,j,x,soilt,tn,qvg,qgold print *,'TEMP term (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN)',& - (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) + (cp*rho*r211+rhcs*zsmain(2)*0.5_kind_phys/delt)*(SOILT-TN) print *,'QV term XLV*rho*r211*(QVG-QGOLD)',XLV*rho*r211*(QVG-QGOLD) ENDIF X=X & @@ -5029,7 +5033,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & testptlat,testptlon , & @@ -5037,12 +5041,12 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & real :: rhonewcsn !--- 3-D Atmospheric variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & RHO, & @@ -5052,14 +5056,14 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & TKMS !--- soil properties - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & BCLH, & DQM, & PSIS, & QMIN - real (kind_phys), INTENT(IN ) :: CP, & + real (kind_phys), INTENT(IN ) :: CP, & ROVCP, & CVW, & STBOLT, & @@ -5067,7 +5071,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & G0_P - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & THDIF, & CAP, & @@ -5080,12 +5084,12 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO !-------- 2-d variables - real (kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & CST, & RHOSN, & @@ -5107,7 +5111,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & real (kind_phys), INTENT(INOUT) :: DRYCAN, WETCAN - real (kind_phys), INTENT(OUT) :: RSM, & + real (kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & SNHEIPRINT INTEGER, INTENT(OUT) :: ilnb @@ -5116,16 +5120,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & INTEGER :: nzs1,nzs2,k,k1,kn,kk - real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph, & + real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph, & tn,trans,umveg,denom real (kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - real (kind_phys) :: t3,upflux,xinet,ras, & + real (kind_phys) :: t3,upflux,xinet,ras, & xlmelt,rhocsn,thdifsn, & beta,epot,xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn - real (kind_phys) :: fso,fsn, & + real (kind_phys) :: fso,fsn, & FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2, & TDENOM,C,CC,AA1,RHCS,H1, & @@ -5134,7 +5138,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & CMC2MS,TNOLD,QGOLD,SNOHGNEW real (kind_phys), DIMENSION(1:NZS) :: transp,cotso,rhtso - real (kind_phys) :: edir1, & + real (kind_phys) :: edir1, & ec1, & ett1, & eeta, & @@ -5151,91 +5155,91 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- options for snow conductivity: !-- 1 - constant !-- opt 2 - Sturm et al., 1997 - keff = 0.265 + keff = 0.265_kind_phys do k=1,nzs - transp (k)=0. - cotso (k)=0. - rhtso (k)=0. + transp (k)=zero + cotso (k)=zero + rhtso (k)=zero enddo IF (debug_print ) THEN print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt ENDIF - XLMELT=3.35E+5 - RHOCSN=2090.* RHOSN - RHOnewCSN=2090.* RHOnewSN + XLMELT=con_hfus + RHOCSN=sheatsn* RHOSN + RHOnewCSN=sheatsn* RHOnewSN if(isncond_opt == 1) then - if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN endif else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) - fact = 1. - if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then - keff = 0.023 + 0.234 * rhosn * 1.e-3 + fact = one + if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then + keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5. + fact = 5._kind_phys else - keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 - fact = 2. + keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys + fact = 2._kind_phys if(debug_print) then print *,'SnowTemp xlat,xlon,rhosn,keff', xlat,xlon,rhosn,keff,keff/rhocsn*fact - print *,'SNOWTEMP - 0.265/rhocsn',0.265/rhocsn + print *,'SNOWTEMP - 0.265/rhocsn',0.265_kind_phys/rhocsn endif endif if ( debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then print *,'SNOWTEMP - xlat,xlon,newsnow,rhonewsn,rhosn,fact,keff',xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff endif - if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else thdifsn = keff/rhocsn * fact endif if (debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then print *,'SNOWTEMP - thdifsn',xlat,xlon,thdifsn - print *,'SNOWTEMP - 0.265/rhocsn',0.265/rhocsn + print *,'SNOWTEMP - 0.265/rhocsn',0.265_kind_phys/rhocsn endif endif - RAS=RHO*1.E-3 + RAS=RHO*1.E-3_kind_phys SOILTFRAC=SOILT - SMELT=0. - SOH=0. - SMELTG=0. - SNOHG=0. - SNODIF=0. - RSM = 0. - RSMFRAC = 0. - fsn=1. - fso=0. + SMELT=zero + SOH=zero + SMELTG=zero + SNOHG=zero + SNODIF=zero + RSM = zero + RSMFRAC = zero + fsn=one + fso=zero NZS1=NZS-1 NZS2=NZS-2 QGOLD=QVG - DZSTOP=1./(ZSMAIN(2)-ZSMAIN(1)) + DZSTOP=one/(ZSMAIN(2)-ZSMAIN(1)) !****************************************************************************** ! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO !****************************************************************************** - cotso(1)=0. + cotso(1)=zero rhtso(1)=TSO(NZS) DO 33 K=1,NZS2 KN=NZS-K @@ -5260,20 +5264,19 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & snprim=max(snth,snhei) tsob=tso(1) soilt1=tso(1) - XSN = DELT/2./(zshalf(2)+0.5*SNPRIM) + XSN = DELT/2._kind_phys/(zshalf(2)+0.5_kind_phys*SNPRIM) DDZSN = XSN / SNPRIM X1SN = DDZSN * thdifsn X2 = DTDZS(1)*THDIF(1) FT = TSO(1)+X1SN*(SOILT-TSO(1)) & -X2*(TSO(1)-TSO(2)) - DENOM = 1. + X1SN + X2 -X2*cotso(NZS1) + DENOM = one + X1SN + X2 -X2*cotso(NZS1) cotso(NZS)=X1SN/DENOM rhtso(NZS)=(FT+X2*rhtso(NZS1))/DENOM cotsn=cotso(NZS) rhtsn=rhtso(NZS) !*** Average temperature of snow pack (C) - tsnav=min(0.,0.5*(soilt+tso(1)) & - -tfrz) + tsnav=min(zero,0.5_kind_phys*(soilt+tso(1))-tfrz) else !-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth @@ -5283,8 +5286,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ilnb=2 snprim=deltsn tsob=soilt1 - XSN = DELT/2./(0.5*deltsn) - XSN1= DELT/2./(zshalf(2)+0.5*(SNHEI-DELTSN)) + XSN = DELT/2._kind_phys/(0.5_kind_phys*deltsn) + XSN1= DELT/2._kind_phys/(zshalf(2)+0.5_kind_phys*(SNHEI-DELTSN)) DDZSN = XSN / DELTSN DDZSN1 = XSN1 / (SNHEI-DELTSN) X1SN = DDZSN * thdifsn @@ -5297,33 +5300,33 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom ftsnow = soilt1+x1sn*(soilt-soilt1) & -x1sn1*(soilt1-tso(1)) - denomsn = 1. + X1SN + X1SN1 - X1SN1*cotso(NZS) + denomsn = one + X1SN + X1SN1 - X1SN1*cotso(NZS) cotsn=x1sn/denomsn rhtsn=(ftsnow+X1SN1*rhtso(NZS))/denomsn !*** Average temperature of snow pack (C) - tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & + tsnav=min(zero,0.5_kind_phys/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & -tfrz) endif ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + IF(SNHEI.LT.SNTH.AND.SNHEI.GT.zero) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first soil layer. snprim=SNHEI+zsmain(2) fsn=SNHEI/snprim - fso=1.-fsn + fso=one-fsn soilt1=tso(1) tsob=tso(2) - XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) + XSN = DELT/2._kind_phys/((zshalf(3)-zsmain(2))+0.5_kind_phys*snprim) DDZSN = XSN /snprim X1SN = DDZSN * (fsn*thdifsn+fso*thdif(1)) X2=DTDZS(2)*THDIF(2) FT=TSO(2)+X1SN*(SOILT-TSO(2))- & X2*(TSO(2)-TSO(3)) - denom = 1. + x1sn + x2 - x2*cotso(nzs-2) + denom = one + x1sn + x2 - x2*cotso(nzs-2) cotso(nzs1) = x1sn/denom rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom - tsnav=min(0.,0.5*(soilt+tso(1)) & + tsnav=min(zero,0.5_kind_phys*(soilt+tso(1)) & -tfrz) cotso(NZS)=cotso(nzs1) rhtso(NZS)=rhtso(nzs1) @@ -5336,25 +5339,25 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !--- THE HEAT BALANCE EQUATION (Smirnova et al. 1996, EQ. 21,26) !18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes nmelt=0 - SNOH=0. + SNOH=zero - ETT1=0. + ETT1=zero EPOT=-QKMS*(QVATM-QGOLD) RHCS=CAP(1) H=MAVAIL !1. TRANS=TRANSUM*DRYCAN/ZSHALF(NROOT+1) CAN=WETCAN+TRANS - UMVEG=1.-VEGFRAC + UMVEG=one-VEGFRAC FKT=TKMS D1=cotso(NZS1) D2=rhtso(NZS1) TN=SOILT D9=THDIF(1)*RHCS*dzstop D10=TKMS*CP*RHO - R211=.5*CONFLX/DELT + R211=.5_kind_phys*CONFLX/DELT R21=R211*CP*RHO - R22=.5/(THDIF(1)*DELT*dzstop**2) - R6=EMISS *STBOLT*.5*TN**4 + R22=.5_kind_phys/(THDIF(1)*DELT*dzstop**2) + R6=EMISS *STBOLT*.5_kind_phys*TN**4 R7=R6/TN D11=RNET+R6 @@ -5375,25 +5378,25 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ENDIF endif D9SN= THDIFSN*RHOCSN / SNPRIM - R22SN = SNPRIM*SNPRIM*0.5/(THDIFSN*DELT) + R22SN = SNPRIM*SNPRIM*0.5_kind_phys/(THDIFSN*DELT) IF (debug_print ) THEN print *,'1 or 2 layers D9sn,R22sn',d9sn,r22sn ENDIF ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + IF(SNHEI.LT.SNTH.AND.SNHEI.GT.zero) then !--- thin snow is combined with soil D1SN = D1 D2SN = D2 D9SN = (fsn*THDIFSN*RHOCSN+fso*THDIF(1)*RHCS)/ & snprim - R22SN = snprim*snprim*0.5 & + R22SN = snprim*snprim*0.5_kind_phys & /((fsn*THDIFSN+fso*THDIF(1))*delt) IF (debug_print ) THEN print *,' Combined D9SN,R22SN,D1SN,D2SN: ',D9SN,R22SN,D1SN,D2SN ENDIF ENDIF - IF(SNHEI.eq.0.)then + IF(SNHEI.eq.zero)then !--- all snow is sublimated D9SN = D9 R22SN = R22 @@ -5410,7 +5413,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & 212 continue !---- TDENOM for snow - TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7 & + TDENOM = D9SN*(one-D1SN +R22SN)+D10+R21+R7 & +RAINF*CVW*PRCPMS & +RHOnewCSN*NEWSNOW/DELT @@ -5422,11 +5425,11 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & BB=(D10*TABS+R21*TN+XLVM*(QVATM* & (BETA*FKQ*UMVEG+C) & +R210*QGOLD)+D11+D9SN*(D2SN+R22SN*TN) & - +RAINF*CVW*PRCPMS*max(tfrz,TABS) & - + RHOnewCSN*NEWSNOW/DELT*min(tfrz,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & + + RHOnewCSN*NEWSNOW/DELT*min(tfrz,TABS) & )/TDENOM AA1=AA+CC - PP=PATM*1.E3 + PP=PATM*1.E3_kind_phys AA1=AA1/PP BB=BB-SNOH/TDENOM @@ -5438,7 +5441,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ENDIF CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) TQ2=QVATM - TX2=TQ2*(1.-H) + TX2=TQ2*(one-H) Q1=TX2+H*QS1 IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then @@ -5449,7 +5452,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !--- if saturation - goto 90 90 QVG=QS1 QSG=QS1 - QCG=max(0.,Q1-QS1) + QCG=max(zero,Q1-QS1) IF (debug_print ) THEN print *,'90 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) ENDIF @@ -5465,33 +5468,15 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & IF(Q1.GT.QS1) GOTO 90 QSG=QS1 QVG=Q1 - QCG=0. + QCG=zero IF (debug_print ) THEN print *,'No Saturation QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) ENDIF 200 CONTINUE -if(1==2) then - if(qvatm > QSG .and. iter==0) then -!condensation regime - IF (debug_print ) THEN - print *,'SNOW turn off canopy evaporation and transpiration' - print *,' QVATM,QVG,QSG,TS1',QVATM,QVG,QSG,TS1 - print *,'before can, umveg ',can, umveg - ENDIF - iter=1 - endif - - IF (debug_print ) THEN - if(iter==1) then - print *,'SNOW - QVATM,QVG,QSG,QCG,TS1',QVATM,QVG,QSG,QCG,TS1 - endif - ENDIF -endif ! 1==2 - !--- SOILT - skin temperature SOILT=TS1 - if(nmelt==1 .and. snowfrac==1 .and. snwe > 0. .and. SOILT > tfrz) then + if(nmelt==1 .and. snowfrac==one .and. snwe > zero .and. SOILT > tfrz) then !--7feb22 on the second iteration when SNOH is known and snwe > 0. after melting, !-- check if the snow skin temperature is = 0. .and. SNHEI < SNTH) THEN + ELSEIF (SNHEI > zero .and. SNHEI < SNTH) THEN ! blended TSO(2)=rhtso(NZS1)+cotso(NZS1)*SOILT tso(1)=(tso(2)+(soilt-tso(2))*fso) @@ -5533,7 +5518,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & SOILT1=SOILT tsob=TSO(1) ENDIF - if(nmelt==1.and.snowfrac==1) then + if(nmelt==1.and.snowfrac==one) then !-- second iteration with full snow cover SOILT1= min(tfrz,SOILT1) TSO(1)= min(tfrz,TSO(1)) @@ -5541,7 +5526,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & endif !---- Final solution for TSO - IF (SNHEI > 0. .and. SNHEI < SNTH) THEN + IF (SNHEI > zero .and. SNHEI < SNTH) THEN ! blended or snow is melted DO K=3,NZS KK=NZS-K+1 @@ -5574,7 +5559,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !--- IF SOILT > tfrz F then melting of snow can happen ! if all snow can evaporate (beta<1), then there is nothing to melt - IF(SOILT.GT.tfrz.AND.BETA.EQ.1.AND.SNHEI.GT.0.) THEN + IF(SOILT > tfrz.AND.BETA==one.AND.SNHEI>zero) THEN !-- snow sublimation and melting nmelt = 1 soiltfrac=snowfrac*tfrz+(one-snowfrac)*SOILT @@ -5610,7 +5595,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & EDIR1 = Q1*UMVEG * BETA EC1 = Q1 * WETCAN * vegfrac CMC2MS=CST/DELT*RAS - EETA = (EDIR1 + EC1 + ETT1)*1.E3 + EETA = (EDIR1 + EC1 + ETT1)*rhowater ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ QFX= XLVM * EETA ENDIF @@ -5641,17 +5626,17 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & +RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac) SNOH=AMAX1(0.,SNOH) !-- SMELT is speed of melting in M/S - SMELT= SNOH /XLMELT*1.E-3 + SMELT= SNOH /XLMELT*1.E-3_kind_phys IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'1- SMELT',smelt,snoh,xlat,xlon ENDIF - IF(EPOT.gt.0. .and. SNWEPR.LE.EPOT*RAS*DELT) THEN + IF(EPOT.gt.zero .and. SNWEPR.LE.EPOT*RAS*DELT) THEN !-- all snow can evaporate BETA=SNWEPR/(EPOT*RAS*DELT) - SMELT=AMAX1(0.,AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS)) - SNWE=0. + SMELT=AMAX1(zero,AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS)) + SNWE=zero IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'2- SMELT',xlat,xlon,snwe,smelt,rhonewsn,xlat,xlon @@ -5662,8 +5647,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !18apr08 - Egglston limit !-- 22apr22 Do not limit snow melting for hail (rhonewsn > 450), or dense snow !-- (rhosn > 350.) with very warm surface temperatures (>10C) - if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then - SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*max(1.,(soilt-tfrz))) + if( (rhosn < 350._kind_phys .or. (newsnow > zero .and. rhonewsn < 450._kind_phys)) .and. soilt < 283._kind_phys ) then + SMELT= amin1 (smelt, delt/60._kind_phys*5.6E-8_kind_phys*meltfactor*max(one,(soilt-tfrz))) IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'3- SMELT',xlat,xlon,smelt,rhosn,rhonewsn,xlat,xlon @@ -5671,18 +5656,18 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & endif ! rr - potential melting - rr=max(0.,SNWEPR/delt-BETA*EPOT*RAS) + rr=max(zero,SNWEPR/delt-BETA*EPOT*RAS) if(smelt > rr) then SMELT = min(SMELT,rr) - SNWE = 0. + SNWE = zero IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'4- SMELT i,j,smelt,rr',xlat,xlon,smelt,rr ENDIF endif 88 continue - SNOHGNEW=SMELT*XLMELT*1.E3 - SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) + SNOHGNEW=SMELT*XLMELT*rhowater + SNODIF=AMAX1(zero,(SNOH-SNOHGNEW)) SNOH=SNOHGNEW IF (debug_print ) THEN @@ -5691,19 +5676,19 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,' xlat, xlon', xlat, xlon ENDIF - IF( smelt > 0.) then + IF( smelt > zero) then !*** From Koren et al. (1999) 13% of snow melt stays in the snow pack - rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) - if(snhei > 0.01 .and. rhosn < 350.) then + rsmfrac=min(0.18_kind_phys,(max(0.08_kind_phys,snwepr/0.10_kind_phys*0.13_kind_phys))) + if(snhei > 0.01_kind_phys .and. rhosn < 350._kind_phys) then rsm=min(snwe,rsmfrac*smelt*delt) else ! do not keep melted water if snow depth is less that 1 cm ! or if snow is dense - rsm=0. + rsm=zero endif !18apr08 rsm is part of melted water that stays in snow as liquid - if(rsm > 0.) then - SMELT=max(0.,SMELT-rsm/delt) + if(rsm > zero) then + SMELT=max(zero,SMELT-rsm/delt) IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & @@ -5716,8 +5701,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- update of liquid equivalent of snow depth !-- due to evaporation and snow melt - if(snwe > 0.) then - SNWE = AMAX1(0.,(SNWEPR- & + if(snwe > zero) then + SNWE = AMAX1(zero,(SNWEPR- & (SMELT+BETA*EPOT*RAS)*DELT & ) ) IF (debug_print ) THEN @@ -5735,13 +5720,13 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- NO MELTING, only sublimation !--- If there is no snow melting then just evaporation !--- or condensation changes SNWE - if(snhei.ne.0..and. beta == 1.) then + if(snhei.ne.zero .and. beta == one) then EPOT=-QKMS*(QVATM-QSG) - SNWE = AMAX1(0.,(SNWEPR- & + SNWE = AMAX1(zero,(SNWEPR- & BETA*EPOT*RAS*DELT)) else !-- all snow is sublibated - snwe = 0. + snwe = zero endif ENDIF @@ -5751,7 +5736,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & if(nmelt.eq.1) goto 212 ! second interation 220 continue - if(smelt.gt.0..and.rsm.gt.0.) then + if(smelt > zero .and. rsm > zero) then if(snwe.le.rsm) then IF ( debug_print ) THEN print *,'SNWE 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN endif else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) - fact = 1. - if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then - keff = 0.023 + 0.234 * rhosn * 1.e-3 + fact = one + if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then + keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5. + fact = 5._kind_phys else - keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 - fact = 2. + keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys + fact = 2._kind_phys if(debug_print) then print *,'End SNOWTEMP - xlat,xlon,rhosn,keff',xlat,xlon,rhosn,keff print *,'End SNOWTEMP - 0.265/rhocsn',0.265/rhocsn @@ -5799,12 +5784,12 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff,keff/rhocsn*fact endif - if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -5822,7 +5807,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & S=thdifsn*RHOCSN*(soilt-TSOB)/SNPRIM SNFLX=S S=D9*(tso(1)-tso(2)) - ELSEIF(SNHEI.lt.SNTH.and.SNHEI.GT.0.) then + ELSEIF(SNHEI.lt.SNTH.and.SNHEI.GT.zero) then S=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)* & (soilt-TSOB)/snprim SNFLX=S @@ -5834,7 +5819,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ENDIF !-- Update snow depth after melting at the interface with the atmosphere - SNHEI=SNWE *1.E3 / RHOSN + SNHEI=SNWE * rhowater / RHOSN !-- If ground surface temperature !-- is above freezing snow can melt from the bottom at the interface with soild. The following @@ -5845,7 +5830,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,'snhei,snwe,rhosn,snowfr',snhei,snwe,rhosn,snowfrac,xlat,xlon endif - IF(TSO(1).GT.tfrz .and. snhei > 0.) THEN + IF(TSO(1).GT.tfrz .and. snhei > zero) THEN !-- melting at the soil/snow interface if (snhei.GT.deltsn+snth) then hsn = snhei - deltsn @@ -5859,41 +5844,41 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & hsn = snhei endif - soiltfrac=snowfrac*tfrz+(1.-snowfrac)*TSO(1) + soiltfrac=snowfrac*tfrz+(one-snowfrac)*TSO(1) SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & - RHOCSN*0.5*hsn) / DELT - SNOHG=AMAX1(0.,SNOHG) - SNODIF=0. - SMELTG=SNOHG/XLMELT*1.E-3 + RHOCSN*0.5_kind_phys*hsn) / DELT + SNOHG=AMAX1(zero,SNOHG) + SNODIF=zero + SMELTG=SNOHG/XLMELT*1.E-3_kind_phys IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,' SMELTG =',smeltg,xlat,xlon endif ! Egglston - empirical limit on snow melt from the bottom of snow pack !9jun22-- the next line excludeis cases of summer hail from snowmelt limiting - if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then - SMELT=AMIN1(SMELTG, 5.8e-9) + if( (rhosn < 350._kind_phys .or. (newsnow > zero .and. rhonewsn < 450._kind_phys)) .and. soilt < 283._kind_phys ) then + SMELT=AMIN1(SMELTG, 5.8e-9_kind_phys) endif ! rr - potential melting rr=SNWE/delt SMELTG=AMIN1(SMELTG, rr) - SNOHGNEW=SMELTG*XLMELT*1.e3 - SNODIF=AMAX1(0.,(SNOHG-SNOHGNEW)) + SNOHGNEW=SMELTG*XLMELT*rhowater + SNODIF=AMAX1(zero,(SNOHG-SNOHGNEW)) IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',TSO(1),soiltfrac,snowfrac,smeltg,SNODIF print *,' xlat, xlon', xlat, xlon ENDIF - snwe=max(0.,snwe-smeltg*delt) - SNHEI=SNWE *1.E3 / RHOSN + snwe=max(zero,snwe-smeltg*delt) + SNHEI=SNWE * rhowater / RHOSN !-- add up all snow melt SMELT = SMELT + SMELTG - if(snhei > 0.) TSO(1) = soiltfrac + if(snhei > zero) TSO(1) = soiltfrac IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then @@ -5902,14 +5887,14 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',TSO(1),soiltfrac,snowfrac,smeltg,SNODIF print *,'Melt from the bottom snwe,snhei,snoh',snwe,snhei,snoh print *,' Final TSO ',tso - if (snhei==0.) & + if (snhei==zero) & print *,'Snow is all melted on the warm ground' ENDIF ENDIF ! melt on snow/soil interface snweprint=snwe - snheiprint=snweprint*1.E3 / RHOSN + snheiprint=snweprint*rhowater / RHOSN X= (R21+D9SN*R22SN)*(soilt-TN) + & XLVM*R210*(QSG-QGOLD) @@ -5923,7 +5908,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & X=X & ! "heat" from snow and rain - -RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-SOILT) & + -RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-SOILT) & -RAINF*CVW*PRCPMS*(max(tfrz,TABS)-SOILT) IF (debug_print ) THEN print *,'x=',x @@ -5931,16 +5916,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,'SNFLX=',snflx ENDIF - IF(SNHEI.GT.0.) THEN + IF(SNHEI.GT.zero) THEN if(ilnb.gt.1) then - tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & - +(soilt1+tso(1))*(SNHEI-DELTSN)) & + tsnav=min(zero,0.5_kind_phys/snhei*((soilt+soilt1)*deltsn & + +(soilt1+tso(1))*(SNHEI-DELTSN)) & -tfrz) else - tsnav=min(0.,0.5*(soilt+tso(1)) - tfrz) + tsnav=min(zero,0.5_kind_phys*(soilt+tso(1)) - tfrz) endif ELSE - tsnav= min(0.,soilt - tfrz) + tsnav= min(zero,soilt - tfrz) ENDIF !------------------------------------------------------------------------ @@ -6008,7 +5993,7 @@ SUBROUTINE SOILMOIST ( debug_print, & ! input variables - real (kind_phys), DIMENSION(1:NZS), INTENT(IN ) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DIFFU, & HYDRO, & @@ -6018,18 +6003,17 @@ SUBROUTINE SOILMOIST ( debug_print, & real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind_phys), INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM, & + real (kind_phys), INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM, & QKMS,VEGFRAC,DRIP,PRCP , & DEW,SMELT,SNOWFRAC , & DQM,QMIN,REF,KSAT,RAS,RIW,SOILRES ! output - real (kind_phys), DIMENSION( 1:nzs ) , & - - INTENT(INOUT) :: SOILMOIS,SOILIQW - - real (kind_phys), INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & + real (kind_phys), DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: SOILMOIS,SOILIQW + + real (kind_phys), INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & INFMAX ! local variables @@ -6055,16 +6039,16 @@ SUBROUTINE SOILMOIST ( debug_print, & 118 format(6(10Pf23.19)) do k=1,nzs - cosmc(k)=0. - rhsmc(k)=0. + cosmc(k)=zero + rhsmc(k)=zero enddo DID=(ZSMAIN(NZS)-ZSHALF(NZS)) X1=ZSMAIN(NZS)-ZSMAIN(NZS1) - DENOM=(1.+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/(2.*DID)*DELT) - COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & - +HYDRO(NZS1)/2./DID)/DENOM + DENOM=(one+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/(2._kind_phys*DID)*DELT) + COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & + +HYDRO(NZS1)/2._kind_phys/DID)/DENOM RHSMC(1)=(SOILMOIS(NZS)+TRANSP(NZS)*DELT/ & DID)/DENOM @@ -6073,13 +6057,13 @@ SUBROUTINE SOILMOIST ( debug_print, & ! So far - no interaction with the water table. DENOM=1.+DIFFU(nzs1)/X1/DID*DELT - COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & + COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & +HYDRO(NZS1)/DID)/DENOM - RHSMC(1)=(SOILMOIS(NZS)-HYDRO(NZS)*DELT/DID*soilmois(nzs) & + RHSMC(1)=(SOILMOIS(NZS)-HYDRO(NZS)*DELT/DID*soilmois(nzs) & +TRANSP(NZS)*DELT/DID)/DENOM - COSMC(1)=0. + COSMC(1)=zero RHSMC(1)=SOILMOIS(NZS) ! DO K=1,NZS2 @@ -6089,7 +6073,7 @@ SUBROUTINE SOILMOIST ( debug_print, & X2=2.*DTDZS(K1+1)*DIFFU(KN) Q4=X4+HYDRO(KN-1)*DTDZS2(KN-1) Q2=X2-HYDRO(KN+1)*DTDZS2(KN-1) - DENOM=1.+X2+X4-Q2*COSMC(K) + DENOM=one+X2+X4-Q2*COSMC(K) COSMC(K+1)=Q4/DENOM IF (debug_print ) THEN print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' & @@ -6104,16 +6088,16 @@ SUBROUTINE SOILMOIST ( debug_print, & ! --- MOISTURE BALANCE BEGINS HERE TRANS=TRANSP(1) - UMVEG=(1.-VEGFRAC)*soilres + UMVEG=(one-VEGFRAC)*soilres - RUNOFF=0. - RUNOFF2=0. + RUNOFF=zero + RUNOFF2=zero DZS=ZSMAIN(2) R1=COSMC(NZS1) R2= RHSMC(NZS1) R3=DIFFU(1)/DZS - R4=R3+HYDRO(1)*.5 - R5=R3-HYDRO(2)*.5 + R4=R3+HYDRO(1)*.5_kind_phys + R5=R3-HYDRO(2)*.5_kind_phys R6=QKMS*RAS !-- Total liquid water available on the top of soil domain !-- Without snow - 3 sources of water: precipitation, @@ -6122,7 +6106,7 @@ SUBROUTINE SOILMOIST ( debug_print, & 191 format (f23.19) - TOTLIQ=PRCP-DRIP/DELT-(1.-VEGFRAC)*DEW*RAS-SMELT + TOTLIQ=PRCP-DRIP/DELT-(one-VEGFRAC)*DEW*RAS-SMELT IF (debug_print ) THEN print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT @@ -6140,32 +6124,32 @@ SUBROUTINE SOILMOIST ( debug_print, & ! THAT IS WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}) ! ! Current logic doesn't allow CVFRZ be bigger than 3 - CVFRZ = 3. + CVFRZ = 3._kind_phys !-- SCHAAKE/KOREN EXPRESSION for calculation of max infiltration - REFKDT=3. - REFDK=3.4341E-6 - DELT1=DELT/86400. + REFKDT=3._kind_phys + REFDK=3.4341E-6_kind_phys + DELT1=DELT/86400._kind_phys F1MAX=DQM*ZSHALF(2) F2MAX=DQM*(ZSHALF(3)-ZSHALF(2)) - F1=F1MAX*(1.-SOILMOIS(1)/DQM) + F1=F1MAX*(one-SOILMOIS(1)/DQM) DICE=SOILICE(1)*ZSHALF(2) FD=F1 do k=2,nzs1 DICE=DICE+(ZSHALF(k+1)-ZSHALF(k))*SOILICE(K) FKMAX=DQM*(ZSHALF(k+1)-ZSHALF(k)) - FK=FKMAX*(1.-SOILMOIS(k)/DQM) + FK=FKMAX*(one-SOILMOIS(k)/DQM) FD=FD+FK enddo KDT=REFKDT*KSAT/REFDK VAL=(1.-EXP(-KDT*DELT1)) DDT = FD*VAL PX= - TOTLIQ * DELT - IF(PX.LT.0.0) PX = 0.0 - IF(PX.gt.0.0) THEN + IF(PX < zero) PX = zero + IF(PX > zero) THEN INFMAX1 = (PX*(DDT/(PX+DDT)))/DELT ELSE - INFMAX1 = 0. + INFMAX1 = zero ENDIF IF (debug_print ) THEN print *,'INFMAX1 before frozen part',INFMAX1 @@ -6176,11 +6160,12 @@ SUBROUTINE SOILMOIST ( debug_print, & ! ! ------------------------------------------------------------------ - FRZX= 0.15*((dqm+qmin)/ref) * (0.412 / 0.468) - FCR = 1. - IF ( DICE .GT. 1.E-2) THEN + FRZX= 0.15_kind_phys*((dqm+qmin)/ref) * (0.412_kind_phys / 0.468_kind_phys) + + FCR = one + IF ( DICE .GT. 1.E-2_kind_phys) THEN ACRT = CVFRZ * FRZX / DICE - SUM = 1. + SUM = one IALP1 = CVFRZ - 1 DO JK = 1,IALP1 K = 1 @@ -6189,7 +6174,7 @@ SUBROUTINE SOILMOIST ( debug_print, & END DO SUM = SUM + (ACRT ** ( CVFRZ-JK)) / FLOAT (K) END DO - FCR = 1. - EXP(-ACRT) * SUM + FCR = one - EXP(-ACRT) * SUM END IF IF (debug_print ) THEN print *,'FCR--------',fcr @@ -6215,18 +6200,18 @@ SUBROUTINE SOILMOIST ( debug_print, & ! INFILTRP is total infiltration flux in M/S INFILTRP=FLX ! Solution of moisture budget - R7=.5*DZS/DELT + R7=.5_kind_phys*DZS/DELT R4=R4+R7 FLX=FLX-SOILMOIS(1)*R7 ! R8 is for direct evaporation from soil, which occurs ! only from snow-free areas - R8=UMVEG*R6*(1.-snowfrac) + R8=UMVEG*R6*(one-snowfrac) QTOT=QVATM+QCATM R9=TRANS R10=QTOT-QSG !-- evaporation regime - IF(R10.LE.0.) THEN + IF(R10.LE.zero) THEN QQ=(R5*R2-FLX+R9)/(R4-R5*R1-R10*R8/(REF-QMIN)) FLXSAT=-DQM*(R4-R5*R1-R10*R8/(REF-QMIN)) & +R5*R2+R9 @@ -6238,7 +6223,7 @@ SUBROUTINE SOILMOIST ( debug_print, & IF(QQ.LT.0.) THEN ! print *,'negative QQ=',qq - SOILMOIS(1)=1.e-8 + SOILMOIS(1)=1.e-8_kind_phys ELSE IF(QQ.GT.DQM) THEN !-- saturation @@ -6248,7 +6233,7 @@ SUBROUTINE SOILMOIST ( debug_print, & ENDIF RUNOFF=RUNOFF+(FLXSAT-FLX) ELSE - SOILMOIS(1)=min(dqm,max(1.e-8,QQ)) + SOILMOIS(1)=min(dqm,max(1.e-8_kind_phys,QQ)) END IF IF (debug_print ) THEN @@ -6261,7 +6246,7 @@ SUBROUTINE SOILMOIST ( debug_print, & KK=NZS-K+1 QQ=COSMC(KK)*SOILMOIS(K-1)+RHSMC(KK) - IF (QQ.LT.0.) THEN + IF (QQ.LT.zero) THEN ELSE IF(QQ.GT.DQM) THEN !-- saturation @@ -6275,14 +6260,14 @@ SUBROUTINE SOILMOIST ( debug_print, & RUNOFF2=RUNOFF2+((QQ-DQM)*(ZSHALF(K+1)-ZSHALF(K)))/DELT ENDIF ELSE - SOILMOIS(K)=min(dqm,max(1.e-8,QQ)) + SOILMOIS(K)=min(dqm,max(1.e-8_kind_phys,QQ)) END IF END DO IF (debug_print ) THEN print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw ENDIF - MAVAIL=max(.00001,min(1.,(SOILMOIS(1)/(REF-QMIN)*(1.-snowfrac)+1.*snowfrac))) + MAVAIL=max(.00001_kind_phys,min(one,(SOILMOIS(1)/(REF-QMIN)*(one-snowfrac)+one*snowfrac))) !------------------------------------------------------------------- END SUBROUTINE SOILMOIST !------------------------------------------------------------------- @@ -6324,7 +6309,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- soil properties LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: NZS - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -6333,12 +6318,12 @@ SUBROUTINE SOILPROP( debug_print, & QWRTZ, & QMIN - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(IN ) :: SOILMOIS, & keepfr - real (kind_phys), INTENT(IN ) :: CP, & + real (kind_phys), INTENT(IN ) :: CP, & CVW, & RIW, & kqwrtz, & @@ -6350,7 +6335,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- output variables - real (kind_phys), DIMENSION(1:NZS) , & + real (kind_phys), DIMENSION(1:NZS) , & INTENT(INOUT) :: cap,diffu,hydro , & thdif,tav , & soilmoism , & @@ -6372,66 +6357,66 @@ SUBROUTINE SOILPROP( debug_print, & nzs1=nzs-1 !-- Constants for Johansen (1975) thermal conductivity - kzero =2. ! if qwrtz > 0.2 + kzero =2._kind_phys ! if qwrtz > 0.2 do k=1,nzs - detal (k)=0. - kasat (k)=0. - kjpl (k)=0. - hk (k)=0. + detal (k)=zero + kasat (k)=zero + kjpl (k)=zero + hk (k)=zero enddo ws=dqm+qmin x1=xlmelt/(g0_p*psis) x2=x1/bclh*ws - x4=(bclh+1.)/bclh + x4=(bclh+one)/bclh !--- Next 3 lines are for Johansen thermal conduct. - gamd=(1.-ws)*2700. - kdry=(0.135*gamd+64.7)/(2700.-0.947*gamd) + gamd=(one-ws)*2700._kind_phys + kdry=(0.135_kind_phys*gamd+64.7_kind_phys)/(2700._kind_phys-0.947_kind_phys*gamd) !-- one more option from Christa's paper - if(qwrtz > 0.2) then + if(qwrtz > 0.2_kind_phys) then kas=kqwrtz**qwrtz*kzero**(1.-qwrtz) else - kas=kqwrtz**qwrtz*3.**(1.-qwrtz) + kas=kqwrtz**qwrtz*3._kind_phys**(one-qwrtz) endif DO K=1,NZS1 tn=tav(k) - tfrz wd=ws - riw*soilicem(k) - psif=psis*100.*(wd/(soiliqwm(k)+qmin))**bclh & - * (ws/wd)**3. + psif=psis*100._kind_phys*(wd/(soiliqwm(k)+qmin))**bclh & + * (ws/wd)**3._kind_phys !--- PSIF should be in [CM] to compute PF pf=log10(abs(psif)) - fact=1.+riw*soilicem(k) + fact=one+riw*soilicem(k) !--- HK is for McCumber thermal conductivity - IF(PF.LE.5.2) THEN - HK(K)=420.*EXP(-(PF+2.7))*fact + IF(PF.LE.5.2_kind_phys) THEN + HK(K)=420._kind_phys*EXP(-(PF+2.7_kind_phys))*fact ELSE - HK(K)=.1744*fact + HK(K)=.1744_kind_phys*fact END IF - IF(soilicem(k).NE.0.AND.TN.LT.0.) then + IF(soilicem(k).NE.zero.AND.TN.LT.zero) then !--- DETAL is taking care of energy spent on freezing or released from ! melting of soil water DETAL(K)=tfrz*X2/(TAV(K)*TAV(K))* & (TAV(K)/(X1*TN))**X4 - if(keepfr(k).eq.1.) then - detal(k)=0. + if(keepfr(k).eq.one) then + detal(k)=zero endif ENDIF !--- Next 10 lines calculate Johansen thermal conductivity KJPL - kasat(k)=kas**(1.-ws)*kice**fwsat(k) & + kasat(k)=kas**(one-ws)*kice**fwsat(k) & *kwt**lwsat(k) X5=(soilmoism(k)+qmin)/ws - if(soilicem(k).eq.0.) then - sr=max(0.101,x5) - ke=log10(sr)+1. + if(soilicem(k).eq.zero) then + sr=max(0.101_kind_phys,x5) + ke=log10(sr)+one else ke=x5 endif @@ -6439,25 +6424,25 @@ SUBROUTINE SOILPROP( debug_print, & kjpl(k)=ke*(kasat(k)-kdry)+kdry !--- CAP -volumetric heat capacity - CAP(K)=(1.-WS)*RHOCS & + CAP(K)=(one-WS)*RHOCS & + (soiliqwm(K)+qmin)*CVW & + soilicem(K)*CI & - + (dqm-soilmoism(k))*CP*1.2 & - - DETAL(K)*1.e3*xlmelt + + (dqm-soilmoism(k))*CP*1.2_kind_phys & + - DETAL(K)*rhowater*xlmelt a=RIW*soilicem(K) - if((ws-a).lt.0.12)then - diffu(K)=0. + if((ws-a).lt.0.12_kind_phys)then + diffu(K)=zero else - H=max(0.,(soilmoism(K)+qmin-a)/(max(1.e-8,(ws-a)))) - facd=1. - if(a.ne.0.)facd=1.-a/max(1.e-8,soilmoism(K)) - ame=max(1.e-8,ws-riw*soilicem(K)) + H=max(zero,(soilmoism(K)+qmin-a)/(max(1.e-8_kind_phys,(ws-a)))) + facd=one + if(a.ne.zero)facd=one-a/max(1.e-8_kind_phys,soilmoism(K)) + ame=max(1.e-8_kind_phys,ws-riw*soilicem(K)) !--- DIFFU is diffusional conductivity of soil water diffu(K)=-BCLH*KSAT*PSIS/ame* & - (ws/ame)**3. & - *H**(BCLH+2.)*facd + (ws/ame)**3._kind_phys & + *H**(BCLH+2._kind_phys)*facd endif !--- thdif - thermal diffusivity @@ -6472,19 +6457,19 @@ SUBROUTINE SOILPROP( debug_print, & ENDIF DO K=1,NZS - if((ws-riw*soilice(k)).lt.0.12)then - hydro(k)=0. + if((ws-riw*soilice(k)).lt.0.12_kind_phys)then + hydro(k)=zero else - fach=1. - if(soilice(k).ne.0.) & - fach=1.-riw*soilice(k)/max(1.e-8,soilmois(k)) - am=max(1.e-8,ws-riw*soilice(k)) + fach=one + if(soilice(k).ne.zero) & + fach=one-riw*soilice(k)/max(1.e-8_kind_phys,soilmois(k)) + am=max(1.e-8_kind_phys,ws-riw*soilice(k)) !--- HYDRO is hydraulic conductivity of soil water hydro(K)=min(KSAT,KSAT/am* & (soiliqw(K)/am) & - **(2.*BCLH+2.) & + **(2._kind_phys*BCLH+2._kind_phys) & * fach) - if(hydro(k)<1.e-10)hydro(k)=0. + if(hydro(k)<1.e-10_kind_phys)hydro(k)=zero endif ENDDO @@ -6521,22 +6506,22 @@ SUBROUTINE TRANSF( debug_print, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: nroot,nzs,iland - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GSWin, TABS, lai !--- soil properties - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: DQM, & QMIN, & REF, & PC, & WILT - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & - ZSHALF + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & + ZSHALF !-- output - real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: TRANF - real (kind_phys), INTENT(OUT) :: TRANSUM + real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: TRANF + real (kind_phys), INTENT(OUT) :: TRANSUM !-- local variables real (kind_phys) :: totliq, did @@ -6549,32 +6534,32 @@ SUBROUTINE TRANSF( debug_print, & !-------------------------------------------------------------------- do k=1,nzs - part(k)=0. - tranf(k)=0. + part(k)=zero + tranf(k)=zero enddo - transum=0. + transum=zero totliq=soiliqw(1)+qmin sm1=totliq sm2=sm1*sm1 sm3=sm2*sm1 sm4=sm3*sm1 - ap0=0.299 - ap1=-8.152 - ap2=61.653 - ap3=-115.876 - ap4=59.656 + ap0=0.299_kind_phys + ap1=-8.152_kind_phys + ap2=61.653_kind_phys + ap3=-115.876_kind_phys + ap4=59.656_kind_phys gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4 - if(totliq.ge.ref) gx=1. - if(totliq.le.0.) gx=0. - if(gx.gt.1.) gx=1. - if(gx.lt.0.) gx=0. + if(totliq.ge.ref) gx=one + if(totliq.le.zero) gx=zero + if(gx.gt.one) gx=one + if(gx.lt.zero) gx=zero DID=zshalf(2) part(1)=DID*gx IF(TOTLIQ.GT.REF) THEN TRANF(1)=DID ELSE IF(TOTLIQ.LE.WILT) THEN - TRANF(1)=0. + TRANF(1)=zero ELSE TRANF(1)=(TOTLIQ-WILT)/(REF-WILT)*DID ENDIF @@ -6588,16 +6573,16 @@ SUBROUTINE TRANSF( debug_print, & sm3=sm2*sm1 sm4=sm3*sm1 gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4 - if(totliq.ge.ref) gx=1. - if(totliq.le.0.) gx=0. - if(gx.gt.1.) gx=1. - if(gx.lt.0.) gx=0. + if(totliq.ge.ref) gx=one + if(totliq.le.zero) gx=zero + if(gx.gt.one) gx=one + if(gx.lt.zero) gx=zero DID=zshalf(K+1)-zshalf(K) part(k)=did*gx IF(totliq.GE.REF) THEN TRANF(K)=DID ELSE IF(totliq.LE.WILT) THEN - TRANF(K)=0. + TRANF(K)=zero ELSE TRANF(K)=(totliq-WILT) & /(REF-WILT)*DID @@ -6607,8 +6592,8 @@ SUBROUTINE TRANSF( debug_print, & END DO ! For LAI> 3 => transpiration at potential rate (F.Tardieu, 2013) - if(lai > 4.) then - pctot=0.8 + if(lai > 4._kind_phys) then + pctot=0.8_kind_phys else pctot=pc !- 26aug16- next 2 lines could lead to LH increase and higher 2-m Q during the day @@ -6621,22 +6606,22 @@ SUBROUTINE TRANSF( debug_print, & !--- !--- air temperature function ! Avissar (1985) and AX 7/95 - IF (TABS .LE. 302.15) THEN - FTEM = 1.0 / (1.0 + EXP(-0.41 * (TABS - 282.05))) + IF (TABS .LE. 302.15_kind_phys) THEN + FTEM = one / (one + EXP(-0.41_kind_phys * (TABS - 282.05_kind_phys))) ELSE - FTEM = 1.0 / (1.0 + EXP(0.5 * (TABS - 314.0))) + FTEM = one / (one + EXP(0.5_kind_phys * (TABS - 314.0_kind_phys))) ENDIF IF ( debug_print ) THEN print *,'tabs,ftem',tabs,ftem ENDIF !--- incoming solar function - cmin = 1./rsmax_data - cmax = 1./rstbl(iland) - if(lai > 1.) then + cmin = one/rsmax_data + cmax = one/rstbl(iland) + if(lai > one) then cmax = lai/rstbl(iland) ! max conductance endif ! Noihlan & Planton (1988) - f1=0. + f1=zero ! if(lai > 0.01) then ! f1 = 1.1/lai*gswin/rgltbl(iland)! f1=0. when GSWin=0. ! fsol = (f1+cmin/cmax)/(1.+f1) @@ -6647,9 +6632,9 @@ SUBROUTINE TRANSF( debug_print, & ! totcnd = max(lai/rstbl(iland), pctot * ftem * f1) ! Mahrer & Avissar (1982), Avissar et al. (1985) if (GSWin < rgltbl(iland)) then - fsol = 1. / (1. + exp(-0.034 * (GSWin - 3.5))) + fsol = one / (one + exp(-0.034_kind_phys * (GSWin - 3.5_kind_phys))) else - fsol = 1. + fsol = one endif IF ( debug_print ) THEN print *,'GSWin,lai,f1,fsol',gswin,lai,f1,fsol @@ -6663,7 +6648,7 @@ SUBROUTINE TRANSF( debug_print, & ENDIF !-- TRANSUM - total for the rooting zone - transum=0. + transum=zero DO K=1,NROOT ! linear root distribution TRANF(k)=max(cmin,TRANF(k)*totcnd) @@ -6695,20 +6680,20 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) real (kind_phys) :: F1,T1,T2,RN INTEGER :: I,I1 - I=(TN-1.7315E2)/.05+1 - T1=173.1+FLOAT(I)*.05 + I=(TN-1.7315E2_kind_dbl_prec)/.05_kind_dbl_prec+1 + T1=173.1_kind_dbl_prec+FLOAT(I)*.05_kind_dbl_prec F1=T1+D1*TT(I)-D2 - I1=I-F1/(.05+D1*(TT(I+1)-TT(I))) + I1=I-F1/(.05_kind_dbl_prec+D1*(TT(I+1)-TT(I))) I=I1 IF(I.GT.5000.OR.I.LT.1) GOTO 1 10 I1=I - T1=173.1+FLOAT(I)*.05 + T1=173.1_kind_dbl_prec+FLOAT(I)*.05_kind_dbl_prec F1=T1+D1*TT(I)-D2 - RN=F1/(.05+D1*(TT(I+1)-TT(I))) + RN=F1/(.05_kind_dbl_prec+D1*(TT(I+1)-TT(I))) I=I-INT(RN) IF(I.GT.5000.OR.I.LT.1) GOTO 1 IF(I1.NE.I) GOTO 10 - TS=T1-.05*RN + TS=T1-.05_kind_dbl_prec*RN QS=(TT(I)+(TT(I)-TT(I+1))*RN)/PP GOTO 20 1 PRINT *,' AVOST IN VILKA Table index= ',I @@ -6784,7 +6769,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & ! 19 White Sand ! !---------------------------------------------------------------------- - real (kind_phys) LQMA(nsoilclas),LRHC(nsoilclas), & + real (kind_phys) LQMA(nsoilclas),LRHC(nsoilclas), & LPSI(nsoilclas),LQMI(nsoilclas), & LBCL(nsoilclas),LKAS(nsoilclas), & LWIL(nsoilclas),LREF(nsoilclas), & @@ -6921,8 +6906,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & !---- Below are the arrays for the vegetation parameters - real (kind_phys) LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & - LROU(nvegclas),LTHI(nvegclas),LSIG(nvegclas), & + real (kind_phys) LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & + LROU(nvegclas),LTHI(nvegclas),LSIG(nvegclas), & LPC(nvegclas) !************************************************************************ @@ -6962,18 +6947,18 @@ SUBROUTINE SOILVEGIN ( debug_print, & real (kind_phys), DIMENSION( 1:NLCAT ), INTENT(IN):: LUFRAC real (kind_phys), DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC - real (kind_phys) , & + real (kind_phys) , & INTENT ( OUT) :: pc, & msnf, & facsnf - real (kind_phys) , & + real (kind_phys) , & INTENT (INOUT ) :: emiss, & lai, & znt LOGICAL, intent(in) :: rdlai2d !--- soil properties - real (kind_phys) , & + real (kind_phys) , & INTENT( OUT) :: RHOCS, & BCLH, & DQM, & @@ -7007,25 +6992,25 @@ SUBROUTINE SOILVEGIN ( debug_print, & ifortbl(ivgtyp),ivgtyp,laitbl(ivgtyp),z0tbl(ivgtyp) ENDIF - deltalai(:) = 0. + deltalai(:) = zero ! 11oct2012 - seasonal correction on ZNT for crops and LAI for all veg. types ! factor = 1 with minimum greenness --> vegfrac = shdmin (cold season) ! factor = 0 with maximum greenness --> vegfrac = shdmax ! SHDMAX, SHDMIN and VEGFRAC are in % here. - if((shdmax - shdmin) .lt. 1) then - factor = 1. ! min greenness + if((shdmax - shdmin) .lt. one) then + factor = one ! min greenness else - factor = 1. - max(0.,min(1.,(vegfrac - shdmin)/max(1.,(shdmax-shdmin)))) + factor = one - max(zero,min(one,(vegfrac - shdmin)/max(one,(shdmax-shdmin)))) endif ! 18sept18 - LAITBL and Z0TBL are the max values do k = 1,nlcat - if(IFORTBL(k) == 1) deltalai(k)=min(0.2,0.8*LAITBL(K)) - if(IFORTBL(k) == 2 .or. IFORTBL(k) == 7) deltalai(k)=min(0.5,0.8*LAITBL(K)) - if(IFORTBL(k) == 3) deltalai(k)=min(0.45,0.8*LAITBL(K)) - if(IFORTBL(k) == 4) deltalai(k)=min(0.75,0.8*LAITBL(K)) - if(IFORTBL(k) == 5) deltalai(k)=min(0.86,0.8*LAITBL(K)) + if(IFORTBL(k) == 1) deltalai(k)=min(0.2_kind_phys,0.8_kind_phys*LAITBL(K)) + if(IFORTBL(k) == 2 .or. IFORTBL(k) == 7) deltalai(k)=min(0.5_kind_phys,0.8_kind_phys*LAITBL(K)) + if(IFORTBL(k) == 3) deltalai(k)=min(0.45_kind_phys,0.8_kind_phys*LAITBL(K)) + if(IFORTBL(k) == 4) deltalai(k)=min(0.75_kind_phys,0.8_kind_phys*LAITBL(K)) + if(IFORTBL(k) == 5) deltalai(k)=min(0.86_kind_phys,0.8_kind_phys*LAITBL(K)) if(k.ne.iswater) then !-- 20aug18 - change in LAItoday based on the greenness fraction for the current day @@ -7033,7 +7018,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & if(IFORTBL(k) == 7) then !-- seasonal change of roughness length for crops - ZNTtoday(k) = Z0TBL(K) - 0.125 * factor + ZNTtoday(k) = Z0TBL(K) - 0.125_kind_phys * factor else ZNTtoday(k) = Z0TBL(K) endif @@ -7048,24 +7033,24 @@ SUBROUTINE SOILVEGIN ( debug_print, & i,j,ivgtyp,factor,vegfrac,shdmin,shdmax,deltalai(ivgtyp),laitoday(ivgtyp),znttoday(ivgtyp) ENDIF - EMISS = 0. - ZNT = 0. - ZNT1 = 0. - PC = 0. - MSNF = 0. - FACSNF= 0. - if(.not.rdlai2d) LAI = 0. - AREA = 0. + EMISS = zero + ZNT = zero + ZNT1 = zero + PC = zero + MSNF = zero + FACSNF= zero + if(.not.rdlai2d) LAI = zero + AREA = zero !-- mosaic approach to landuse in the grid box ! Use Mason (1988) Eq.(15) to compute effective ZNT; ! Lb - blending height = L/200., where L is the length scale ! of regions with varying Z0 (Lb = 5 if L=1000 m) - LB = 5. + LB = 5._kind_phys if(mosaic_lu == 1) then do k = 1,nlcat AREA = AREA + lufrac(k) EMISS = EMISS+ LEMITBL(K)*lufrac(k) - ZNT = ZNT + lufrac(k)/ALOG(LB/ZNTtoday(K))**2. + ZNT = ZNT + lufrac(k)/ALOG(LB/ZNTtoday(K))**2._kind_phys ! ZNT1 - weighted average in the grid box, not used, computed for comparison ZNT1 = ZNT1 + lufrac(k)*ZNTtoday(K) if(.not.rdlai2d) LAI = LAI + LAItoday(K)*lufrac(k) @@ -7074,8 +7059,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & FACSNF= FACSNF + SNCOVFAC(K)*lufrac(k) enddo - if (area.gt.1.) area=1. - if (area <= 0.) then + if (area.gt.one) area=one + if (area <= zero) then print *,'Bad area of grid box', area errflg = 1 errmsg = 'ERROR(SOILVEGIN): Bad area of grid box' @@ -7088,7 +7073,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & EMISS = EMISS/AREA ZNT1 = ZNT1/AREA - ZNT = LB/EXP(SQRT(1./ZNT)) + ZNT = LB/EXP(SQRT(one/ZNT)) if(.not.rdlai2d) LAI = LAI/AREA PC = PC /AREA MSNF = MSNF /AREA @@ -7109,23 +7094,23 @@ SUBROUTINE SOILVEGIN ( debug_print, & endif ! parameters from SOILPARM.TBL - RHOCS = 0. - BCLH = 0. - DQM = 0. - KSAT = 0. - PSIS = 0. - QMIN = 0. - REF = 0. - WILT = 0. - QWRTZ = 0. - AREA = 0. + RHOCS = zero + BCLH = zero + DQM = zero + KSAT = zero + PSIS = zero + QMIN = zero + REF = zero + WILT = zero + QWRTZ = zero + AREA = zero ! mosaic approach if(mosaic_soil == 1 ) then do k = 1, nscat if(k.ne.14) then ! STATSGO value for water !exclude water points from this loop AREA = AREA + soilfrac(k) - RHOCS = RHOCS + HC(k)*1.E6*soilfrac(k) + RHOCS = RHOCS + HC(k)*1.E6_kind_phys*soilfrac(k) BCLH = BCLH + BB(K)*soilfrac(k) DQM = DQM + (MAXSMC(K)- & DRYSMC(K))*soilfrac(k) @@ -7137,11 +7122,11 @@ SUBROUTINE SOILVEGIN ( debug_print, & QWRTZ = QWRTZ + QTZ(K)*soilfrac(k) endif enddo - if (area.gt.1.) area=1. - if (area <= 0.) then + if (area.gt.one) area=one + if (area <= zero) then ! area = 0. for water points ! print *,'Area of a grid box', area, 'iswater = ',iswater - RHOCS = HC(ISLTYP)*1.E6 + RHOCS = HC(ISLTYP)*1.E6_kind_phys BCLH = BB(ISLTYP) DQM = MAXSMC(ISLTYP)- & DRYSMC(ISLTYP) @@ -7166,7 +7151,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & ! dominant category approach else if(isltyp.ne.14) then - RHOCS = HC(ISLTYP)*1.E6 + RHOCS = HC(ISLTYP)*1.E6_kind_phys BCLH = BB(ISLTYP) DQM = MAXSMC(ISLTYP)- & DRYSMC(ISLTYP) @@ -7208,18 +7193,18 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & its,ite, jts,jte, kts,kte, & nzs - real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ), & + real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , & INTENT(IN) :: TSLB, & SMOIS INTEGER, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: ISLTYP,IVGTYP - real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , & INTENT(OUT) :: SMFR3D, & SH2O - real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: MAVAIL !-- local @@ -7230,8 +7215,8 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & INTEGER :: errflag - RIW=900.*1.e-3 - XLMELT=3.35E+5 + RIW=rhoice*1.e-3_kind_phys + XLMELT=con_hfus ! for FIM itf=ite ! min0(ite,ide-1) @@ -7261,7 +7246,7 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & ! has isltyp=14 for water if (isltyp(i,j) == 0) isltyp(i,j)=14 - if(landfrac(i) > 0. ) then + if(landfrac(i) > zero ) then !-- land !-- Computate volumetric content of ice in soil !-- and initialize MAVAIL @@ -7272,41 +7257,41 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & QMIN = DRYSMC (ISLTYP(I,J)) BCLH = BB (ISLTYP(I,J)) - mavail(i,j) = max(0.00001,min(1.,(smois(i,1,j)-qmin)/(ref-qmin))) + mavail(i,j) = max(0.00001_kind_phys,min(one,(smois(i,1,j)-qmin)/(ref-qmin))) DO L=1,NZS !-- for land points initialize soil ice tln=log(TSLB(i,l,j)/tfrz) - if(tln.lt.0.) then + if(tln.lt.zero) then soiliqw(l)=(dqm+qmin)*(XLMELT* & - (tslb(i,l,j)-tfrz)/tslb(i,l,j)/9.81/psis) & - **(-1./bclh) - soiliqw(l)=max(0.,soiliqw(l)) + (tslb(i,l,j)-tfrz)/tslb(i,l,j)/grav/psis) & + **(-one/bclh) + soiliqw(l)=max(zero,soiliqw(l)) soiliqw(l)=min(soiliqw(l),smois(i,l,j)) sh2o(i,l,j)=soiliqw(l) smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/RIW else - smfr3d(i,l,j)=0. + smfr3d(i,l,j)=zero sh2o(i,l,j)=smois(i,l,j) endif ENDDO elseif( fice(i) > min_seaice) then !-- ice - mavail(i,j) = 1. + mavail(i,j) = one DO L=1,NZS - smfr3d(i,l,j)=1. - sh2o(i,l,j)=0. + smfr3d(i,l,j)=one + sh2o(i,l,j)=zero ENDDO else !-- water ISLTYP=14 - mavail(i,j) = 1. + mavail(i,j) = one DO L=1,NZS - smfr3d(i,l,j)=0. - sh2o(i,l,j)=1. + smfr3d(i,l,j)=zero + sh2o(i,l,j)=one ENDDO endif ! land @@ -7684,11 +7669,11 @@ real (kind_phys) FUNCTION RSLF(P,T) real (kind_phys), PARAMETER:: C7= .379534310E-11 real (kind_phys), PARAMETER:: C8=-.321582393E-13 - X=MAX(-80.,T-273.16) + X=MAX(-80._kind_dbl_prec,T-273.16_kind_dbl_prec) ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) - ESL=MIN(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. - RSLF=.622*ESL/max(1.e-4,(P-ESL)) + ESL=MIN(ESL, P*0.15_kind_dbl_prec) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. + RSLF=.622_kind_dbl_prec*ESL/max(1.e-4_kind_dbl_prec,(P-ESL)) END FUNCTION RSLF From f10866c59c35418214ce8dab1cbee01af5ec5964 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 22 Mar 2023 22:07:15 +0000 Subject: [PATCH 17/28] Use constants from host in RUC LSM driver. --- physics/lsm_ruc.F90 | 13 +++++-------- physics/lsm_ruc.meta | 16 ++++++++++++++++ 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index a8afa7f92..4a7519f50 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -336,7 +336,7 @@ subroutine lsm_ruc_run & ! inputs & min_lakeice, min_seaice, oceanfrac, rhonewsn1, & ! --- constants & con_cp, con_rd, con_rv, con_g, con_pi, con_hvap, & - & con_hfus, con_fvirt, & + & con_hfus, con_fvirt, stbolt, rhoh2o, & ! --- in/outs for ice and land & semisbase, semis_lnd, semis_ice, sfalb_lnd, sfalb_ice, & & sncovr1_lnd, weasd_lnd, snwdph_lnd, tskin_lnd, & @@ -366,10 +366,6 @@ subroutine lsm_ruc_run & ! inputs implicit none -! --- constant parameters: - real(kind_phys), parameter :: rhoh2o = 1000.0 - real(kind_phys), parameter :: stbolt = 5.670400e-8 - ! --- input: integer, intent(in) :: me, master integer, intent(in) :: im, nlev, iter, lsoil_ruc, lsoil, kdt, isot, ivegsrc @@ -392,9 +388,10 @@ subroutine lsm_ruc_run & ! inputs & cm_ice, ch_ice real (kind_phys), intent(in) :: delt, min_seaice, min_lakeice - real (kind_phys), intent(in) :: con_cp, con_rv, con_g, & - con_pi, con_rd, & - con_hvap, con_hfus, con_fvirt + real (kind_phys), intent(in) :: con_cp, con_rv, con_g, & + con_pi, con_rd, & + con_hvap, con_hfus, & + con_fvirt, stbolt, rhoh2o logical, dimension(:), intent(in) :: flag_iter, flag_guess logical, dimension(:), intent(in) :: land, icy, use_lake diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 3ff016f85..38ebbcd67 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -1077,6 +1077,22 @@ type = real kind = kind_phys intent = in +[stbolt] + standard_name = stefan_boltzmann_constant + long_name = Stefan-Boltzmann constant + units = W m-2 K-4 + dimensions = () + type = real + kind = kind_phys + intent = in +[rhoh2o] + standard_name = density_of_fresh_water + long_name = density of fresh water + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in [semisbase] standard_name = baseline_surface_longwave_emissivity long_name = baseline surface lw emissivity in fraction From 4933f03329bce3422b7a4fb469f1998abc76a326 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 23 Mar 2023 17:19:44 +0000 Subject: [PATCH 18/28] Removed wet - not used. Also rename rocp into con_rocp --- physics/sfc_diag.f | 11 ++++++----- physics/sfc_diag.meta | 10 +--------- 2 files changed, 7 insertions(+), 14 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 585bd4b7d..be648bd61 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -22,8 +22,9 @@ end subroutine sfc_diag_finalize !! \section detailed Detailed Algorithm !! @{ subroutine sfc_diag_run (im,xlat_d,xlon_d, & - & lsm,lsm_ruc,grav,cp,eps,epsm1,rocp,con_karman,& - & wet,shflx,cdq,wind, & + & lsm,lsm_ruc,grav,cp,eps,epsm1,con_rocp, & + & con_karman, & + & shflx,cdq,wind, & & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & & ust,tskin,qsurf,thsfc_loc,diag_flux,diag_log, & & f10m,u10m,v10m,t2m,q2m,dpt2m,errmsg,errflg & @@ -37,10 +38,10 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. logical, intent(in) :: diag_flux ! Flag for flux method in 2-m diagnostics logical, intent(in) :: diag_log ! Flag for 2-m log diagnostics under stable conditions - real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1,rocp + real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1,con_rocp real(kind=kind_phys), intent(in) :: con_karman real(kind=kind_phys), dimension(:), intent( in) :: & - & zf, ps, u1, v1, t1, q1, ust, tskin, wet, & + & zf, ps, u1, v1, t1, q1, ust, tskin, & & qsurf, prslki, evap, fm, fh, fm10, fh2, & & shflx, cdq, wind, xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(out) :: & @@ -95,7 +96,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & ! t2m(i) = t2m(i) * sig2k wrk = 1.0 - fhi - thcon = (1.e5/ps(i))**rocp + thcon = (1.e5/ps(i))**con_rocp !-- make sure 1st level q is not higher than saturated value qss = fpvs(t1(i)) qss = eps * qss / (ps(i) + epsm1 * qss) diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index 7618a4a00..6eac1dc4b 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -76,7 +76,7 @@ type = real kind = kind_phys intent = in -[rocp] +[con_rocp] standard_name = ratio_of_gas_constant_dry_air_to_specific_heat_of_dry_air_at_constant_pressure long_name = (rd/cp) units = none @@ -91,14 +91,6 @@ dimensions = () type = real intent = in -[wet] - standard_name = normalized_soil_wetness_for_land_surface_model - long_name = normalized soil wetness - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [zf] standard_name = height_above_ground_at_lowest_model_layer long_name = layer 1 height above ground (not MSL) From f7839dea35783b80383a619b3e0363cd349b091f Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 23 Mar 2023 18:27:34 +0000 Subject: [PATCH 19/28] More changes in RUC LSM related to kind_phys and use of constants from Physcons. --- physics/lsm_ruc.F90 | 412 ++++++++++++++++++++++---------------------- 1 file changed, 207 insertions(+), 205 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 4a7519f50..cec87e689 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -10,13 +10,15 @@ module lsm_ruc use module_soil_pre use module_sf_ruclsm + use physcons, only : con_t0c + implicit none private public :: lsm_ruc_init, lsm_ruc_run, lsm_ruc_finalize - real(kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys + real(kind_phys), parameter :: zero = 0.0_kind_dbl_prec, one = 1.0_kind_dbl_prec, epsln = 1.0e-8_kind_dbl_prec real(kind_phys), dimension (2), parameter, private :: d = (/0.1,0.25/) integer, dimension(20), parameter, private:: & istwe = (/1,1,1,1,1,2,2,1,1,2,2,2,2,2,1,2,2,1,2,2/) ! IGBP 20 classes @@ -171,26 +173,26 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & if (lsm_cold_start) then !-- land - semis_lnd(i) = semisbase(i) * (1.-sncovr_lnd(i)) & - + 0.99 * sncovr_lnd(i) - sfalb_lnd_bck(i) = 0.25*(alnsf(i) + alnwf(i) + alvsf(i) + alvwf(i)) & - * min(1., facsf(i)+facwf(i)) - alb_lnd = sfalb_lnd_bck(i) * (1. - sncovr_lnd(i)) & + semis_lnd(i) = semisbase(i) * (one-sncovr_lnd(i)) & + + 0.99_kind_phys * sncovr_lnd(i) + sfalb_lnd_bck(i) = 0.25_kind_phys*(alnsf(i) + alnwf(i) + alvsf(i) + alvwf(i)) & + * min(one, facsf(i)+facwf(i)) + alb_lnd = sfalb_lnd_bck(i) * (one - sncovr_lnd(i)) & + snoalb(i) * sncovr_lnd(i) albdvis_lnd(i) = alb_lnd albdnir_lnd(i) = alb_lnd albivis_lnd(i) = alb_lnd albinir_lnd(i) = alb_lnd !-- ice - semis_ice(i) = 0.97 * (1. - sncovr_ice(i)) + 0.99 * sncovr_ice(i) - alb_ice = 0.55 * (1. - sncovr_ice(i)) + 0.75 * sncovr_ice(i) + semis_ice(i) = 0.97_kind_phys * (one - sncovr_ice(i)) + 0.99_kind_phys * sncovr_ice(i) + alb_ice = 0.55_kind_phys * (one - sncovr_ice(i)) + 0.75_kind_phys * sncovr_ice(i) albdvis_ice(i) = alb_ice albdnir_ice(i) = alb_ice albivis_ice(i) = alb_ice albinir_ice(i) = alb_ice !-- initialize QV mixing ratio at the surface from atm. 1st level - q0 = max(q1(i)/(1.-q1(i)), 1.e-8) ! q1=specific humidity at level 1 (kg/kg) + q0 = max(q1(i)/(one-q1(i)), epsln) ! q1=specific humidity at level 1 (kg/kg) qs1 = rslf(prsl1(i),tsfc_lnd(i)) !* qs1=sat. mixing ratio at level 1 (kg/kg) q0 = min(qs1, q0) sfcqv_lnd(i) = q0 @@ -376,7 +378,7 @@ subroutine lsm_ruc_run & ! inputs real (kind_phys), dimension(:), intent(in) :: xlat_d, xlon_d real (kind_phys), dimension(:), intent(in) :: oro, sigma - real (kind_phys), dimension(:), intent(in) :: & + real (kind_phys), dimension(:), intent(in) :: & & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & & coszen, prsl1, wind, shdmin, shdmax, & & sfalb_lnd_bck, snoalb, zf, qc, q1, & @@ -548,13 +550,13 @@ subroutine lsm_ruc_run & ! inputs ipr = 10 !-- - testptlat = 68.6 !41.02 !42.05 !39.0 !74.12 !29.5 - testptlon = 298.6 !284.50 !286.75 !280.6 !164.0 !283.0 + testptlat = 68.6_kind_phys + testptlon = 298.6_kind_phys !-- debug_print=.false. - chklowq = 1. + chklowq = one do i = 1, im ! i - horizontal loop flag_ice(i) = .false. @@ -632,9 +634,9 @@ subroutine lsm_ruc_run & ! inputs fractional_seaice = 1 if ( fractional_seaice == 0 ) then - xice_threshold = 0.5 + xice_threshold = 0.5_kind_phys else if ( fractional_seaice == 1 ) then - xice_threshold = 0.15 ! consistent with GFS physics, 0.02 in HRRR + xice_threshold = 0.15_kind_phys ! consistent with GFS physics, 0.02 in HRRR endif nsoil = lsoil_ruc @@ -643,8 +645,8 @@ subroutine lsm_ruc_run & ! inputs ! reassign smcref2 and smcwlt2 to RUC values if(.not. land(i)) then !water and sea ice - smcref2 (i) = 1. - smcwlt2 (i) = 0. + smcref2 (i) = one + smcwlt2 (i) = zero else !land smcref2 (i) = REFSMC(stype(i)) @@ -701,52 +703,52 @@ subroutine lsm_ruc_run & ! inputs do j = jms, jme do i = 1, im ! i - horizontal loop if (flag_iter(i) .and. flag(i)) then - evap_lnd(i) = 0.0 - evap_ice(i) = 0.0 - hflx_lnd (i) = 0.0 - hflx_ice (i) = 0.0 - gflux_lnd(i) = 0.0 - gflux_ice(i) = 0.0 - drain(i) = 0.0 - canopy(i) = max(canopy(i), 0.0) - - evbs (i) = 0.0 - evcw (i) = 0.0 - trans(i) = 0.0 - sbsno(i) = 0.0 + evap_lnd(i) = zero + evap_ice(i) = zero + hflx_lnd (i) = zero + hflx_ice (i) = zero + gflux_lnd(i) = zero + gflux_ice(i) = zero + drain(i) = zero + canopy(i) = max(canopy(i), zero) + + evbs (i) = zero + evcw (i) = zero + trans(i) = zero + sbsno(i) = zero !local i,j arrays - snoh_lnd(i,j) = 0.0 - snoh_ice(i,j) = 0.0 - dew_lnd(i,j) = 0.0 - dew_ice(i,j) = 0.0 - soilm(i,j) = 0.0 - smmax(i,j) = 0.0 - hfx_lnd(i,j) = 0.0 - hfx_ice(i,j) = 0.0 - qfx_lnd(i,j) = 0.0 - qfx_ice(i,j) = 0.0 - lh_lnd(i,j) = 0.0 - lh_ice(i,j) = 0.0 - esnow_lnd(i,j) = 0.0 - esnow_ice(i,j) = 0.0 - sfcexc(i,j) = 0.0 - acceta(i,j) = 0.0 - ssoil_lnd(i,j) = 0.0 - ssoil_ice(i,j) = 0.0 - infiltr(i,j) = 0.0 - precipfr(i,j) = 0.0 - rhosnfr(i,j) = -1.e3 - runoff1(i,j) = 0.0 - runoff2(i,j) = 0.0 + snoh_lnd(i,j) = zero + snoh_ice(i,j) = zero + dew_lnd(i,j) = zero + dew_ice(i,j) = zero + soilm(i,j) = zero + smmax(i,j) = zero + hfx_lnd(i,j) = zero + hfx_ice(i,j) = zero + qfx_lnd(i,j) = zero + qfx_ice(i,j) = zero + lh_lnd(i,j) = zero + lh_ice(i,j) = zero + esnow_lnd(i,j)= zero + esnow_ice(i,j)= zero + sfcexc(i,j) = zero + acceta(i,j) = zero + ssoil_lnd(i,j)= zero + ssoil_ice(i,j)= zero + infiltr(i,j) = zero + precipfr(i,j) = zero + rhosnfr(i,j) = -1.e3_kind_phys + runoff1(i,j) = zero + runoff2(i,j) = zero if(kdt == 1) then - acrunoff(i,j) = 0.0 - snfallac_lnd(i,j) = 0.0 - acsn_lnd(i,j) = 0.0 - snfallac_ice(i,j) = 0.0 - acsn_ice(i,j) = 0.0 - snomlt_lnd(i,j) = 0.0 - snomlt_ice(i,j) = 0.0 + acrunoff(i,j) = zero + snfallac_lnd(i,j) = zero + acsn_lnd(i,j) = zero + snfallac_ice(i,j) = zero + acsn_ice(i,j) = zero + snomlt_lnd(i,j) = zero + snomlt_ice(i,j) = zero endif endif enddo ! i=1,im @@ -756,9 +758,9 @@ subroutine lsm_ruc_run & ! inputs do i = 1, im if (flag_iter(i) .and. flag(i)) then - q0(i) = max(q1(i)/(1.-q1(i)), 1.e-8) !* q1=specific humidity at level 1 (kg/kg) + q0(i) = max(q1(i)/(one-q1(i)), epsln) !* q1=specific humidity at level 1 (kg/kg) - rho(i) = prsl1(i) / (con_rd*t1(i)*(1.0+con_fvirt*q0(i))) + rho(i) = prsl1(i) / (con_rd*t1(i)*(one+con_fvirt*q0(i))) qs1(i) = rslf(prsl1(i),t1(i)) !* qs1=sat. mixing ratio at level 1 (kg/kg) q0 (i) = min(qs1(i), q0(i)) endif ! flag_iter & flag @@ -799,7 +801,7 @@ subroutine lsm_ruc_run & ! inputs do j = jms, jme do i = 1, im ! i - horizontal loop - xice(i,j) = 0. + xice(i,j) = zero if (flag_iter(i) .and. flag(i)) then if (frpcpn) then @@ -813,8 +815,8 @@ subroutine lsm_ruc_run & ! inputs rdlai2d = rdlai - conflx2(i,1,j) = zf(i) * 2. ! factor 2. is needed to get the height of - ! atm. forcing inside RUC LSM (inherited + conflx2(i,1,j) = zf(i) * 2._kind_phys ! factor 2. is needed to get the height of + ! atm. forcing inside RUC LSM (inherited ! from WRF) !> - 2. forcing data (f): @@ -827,7 +829,7 @@ subroutine lsm_ruc_run & ! inputs sfcprs(i,1,j) = prsl1(i) sfctmp(i,1,j) = t1(i) q2(i,1,j) = q0(i) - qcatm(i,1,j) = max(0., qc(i)) + qcatm(i,1,j) = max(zero, qc(i)) rho2(i,1,j) = rho(i) !!\n \a lwdn - lw dw radiation flux at surface (\f$W m^{-2}\f$) @@ -903,10 +905,10 @@ subroutine lsm_ruc_run & ! inputs ! SLMSK0 - SEA(0),LAND(1),ICE(2) MASK if(land(i)) then ! some land - xland(i,j) = 1. - xice_lnd(i,j) = 0. + xland(i,j) = one + xice_lnd(i,j) = zero elseif(flag_ice_uncoupled(i)) then ! some ice - xland(i,j) = 1. + xland(i,j) = one xice(i,j) = fice(i) ! fraction of sea-ice endif else @@ -916,14 +918,14 @@ subroutine lsm_ruc_run & ! inputs if(rdlai2d) then xlai(i,j) = laixy(i) else - xlai(i,j) = 0. + xlai(i,j) = zero endif semis_bck(i,j) = semisbase(i) ! --- units % - shdfac(i,j) = sigmaf(i)*100. - shdmin1d(i,j) = shdmin(i)*100. - shdmax1d(i,j) = shdmax(i)*100. + shdfac(i,j) = sigmaf(i)*100._kind_phys + shdmin1d(i,j) = shdmin(i)*100._kind_phys + shdmax1d(i,j) = shdmax(i)*100._kind_phys if (land(i)) then ! at least some land in the grid cell @@ -954,22 +956,22 @@ subroutine lsm_ruc_run & ! inputs qcg_lnd(i,j) = sfcqc_lnd(i) sncovr_lnd(i,j) = sncovr1_lnd(i) if (kdt == 1) then - sfcems_lnd(i,j) = semisbase(i) * (1.-sncovr_lnd(i,j)) + 0.99 * sncovr_lnd(i,j) + sfcems_lnd(i,j) = semisbase(i) * (one-sncovr_lnd(i,j)) + 0.99_kind_phys * sncovr_lnd(i,j) else sfcems_lnd(i,j) = semis_lnd(i) endif - if(coszen(i) > 0. .and. weasd_lnd(i) < 1.e-4) then + if(coszen(i) > zero .and. weasd_lnd(i) < 1.e-4_kind_phys) then !-- solar zenith angle dependence when no snow ilst=istwe(vtype(i)) ! 1 or 2 - dm = (1.+2.*d(ilst))/(1.+2.*d(ilst)*coszen(i)) + dm = (one+2._kind_phys*d(ilst))/(one+2._kind_phys*d(ilst)*coszen(i)) albbcksol(i) = sfalb_lnd_bck(i)*dm else albbcksol(i) = sfalb_lnd_bck(i) endif ! coszen > 0. snoalb1d_lnd(i,j) = snoalb(i) - albbck_lnd(i,j) = min(0.9,albbcksol(i)) !sfalb_lnd_bck(i) + albbck_lnd(i,j) = min(0.9_kind_phys,albbcksol(i)) !sfalb_lnd_bck(i) !-- spp_lsm @@ -980,29 +982,29 @@ subroutine lsm_ruc_run & ! inputs enddo !-- stochastic perturbation of snow-free albedo, emissivity and veg. !-- fraction - albbck_lnd(i,j) = min(albbck_lnd(i,j) * (1. + 0.4*pattern_spp_lsm(i,1,j)), 1.) - sfcems_lnd(i,j) = min(sfcems_lnd(i,j) * (1. + 0.1*pattern_spp_lsm(i,1,j)), 1.) - shdfac(i,j) = min(0.01*shdfac(i,j) * (1. + 0.33*pattern_spp_lsm(i,1,j)),1.)*100. + albbck_lnd(i,j) = min(albbck_lnd(i,j) * (one + 0.4_kind_phys*pattern_spp_lsm(i,1,j)), one) + sfcems_lnd(i,j) = min(sfcems_lnd(i,j) * (one + 0.1_kind_phys*pattern_spp_lsm(i,1,j)), one) + shdfac(i,j) = min(0.01_kind_phys*shdfac(i,j) * (one + 0.33_kind_phys*pattern_spp_lsm(i,1,j)),one)*100._kind_phys if (kdt == 2) then !-- stochastic perturbation of soil moisture at time step 2 do k = 1, lsoil_ruc - smois(i,k) = smois(i,k)*(1+1.5*pattern_spp_lsm(i,k,j)) + smois(i,k) = smois(i,k)*(one+1.5_kind_phys*pattern_spp_lsm(i,k,j)) enddo endif endif - alb_lnd(i,j) = albbck_lnd(i,j) * (1.-sncovr_lnd(i,j)) + snoalb(i) * sncovr_lnd(i,j) ! sfalb_lnd(i) - solnet_lnd(i,j) = dswsfc(i)*(1.-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 + alb_lnd(i,j) = albbck_lnd(i,j) * (one-sncovr_lnd(i,j)) + snoalb(i) * sncovr_lnd(i,j) ! sfalb_lnd(i) + solnet_lnd(i,j) = dswsfc(i)*(one-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 cmc(i,j) = canopy(i) ! [mm] soilt_lnd(i,j) = tsurf_lnd(i) ! sanity check for snow temperature tsnow - if (tsnow_lnd(i) > 200. .and. tsnow_lnd(i) < 273.15) then + if (tsnow_lnd(i) > 200._kind_phys .and. tsnow_lnd(i) < con_t0c) then soilt1_lnd(i,j) = tsnow_lnd(i) else soilt1_lnd(i,j) = tsurf_lnd(i) endif - tsnav_lnd(i,j) = min(0.,0.5*(soilt_lnd(i,j) + soilt1_lnd(i,j)) - 273.15) + tsnav_lnd(i,j) = min(zero,0.5_kind_phys*(soilt_lnd(i,j) + soilt1_lnd(i,j)) - con_t0c) do k = 1, lsoil_ruc smsoil (i,k,j) = smois(i,k) slsoil (i,k,j) = sh2o(i,k) @@ -1011,14 +1013,14 @@ subroutine lsm_ruc_run & ! inputs keepfrsoil(i,k,j) = keepfr(i,k) enddo ! land - if (wetness(i) > 0.) then + if (wetness(i) > zero) then wet(i,j) = wetness(i) else - wet(i,j) = max(0.0001,smsoil(i,1,j)/0.3) + wet(i,j) = max(0.0001_kind_phys,smsoil(i,1,j)/0.3_kind_phys) endif chs_lnd (i,j) = ch_lnd(i) * wind(i) ! compute conductance - flhc_lnd(i,j) = chs_lnd(i,j) * rho(i) * con_cp * (1.+0.84*q2(i,1,j)) + flhc_lnd(i,j) = chs_lnd(i,j) * rho(i) * con_cp * (one+0.84_kind_phys*q2(i,1,j)) flqc_lnd(i,j) = chs_lnd(i,j) * rho(i) * wet(i,j) ! for output @@ -1026,7 +1028,7 @@ subroutine lsm_ruc_run & ! inputs chh_lnd(i) = chs_lnd(i,j) * rho(i) ! sneqv_lnd(i,j) = weasd_lnd(i) - snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m + snowh_lnd(i,j) = snwdph_lnd(i) * 0.001_kind_phys ! convert from mm to m if(kdt > 1) then !-- run-total accumulation @@ -1036,38 +1038,38 @@ subroutine lsm_ruc_run & ! inputs endif !> -- sanity checks on sneqv and snowh - if (sneqv_lnd(i,j) /= 0.0_kind_dbl_prec .and. snowh_lnd(i,j) == 0.0_kind_dbl_prec) then + if (sneqv_lnd(i,j) /= zero .and. snowh_lnd(i,j) == zero) then if (debug_print) print *,'bad sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) - if(sneqv_lnd(i,j) < 1.e-7_kind_dbl_prec.or.soilt_lnd(i,j)>273.15_kind_dbl_prec) then - sneqv_lnd(i,j) = 0._kind_dbl_prec - snowh_lnd(i,j) = 0._kind_dbl_prec + if(sneqv_lnd(i,j) < epsln.or.soilt_lnd(i,j)>con_t0c) then + sneqv_lnd(i,j) = zero + snowh_lnd(i,j) = zero else - sneqv_lnd(i,j) = 300._kind_dbl_prec * snowh_lnd(i,j) ! snow density ~300 kg m-3 + sneqv_lnd(i,j) = 300._kind_phys * snowh_lnd(i,j) ! snow density ~300 kg m-3 endif if (debug_print) print *,'fixed sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) - elseif (snowh_lnd(i,j) /= 0.0_kind_dbl_prec .and. sneqv_lnd(i,j) == 0.0_kind_dbl_prec) then + elseif (snowh_lnd(i,j) /= zero .and. sneqv_lnd(i,j) == zero) then if (debug_print) print *,'bad snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) - if(snowh_lnd(i,j) < 3.e-10_kind_dbl_prec.or.soilt_lnd(i,j)>273.15_kind_dbl_prec) then - snowh_lnd(i,j) = 0._kind_dbl_prec - sneqv_lnd(i,j) = 0._kind_dbl_prec + if(snowh_lnd(i,j) < 3.e-10_kind_dbl_prec.or.soilt_lnd(i,j)>con_t0c) then + snowh_lnd(i,j) = zero + sneqv_lnd(i,j) = zero else snowh_lnd(i,j) = 0.003_kind_dbl_prec * sneqv_lnd(i,j) ! snow density ~300 kg m-3 endif if (debug_print) print *,'fixed snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) - elseif (sneqv_lnd(i,j) > 0._kind_dbl_prec .and. snowh_lnd(i,j) > 0._kind_dbl_prec) then + elseif (sneqv_lnd(i,j) > zero .and. snowh_lnd(i,j) > zero) then if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then print *,'sneqv_lnd(i,j)/snowh_lnd(i,j)',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) endif - if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 500._kind_dbl_prec) then + if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 500._kind_phys) then if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then print *,'large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) print *,'large snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) endif - if(soilt_lnd(i,j)>273.15_kind_dbl_prec) then - snowh_lnd(i,j) = 0._kind_dbl_prec - sneqv_lnd(i,j) = 0._kind_dbl_prec + if(soilt_lnd(i,j)>con_t0c) then + snowh_lnd(i,j) = zero + sneqv_lnd(i,j) = zero else snowh_lnd(i,j) = 0.002_kind_dbl_prec * sneqv_lnd(i,j) endif @@ -1075,17 +1077,17 @@ subroutine lsm_ruc_run & ! inputs abs(xlon_d(i)-testptlon).lt.0.5)then print *,'fixed large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) endif - elseif(sneqv_lnd(i,j)/snowh_lnd(i,j) < 58._kind_dbl_prec) then + elseif(sneqv_lnd(i,j)/snowh_lnd(i,j) < 58._kind_phys) then if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then print *,'small snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) print *,'small snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) endif - if(soilt_lnd(i,j)>273.15_kind_dbl_prec) then - snowh_lnd(i,j) = 0._kind_dbl_prec - sneqv_lnd(i,j) = 0._kind_dbl_prec + if(soilt_lnd(i,j)>con_t0c) then + snowh_lnd(i,j) = zero + sneqv_lnd(i,j) = zero else - sneqv_lnd(i,j) = 58._kind_dbl_prec * snowh_lnd(i,j) + sneqv_lnd(i,j) = 58._kind_phys * snowh_lnd(i,j) endif if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then @@ -1095,8 +1097,8 @@ subroutine lsm_ruc_run & ! inputs endif !-- z0rl is in [cm] - z0_lnd(i,j) = z0rl_lnd(i)/100. - znt_lnd(i,j) = z0rl_lnd(i)/100. + z0_lnd(i,j) = z0rl_lnd(i)/100._kind_phys + znt_lnd(i,j) = z0rl_lnd(i)/100._kind_phys ! Workaround needed for subnormal numbers. This should be ! done after all other sanity checks, in case a sanity check @@ -1105,34 +1107,34 @@ subroutine lsm_ruc_run & ! inputs ! This bug was caught by the UFS gfortran debug-mode ! regression tests, and the fix is necessary to pass those ! tests. - if(abs(snowh_lnd(i,j))<1e-20) then - snowh_lnd(i,j)=0 + if(abs(snowh_lnd(i,j))<1e-20_kind_phys) then + snowh_lnd(i,j)=zero endif - if(abs(sneqv_lnd(i,j))<1e-20) then - sneqv_lnd(i,j)=0 + if(abs(sneqv_lnd(i,j))<1e-20_kind_phys) then + sneqv_lnd(i,j)=zero endif - !if (debug_print) then + if (debug_print) then !-- diagnostics for a land test point with known lat/lon - if (kdt < 10) then + !if (kdt < 10) then if (abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then !if(weasd_lnd(i) > 0.) & - print 100,'(ruc_lsm_drv before RUC land call) i=',i, & - ' lat,lon=',xlat_d(i),xlon_d(i), & - 'rainc',rainc(i),'rainnc',rainnc(i),'prcp',prcp(i,j), & - 'graupel',graupel(i),'qc',qc(i),'sfcqv_lnd',sfcqv_lnd(i),& - 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & + print 100,'(ruc_lsm_drv before RUC land call) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'rainc',rainc(i),'rainnc',rainnc(i),'prcp',prcp(i,j), & + 'graupel',graupel(i),'qc',qc(i),'sfcqv_lnd',sfcqv_lnd(i), & + 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& - 'albbcksol',albbcksol(i),'alb_lnd',alb_lnd(i,j), & - 'solnet_lnd',solnet_lnd(i,j),'t1',t1(i), & - 'sfcems_lnd',sfcems_lnd(i,j),'flhc_lnd',flhc_lnd(i,j), & - 'flqc_lnd',flqc_lnd(i,j),'wet',wet(i,j),'cmc',cmc(i,j),& - 'qcg_lnd',qcg_lnd(i,j),'dew',dew_lnd(i,j), & - 'znt_lnd',znt_lnd(i,j),'shdfac',shdfac(i,j), & - 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & - 'smsoil1',smsoil(i,1,j),'slsoil',slsoil(i,1,j), & - 'keepfrsoil',keepfrsoil(i,1,j), & + 'albbcksol',albbcksol(i),'alb_lnd',alb_lnd(i,j), & + 'solnet_lnd',solnet_lnd(i,j),'t1',t1(i), & + 'sfcems_lnd',sfcems_lnd(i,j),'flhc_lnd',flhc_lnd(i,j), & + 'flqc_lnd',flqc_lnd(i,j),'wet',wet(i,j),'cmc',cmc(i,j), & + 'qcg_lnd',qcg_lnd(i,j),'dew',dew_lnd(i,j), & + 'znt_lnd',znt_lnd(i,j),'shdfac',shdfac(i,j), & + 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & + 'smsoil1',smsoil(i,1,j),'slsoil',slsoil(i,1,j), & + 'keepfrsoil',keepfrsoil(i,1,j), & 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) endif endif ! debug_print @@ -1259,7 +1261,7 @@ subroutine lsm_ruc_run & ! inputs qsurf_lnd(i) = qsfc_lnd(i,j) tsurf_lnd(i) = soilt_lnd(i,j) tsnow_lnd(i) = soilt1_lnd(i,j) - stm(i) = soilm(i,j) * 1.e-3 ! convert to [m] + stm(i) = soilm(i,j) * 1.e-3_kind_phys ! convert to [m] runof (i) = runoff1(i,j) * rhoh2o ! surface kg m-2 s-1 drain (i) = runoff2(i,j) * rhoh2o ! kg m-2 s-1 @@ -1280,14 +1282,14 @@ subroutine lsm_ruc_run & ! inputs ! --- ... accumulated frozen precipitation (accumulation in lsmruc) snowfallac_lnd(i) = snfallac_lnd(i,j) ! accum kg m-2 ! --- ... unit conversion (from m to mm) - snwdph_lnd(i) = snowh_lnd(i,j) * 1000.0 + snwdph_lnd(i) = snowh_lnd(i,j) * rhoh2o canopy(i) = cmc(i,j) ! mm weasd_lnd(i) = sneqv_lnd(i,j) ! mm sncovr1_lnd(i) = sncovr_lnd(i,j) ! ---- ... outside RUC LSM, roughness uses cm as unit ! (update after snow's effect) - z0rl_lnd(i) = znt_lnd(i,j)*100. + z0rl_lnd(i) = znt_lnd(i,j)*100._kind_phys !-- semis_lnd is with snow effect semis_lnd(i) = sfcems_lnd(i,j) !-- semisbas is without snow effect, but can have vegetation mosaic effect @@ -1333,46 +1335,46 @@ subroutine lsm_ruc_run & ! inputs endif 101 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es9.2))) - edir (i,j) = 0.0 - ec (i,j) = 0.0 - ett (i,j) = 0.0 + edir (i,j) = zero + ec (i,j) = zero + ett (i,j) = zero sncovr_ice(i,j) = sncovr1_ice(i) !-- alb_ice* is computed in setalb called from rrtmg_sw_pre. - snoalb1d_ice(i,j) = 0.75 !alb_ice_snow(i) !0.75 is RAP value for max snow alb on ice - albbck_ice(i,j) = 0.55 !alb_ice_snowfree(i) !0.55 is RAP value for ice alb + snoalb1d_ice(i,j) = 0.75_kind_phys !alb_ice_snow(i) !0.75 is RAP value for max snow alb on ice + albbck_ice(i,j) = 0.55_kind_phys !alb_ice_snowfree(i) !0.55 is RAP value for ice alb alb_ice(i,j) = sfalb_ice(i) - solnet_ice(i,j) = dswsfc(i)*(1.-alb_ice(i,j)) + solnet_ice(i,j) = dswsfc(i)*(one-alb_ice(i,j)) qvg_ice(i,j) = sfcqv_ice(i) - qsfc_ice(i,j) = sfcqv_ice(i)/(1.+sfcqv_ice(i)) + qsfc_ice(i,j) = sfcqv_ice(i)/(one+sfcqv_ice(i)) qsg_ice(i,j) = rslf(prsl1(i),tsurf_ice(i)) qcg_ice(i,j) = sfcqc_ice(i) - semis_bck(i,j) = 0.99 + semis_bck(i,j) = 0.99_kind_phys if (kdt == 1) then - sfcems_ice(i,j) = semisbase(i) * (1.-sncovr_ice(i,j)) + 0.99 * sncovr_ice(i,j) + sfcems_ice(i,j) = semisbase(i) * (one-sncovr_ice(i,j)) + 0.99_kind_phys * sncovr_ice(i,j) else sfcems_ice(i,j) = semis_ice(i) endif cmc(i,j) = canopy(i) ! [mm] soilt_ice(i,j) = tsurf_ice(i) - if (tsnow_ice(i) > 150. .and. tsnow_ice(i) < 273.15) then + if (tsnow_ice(i) > 150._kind_phys .and. tsnow_ice(i) < con_t0c) then soilt1_ice(i,j) = tsnow_ice(i) else soilt1_ice(i,j) = tsurf_ice(i) endif - tsnav_ice(i,j) = min(0.,0.5*(soilt_ice(i,j) + soilt1_ice(i,j)) - 273.15) + tsnav_ice(i,j) = min(zero,0.5_kind_phys*(soilt_ice(i,j) + soilt1_ice(i,j)) - con_t0c) do k = 1, lsoil_ruc stsice (i,k,j) = tsice(i,k) - smice (i,k,j) = 1. - slice (i,k,j) = 0. - smfrice (i,k,j) = 1. - keepfrice(i,k,j) = 1. + smice (i,k,j) = one + slice (i,k,j) = zero + smfrice (i,k,j) = one + keepfrice(i,k,j) = one enddo - wet_ice(i,j) = 1. + wet_ice(i,j) = one chs_ice (i,j) = ch_ice(i) * wind(i) ! compute conductance - flhc_ice(i,j) = chs_ice(i,j) * rho(i) * con_cp * (1. + 0.84*q2(i,1,j)) + flhc_ice(i,j) = chs_ice(i,j) * rho(i) * con_cp * (one + 0.84_kind_phys*q2(i,1,j)) flqc_ice(i,j) = chs_ice(i,j) * rho(i) * wet_ice(i,j) ! for output @@ -1380,8 +1382,8 @@ subroutine lsm_ruc_run & ! inputs chh_ice(i) = chs_ice(i,j) * rho(i) - snowh_ice(i,j) = snwdph_ice(i) * 0.001 ! convert from mm to m - sneqv_ice(i,j) = weasd_ice(i) ! [mm] + snowh_ice(i,j) = snwdph_ice(i) * 0.001_kind_phys ! convert from mm to m + sneqv_ice(i,j) = weasd_ice(i) ! [mm] if(kdt > 1) then snfallac_ice(i,j) = snowfallac_ice(i) acsn_ice(i,j) = acsnow_ice(i) @@ -1389,25 +1391,25 @@ subroutine lsm_ruc_run & ! inputs endif !> -- sanity checks on sneqv and snowh - if (sneqv_ice(i,j) /= 0.0 .and. snowh_ice(i,j) == 0.0) then - snowh_ice(i,j) = 0.003 * sneqv_ice(i,j) ! snow density ~300 kg m-3 + if (sneqv_ice(i,j) /= zero .and. snowh_ice(i,j) == zero) then + snowh_ice(i,j) = 0.003_kind_phys * sneqv_ice(i,j) ! snow density ~300 kg m-3 endif - if (snowh_ice(i,j) /= 0.0 .and. sneqv_ice(i,j) == 0.0) then - sneqv_ice(i,j) = 300. * snowh_ice(i,j) ! snow density ~300 kg m-3 + if (snowh_ice(i,j) /= zero .and. sneqv_ice(i,j) == zero) then + sneqv_ice(i,j) = 300._kind_phys * snowh_ice(i,j) ! snow density ~300 kg m-3 endif - if (sneqv_ice(i,j) > 0. .and. snowh_ice(i,j) > 0.) then - if(sneqv_ice(i,j)/snowh_ice(i,j) > 950.) then - sneqv_ice(i,j) = 300. * snowh_ice(i,j) + if (sneqv_ice(i,j) > zero .and. snowh_ice(i,j) > zero) then + if(sneqv_ice(i,j)/snowh_ice(i,j) > 950._kind_phys) then + sneqv_ice(i,j) = 300._kind_phys * snowh_ice(i,j) endif endif - z0_ice(i,j) = z0rl_ice(i)/100. - znt_ice(i,j) = z0rl_ice(i)/100. + z0_ice(i,j) = z0rl_ice(i)/100._kind_phys + znt_ice(i,j) = z0rl_ice(i)/100._kind_phys - runoff1(i,j) = 0. - runoff2(i,j) = 0. + runoff1(i,j) = zero + runoff2(i,j) = zero ! Workaround needed for subnormal numbers. This should be ! done after all other sanity checks, in case a sanity check @@ -1415,11 +1417,11 @@ subroutine lsm_ruc_run & ! inputs ! ! Although this bug has not been triggered yet, it is expected ! to be, like the _lnd variants many lines up from here. - if(abs(snowh_ice(i,j))<1e-20) then - snowh_ice(i,j)=0 + if(abs(snowh_ice(i,j))<1e-20_kind_phys) then + snowh_ice(i,j)=zero endif - if(abs(sneqv_ice(i,j))<1e-20) then - sneqv_ice(i,j)=0 + if(abs(sneqv_ice(i,j))<1e-20_kind_phys) then + sneqv_ice(i,j)=zero endif !> - Call RUC LSM lsmruc() for ice. @@ -1482,7 +1484,7 @@ subroutine lsm_ruc_run & ! inputs snwdph_ice(i) = snowh_ice(i,j) * rhoh2o weasd_ice(i) = sneqv_ice(i,j) ! kg m-2 sncovr1_ice(i) = sncovr_ice(i,j) - z0rl_ice(i) = znt_ice(i,j)*100. ! cm + z0rl_ice(i) = znt_ice(i,j)*100._kind_phys ! cm !-- semis_ice is with snow effect semis_ice(i) = sfcems_ice(i,j) !-- sfalb_ice is with snow effect @@ -1497,11 +1499,11 @@ subroutine lsm_ruc_run & ! inputs do k = 1, lsoil_ruc tsice(i,k) = stsice(i,k,j) if(.not. frac_grid .or. .not. land(i)) then - smois(i,k) = 1. - sh2o(i,k) = 0. + smois(i,k) = one + sh2o(i,k) = zero tslb(i,k) = stsice(i,k,j) - keepfr(i,k) = 1. - smfrkeep(i,k) = 1. + keepfr(i,k) = one + smfrkeep(i,k) = one endif enddo if(debug_print) then @@ -1587,12 +1589,12 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in implicit none - logical, intent(in ) :: lsm_cold_start - integer, intent(in ) :: lsm - integer, intent(in ) :: lsm_ruc - integer, intent(in ) :: im, nlev - integer, intent(in ) :: lsoil_ruc - integer, intent(in ) :: lsoil + logical, intent(in ) :: lsm_cold_start + integer, intent(in ) :: lsm + integer, intent(in ) :: lsm_ruc + integer, intent(in ) :: im, nlev + integer, intent(in ) :: lsoil_ruc + integer, intent(in ) :: lsoil real (kind_phys), intent(in ) :: min_seaice real (kind_phys), dimension(im), intent(in ) :: slmsk real (kind_phys), dimension(im), intent(in ) :: landfrac @@ -1605,8 +1607,8 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in real (kind_phys), dimension(im,lsoil), intent(in ) :: stc ! Noah real (kind_phys), dimension(im,lsoil), intent(in ) :: slc ! Noah - integer, dimension(im), intent(in) :: stype, vtype - real (kind_phys), dimension(im), intent(inout) :: wetness + integer, dimension(im), intent(in) :: stype, vtype + real (kind_phys), dimension(im), intent(inout) :: wetness real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smois! ruc real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb ! ruc real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: sh2o ! ruc @@ -1742,7 +1744,7 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in write (0,*)'tskin_wat(ipr) =', tskin_wat(ipr) write (0,*)'vtype(ipr) =', ipr, vtype(ipr) write (0,*)'stype(ipr) =', ipr, stype(ipr) - write (0,*)'its,ite,jts,jte =',its,ite,jts,jte + write (0,*)'its,ite,jts,jte =', its,ite,jts,jte endif @@ -1753,14 +1755,14 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in tbot(i,j) = tg3(i) ivgtyp(i,j) = vtype(i) isltyp(i,j) = stype(i) - if (landfrac(i) > 0. .or. fice(i) > 0.) then + if (landfrac(i) > zero .or. fice(i) > zero) then !-- land or ice tsk(i,j) = tskin_lnd(i) - landmask(i,j)=1. + landmask(i,j)=one else !-- water tsk(i,j) = tskin_wat(i) - landmask(i,j)=0. + landmask(i,j)=zero endif ! land(i) enddo @@ -1772,30 +1774,30 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in do i=its,ite ! i = horizontal loop st_input(i,1,j)=tsk(i,j) - sm_input(i,1,j)=0. + sm_input(i,1,j)=zero !--- initialize smcwlt2 and smcref2 with Noah values - if(landfrac(i) > 0.) then + if(landfrac(i) > zero) then smcref2 (i) = REFSMCnoah(stype(i)) smcwlt2 (i) = WLTSMCnoah(stype(i)) else - smcref2 (i) = 1. - smcwlt2 (i) = 0. + smcref2 (i) = one + smcwlt2 (i) = zero endif do k=1,lsoil st_input(i,k+1,j)=stc(i,k) ! convert volumetric soil moisture to SWI (soil wetness index) - if(landfrac(i) > 0. .and. swi_init) then - sm_input(i,k+1,j)=min(1.,max(0.,(smc(i,k) - smcwlt2(i))/ & + if(landfrac(i) > zero .and. swi_init) then + sm_input(i,k+1,j)=min(one,max(zero,(smc(i,k) - smcwlt2(i))/ & (smcref2(i) - smcwlt2(i)))) else sm_input(i,k+1,j)=smc(i,k) endif enddo do k=lsoil+2,lsoil_ruc * 3 - st_input(i,k,j)=0. - sm_input(i,k,j)=0. + st_input(i,k,j)=zero + sm_input(i,k,j)=zero enddo enddo ! i - horizontal loop @@ -1821,7 +1823,7 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in do j=jts,jte do i=its,ite - if (landfrac(i) == 1.) then + if (landfrac(i) == one) then !-- land do k=1,lsoil_ruc ! convert from SWI to RUC volumetric soil moisture @@ -1837,7 +1839,7 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in else !-- ice or water do k=1,lsoil_ruc - soilm(i,k,j) = 1. + soilm(i,k,j) = one soiltemp(i,k,j) = dumt(i,k,j) enddo ! k endif ! land @@ -1862,20 +1864,20 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in do j=jts,jte do i=its,ite - if (landfrac(i) > 0.) then + if (landfrac(i) > zero) then ! initialize factor do k=1,lsoil_ruc - factorsm(k)=1. + factorsm(k)=one enddo ! RUC soil moisture bucket - smtotr(i,j)=0. + smtotr(i,j)=zero do k=1,lsoil_ruc -1 smtotr(i,j)=smtotr(i,j) + soilm(i,k,j) *dzs(k) enddo ! Noah soil moisture bucket - smtotn(i,j)=smc(i,1)*0.1 + smc(i,2)*0.2 + smc(i,3)*0.7 + smc(i,4)*1. + smtotn(i,j)=smc(i,1)*0.1_kind_phys + smc(i,2)*0.2_kind_phys + smc(i,3)*0.7_kind_phys + smc(i,4)*one if(debug_print) then if(i==ipr) then @@ -1887,16 +1889,16 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in ! RUC soil moisture correction to match Noah soil moisture bucket do k=1,lsoil_ruc-1 - soilm(i,k,j) = max(0.02,soilm(i,k,j)*smtotn(i,j)/(0.9*smtotr(i,j))) + soilm(i,k,j) = max(0.02_kind_phys,soilm(i,k,j)*smtotn(i,j)/(0.9_kind_phys*smtotr(i,j))) enddo if( soilm(i,2,j) > soilm(i,1,j) .and. soilm(i,3,j) > soilm(i,2,j)) then ! typical for daytime, no recent precip - factorsm(1) = 0.75 - factorsm(2) = 0.8 - factorsm(3) = 0.85 - factorsm(4) = 0.9 - factorsm(5) = 0.95 + factorsm(1) = 0.75_kind_phys + factorsm(2) = 0.8_kind_phys + factorsm(3) = 0.85_kind_phys + factorsm(4) = 0.9_kind_phys + factorsm(5) = 0.95_kind_phys endif do k=1,lsoil_ruc soilm(i,k,j) = factorsm(k) * soilm(i,k,j) @@ -1904,7 +1906,7 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in if(debug_print) then if(i==ipr) write (0,*)'after smois=',i,j,soilm(i,:,j) endif - smtotr(i,j) = 0. + smtotr(i,j) = zero do k=1,lsoil_ruc - 1 smtotr(i,j)=smtotr(i,j) + soilm(i,k,j) *dzs(k) enddo From 3105170f4a62487a4179034d7fa1bfc5341f521d Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 23 Mar 2023 19:42:16 +0000 Subject: [PATCH 20/28] Changes related to kind_phys. --- physics/sfc_diag.f | 53 +++++++++++++++++++++++----------------------- 1 file changed, 27 insertions(+), 26 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index be648bd61..7a3defa62 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -30,9 +30,14 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & & f10m,u10m,v10m,t2m,q2m,dpt2m,errmsg,errflg & & ) ! - use machine , only : kind_phys + use machine , only : kind_phys, kind_dbl_prec use funcphys, only : fpvs + use physcons, only : con_t0c implicit none + + real (kind_phys), parameter :: zero = 0._kind_dbl_prec + real (kind_phys), parameter :: one = 1._kind_dbl_prec + real (kind_phys), parameter :: qmin = 1.0e-8_kind_dbl_prec ! integer, intent(in) :: im, lsm, lsm_ruc logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. @@ -52,7 +57,6 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & ! locals ! logical :: debug_print - real(kind=kind_phys), parameter :: qmin=1.0e-8 real(kind=kind_phys) :: q1c, qv, tem, qv1, th2m, x2m, rho real(kind=kind_phys) :: dT, dQ, qsfcmr, qsfcprox, ff, fac, dz1 real(kind=kind_phys) :: t2_alt, q2_alt @@ -70,8 +74,8 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & errflg = 0 !-- - testptlat = 35.3 !41.02 !42.05 !39.0 !74.12 !29.5 - testptlon = 273.0 !284.50 !286.75 !280.6 !164.0 !283.0 + testptlat = 35.3_kind_phys + testptlon = 273.0_kind_phys !-- debug_print = .false. ! @@ -87,23 +91,19 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & do i = 1, im f10m(i) = fm10(i) / fm(i) -! f10m(i) = min(f10m(i),1.) u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) fhi = fh2(i) / fh(i) -! t2m(i) = tskin(i)*(1. - fhi) + t1(i) * prslki(i) * fhi -! sig2k = 1. - (grav+grav) / (cp * t2m(i)) -! t2m(i) = t2m(i) * sig2k - wrk = 1.0 - fhi + wrk = one - fhi - thcon = (1.e5/ps(i))**con_rocp + thcon = (1.e5_kind_dbl_prec/ps(i))**con_rocp !-- make sure 1st level q is not higher than saturated value qss = fpvs(t1(i)) qss = eps * qss / (ps(i) + epsm1 * qss) q1c = min(q1(i),qss) ! lev 1 spec. humidity - qv1 = q1c / (1. - q1c) ! lev 1 mixing ratio - qsfcmr = qsurf(i)/(1. - qsurf(i)) ! surface mixing ratio + qv1 = q1c / (one - q1c) ! lev 1 mixing ratio + qsfcmr = qsurf(i)/(one - qsurf(i)) ! surface mixing ratio chs = cdq(i) * wind(i) cqs = chs chs2 = ust(i)*con_karman/fh2(i) @@ -118,7 +118,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & else ! Use potential temperature referenced to 1000 hPa t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp endif - if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m + if(evap(i) >= zero) then ! for evaporation>0, use inferred qsurf to deduce q2m q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi else ! for dew formation, use saturated q at tskin qss = fpvs(tskin(i)) @@ -136,7 +136,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & t2m(i) = th2m/thcon x2m = max(qmin,qsfcprox - evap(i)/cqs2) ! mix. ratio - q2m(i) = x2m/(1. + x2m) ! spec. humidity + q2m(i) = x2m/(one + x2m) ! spec. humidity endif ! flux method if(diag_log) then @@ -144,24 +144,24 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & dT = t1(i) - tskin(i) dQ = qv1 - qsfcmr dz1= zf(i) ! level of atm. forcing - IF (dT > 0.) THEN - ff = MIN(MAX(1.-dT/10.,0.01), 1.0) + IF (dT > zero) THEN + ff = MIN(MAX(one-dT/10._kind_phys,0.01_kind_phys), one) !for now, set zt = 0.05 - fac = LOG((2. + .05)/(0.05 + ff))/ & - & LOG((dz1 + .05)/(0.05 + ff)) + fac = LOG((2._kind_phys + .05_kind_phys)/(0.05_kind_phys + & + & ff))/LOG((dz1 + .05_kind_phys)/(0.05_kind_phys + ff)) T2_alt = tskin(i) + fac * dT ELSE !no alternatives (yet) for unstable conditions T2_alt = t2m(i) ENDIF - IF (dQ > 0.) THEN - ff = MIN(MAX(1.-dQ/0.003,0.01), 1.0) + IF (dQ > zero) THEN + ff = MIN(MAX(one-dQ/0.003_kind_phys,0.01_kind_phys), one) !-- for now, set zt = 0.05 - fac = LOG((2. + .05)/(0.05 + ff))/ & - & LOG((dz1 + .05)/(0.05 + ff)) + fac = LOG((2._kind_phys + .05_kind_phys)/(0.05_kind_phys + & + & ff))/LOG((dz1 + .05_kind_phys)/(0.05_kind_phys + ff)) Q2_alt = qsfcmr + fac * dQ ! mix. ratio - Q2_alt = Q2_alt/(1. + Q2_alt) ! spec. humidity + Q2_alt = Q2_alt/(one + Q2_alt) ! spec. humidity ELSE !no alternatives (yet) for unstable conditions Q2_alt = q2m(i) @@ -190,14 +190,15 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & ! This prevents unrealistic values when QFX is not mostly surface ! flux because calculation is based on surface flux only. ! Problems occurred in transition periods and weak winds and vegetation source - q2m(i) = min(q2m(i),1.05*q1c) ! works if qsurf > q1c, evaporation + q2m(i) = min(q2m(i),1.05_kind_dbl_prec*q1c) ! works if qsurf > q1c, evaporation endif !-- Compute dew point, using vapor pressure qv = max(qmin,(q2m(i)/(1.-q2m(i)))) - tem = max(ps(i) * qv/( eps - epsm1 *qv), 1.e-8) - dpt2m(i) = 243.5/( ( 17.67 / log(tem/611.2) ) - 1.) + 273.14 + tem = max(ps(i) * qv/( eps - epsm1 *qv), qmin) + dpt2m(i) = 243.5_kind_dbl_prec/( ( 17.67_kind_dbl_prec / & + & log(tem/611.2_kind_dbl_prec) ) - one) + con_t0c dpt2m(i) = min(dpt2m(i),t2m(i)) From 6572200899f170d64fbdbd6fabd23da69f31c95b Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 23 Mar 2023 21:40:29 +0000 Subject: [PATCH 21/28] Moved RUC LSM options to namelist parameters. Also, some clean-up of print statements. --- physics/lsm_ruc.F90 | 8 ++- physics/lsm_ruc.meta | 28 +++++++++ physics/module_sf_ruclsm.F90 | 114 +++++++++++++++++++++++------------ 3 files changed, 110 insertions(+), 40 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index cec87e689..b4b357f36 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -326,7 +326,8 @@ subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & & imp_physics_nssl, do_mynnsfclay, & - & exticeden, lsoil_ruc, lsoil, nlcat, nscat, & + & exticeden, lsoil_ruc, lsoil, mosaic_lu, mosaic_soil, & + & isncond_opt, isncovr_opt, nlcat, nscat, & & rdlai, xlat_d, xlon_d, & & oro, sigma, zs, t1, q1, qc, stype, vtype, vegtype_frac, & & soiltype_frac, sigmaf, laixy, & @@ -371,6 +372,7 @@ subroutine lsm_ruc_run & ! inputs ! --- input: integer, intent(in) :: me, master integer, intent(in) :: im, nlev, iter, lsoil_ruc, lsoil, kdt, isot, ivegsrc + integer, intent(in) :: mosaic_lu, mosaic_soil, isncond_opt, isncovr_opt integer, intent(in) :: nlcat, nscat integer, intent(in) :: lsm_ruc, lsm integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, & @@ -1154,6 +1156,8 @@ subroutine lsm_ruc_run & ! inputs & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_lnd(i,j), sfcems_lnd(i,j), chklowq(i,j), & & chs_lnd(i,j), flqc_lnd(i,j), flhc_lnd(i,j), rhonewsn_ex(i), & +! --- snow model options + & mosaic_lu, mosaic_soil, isncond_opt, isncovr_opt, & ! --- input/outputs: & wet(i,j), cmc(i,j), shdfac(i,j), alb_lnd(i,j), znt_lnd(i,j), & & z0_lnd(i,j), snoalb1d_lnd(i,j), albbck_lnd(i,j), & @@ -1438,6 +1442,8 @@ subroutine lsm_ruc_run & ! inputs & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_ice(i,j), sfcems_ice(i,j), chklowq(i,j), & & chs_ice(i,j), flqc_ice(i,j), flhc_ice(i,j), rhonewsn_ex(i), & +! --- snow model options + & mosaic_lu, mosaic_soil, isncond_opt, isncovr_opt, & ! --- input/outputs: & wet_ice(i,j), cmc(i,j), shdfac(i,j), alb_ice(i,j), & & znt_ice(i,j), z0_ice(i,j), snoalb1d_ice(i,j), & diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 38ebbcd67..57bf0b3cf 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -655,6 +655,34 @@ dimensions = () type = integer intent = in +[mosaic_lu] + standard_name = control_for_fractional_landuse_in_ruc_land_surface_scheme + long_name = control for use of fractional landuse info in RUC land surface model + units = flag + dimensions = () + type = integer + intent = in +[mosaic_soil] + standard_name = control_for_fractional_soil_in_ruc_land_surface_scheme + long_name = control for use of fractional soil info in RUC land surface model + units = flag + dimensions = () + type = integer + intent = in +[isncond_opt] + standard_name = control_for_soil_thermal_conductivity_option_in_ruc_lsm + long_name = control for soil thermal conductivity option in RUC land surface model + units = flag + dimensions = () + type = integer + intent = in +[isncovr_opt] + standard_name = control_for_snow_cover_fraction_option_in_ruc_lsm + long_name = control for snow cover fraction option in RUC land surface model + units = flag + dimensions = () + type = integer + intent = in [nlcat] standard_name = number_of_vegetation_categories long_name = number of vegetation categories diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 66f4cb660..850e3ee5e 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -37,11 +37,10 @@ MODULE module_sf_ruclsm real (kind_phys), parameter :: one = 1._kind_dbl_prec !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 - integer, parameter :: isncond_opt = 1 - + !integer, parameter :: isncond_opt = 1 !-- Snow fraction options !-- option 1: original formulation using threshold snow depth to compute snow fraction - integer, parameter :: isncovr_opt = 1 + !integer, parameter :: isncovr_opt = 1 !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L., 2007,JGR,DOI:10.1029/2007JD008674. !integer, parameter :: isncovr_opt = 2 !-- option 3: the tanh formulation from Niu,G.-Y.,and Yang,Z with @@ -93,7 +92,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & rhosnf,precipfr,exticeden, hgt,stdev, & Z3D,P8W,T3D,QV3D,QC3D,RHO3D,EMISBCK, & GLW,GSWdn,GSW,EMISS,CHKLOWQ, CHS, & - FLQC,FLHC,rhonewsn_ex,MAVAIL,CANWAT,VEGFRA, & + FLQC,FLHC,rhonewsn_ex,mosaic_lu, & + mosaic_soil,isncond_opt,isncovr_opt, & + MAVAIL,CANWAT,VEGFRA, & ALB,ZNT,Z0,SNOALB,ALBBCK,LAI, & landusef, nlcat, soilctop, nscat, & QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, & @@ -197,6 +198,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & real (kind_phys), INTENT(IN ) :: DT LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden INTEGER, INTENT(IN ) :: NLCAT, NSCAT + INTEGER, INTENT(IN ) :: mosaic_lu,mosaic_soil + INTEGER, INTENT(IN ) :: isncond_opt,isncovr_opt INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte @@ -692,10 +695,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & NZS1=NZS-1 !----- IF (debug_print ) THEN - if (abs(xlat-testptlat).lt.0.2 .and. & - abs(xlon-testptlon).lt.0.2)then print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf - endif ENDIF DO K=2,NZS1 @@ -739,6 +739,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & if(init) then if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then + print*,' lat,lon=',xlat,xlon print *,'before SOILVEGIN - z0,znt',i,z0(i,j),znt(i,j) print *,'ILAND, ISOIL =',i,iland,isoil endif @@ -747,7 +748,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & !> - Call soilvegin() to initialize soil and surface properties !-- land or ice - CALL SOILVEGIN ( debug_print, & + CALL SOILVEGIN ( debug_print, mosaic_lu, mosaic_soil, & soilfrac,nscat,shdmin(i,j),shdmax(i,j), & NLCAT,ILAND,ISOIL,iswater,MYJ,IFOREST,lufrac,VEGFRA(I,J), & EMISSL(I,J),PC(I,J),MSNF(I,J),FACSNF(I,J), & @@ -761,6 +762,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & if(init)then if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then + print*,' lat,lon=',xlat,xlon print *,'after SOILVEGIN - z0,znt,lai',i,z0(i,j),znt(i,j),lai(i,j) print *,'NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J)', & NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),i,j @@ -808,10 +810,14 @@ SUBROUTINE LSMRUC(xlat,xlon, & !----- IF (debug_print ) THEN + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print*,' lat,lon=',xlat,xlon print *,' ZNT, LAI, VEGFRA, SAT, EMIS, PC --->', & ZNT(I,J),LAI(I,J),VEGFRA(I,J),SAT,EMISSL(I,J),PC(I,J) print *,' ZS, ZSMAIN, ZSHALF, CONFLX, CN, SAT, --->', zs,zsmain,zshalf,conflx,cn,sat print *,'NROOT, meltfactor, iforest, ivgtyp, i,j ', nroot,meltfactor,iforest,ivgtyp(I,J),I,J + endif ENDIF IF((XLAND(I,J)-1.5).GE.0._kind_phys)THEN @@ -841,8 +847,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & ENDDO IF (debug_print ) THEN - PRINT*,' water point, I=',I, & - 'J=',J, 'SOILT=', SOILT(i,j) + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + PRINT*,' water point' + print*,' lat,lon=',xlat,xlon,'SOILT=', SOILT(i,j) + endif ENDIF ELSE @@ -857,8 +866,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & IF(SEAICE(I,J).GT.0.5_kind_phys)THEN !-- Sea-ice case IF (debug_print ) THEN - PRINT*,' sea-ice at water point, I=',I, & - 'J=',J + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + PRINT*,' sea-ice at water point' + print*,' lat,lon=',xlat,xlon + endif ENDIF ILAND = isice if(nscat == 9) then @@ -909,6 +921,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then + print*,' lat,lon=',xlat,xlon print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO print *,'CONFLX =',CONFLX @@ -934,6 +947,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & xlat, xlon, testptlat, testptlon, & !--- input variables nzs,nddzs,nroot,meltfactor, & !added meltfactor + isncond_opt,isncovr_opt, & iland,isoil,ivgtyp(i,j),isltyp(i,j), & PRCPMS, NEWSNMS,SNWE,SNHEI,SNOWFRAC, & exticeden,RHOSN,RHONEWSN_ex(I),RHONEWSN, & @@ -973,23 +987,29 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! croplands. ! This change violates LSM moisture budget, but ! can be considered as a compensation for irrigation not included into LSM. - -!tgs - turn off "irrigation" while there is no fractional landuse and LAI -!climatology. - if(1==2) then +!tgs - "irrigation" uses fractional landuse, therefore mosaic_lu=1. + if(mosaic_lu == 1) then IF (lufrac(crop) > zero .and. lai(i,j) > 1.1_kind_phys) THEN ! cropland do k=1,nroot - cropsm=1.1_kind_phys*wilt - qmin + cropsm=1.1_kind_phys*wilt - qmin if(soilm1d(k) < cropsm*lufrac(crop)) then IF (debug_print ) THEN -print * ,'Soil moisture is below wilting in cropland category at time step',ktau & - ,'i,j,lufrac(crop),k,soilm1d(k),wilt,cropsm', & - i,j,lufrac(crop),k,soilm1d(k),wilt,cropsm + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then +print * ,'Soil moisture is below wilting in cropland category at time step',ktau + print*,' lat,lon=',xlat,xlon & + ,'lufrac(crop),k,soilm1d(k),wilt,cropsm', & + lufrac(crop),k,soilm1d(k),wilt,cropsm + endif ENDIF - soilm1d(k) = cropsm*lufrac(crop) + soilm1d(k) = cropsm*lufrac(crop) IF (debug_print ) THEN - print * ,'Added soil water to cropland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print*,' lat,lon=',xlat,xlon + print * ,'Added soil water to cropland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) + endif ENDIF endif enddo @@ -997,21 +1017,30 @@ SUBROUTINE LSMRUC(xlat,xlon, & ELSEIF (ivgtyp(i,j) == natural .and. lai(i,j) > 0.7) THEN ! grassland: assume that 40% of grassland is irrigated cropland do k=1,nroot - cropsm=1.2_kind_phys*wilt - qmin + cropsm=1.2_kind_phys*wilt - qmin if(soilm1d(k) < cropsm*lufrac(natural)*0.4) then IF (debug_print ) THEN -print * ,'Soil moisture is below wilting in mixed grassland/cropland category at time step',ktau & - ,'i,j,lufrac(natural),k,soilm1d(k),wilt', & - i,j,lufrac(natural),k,soilm1d(k),wilt + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then +print * ,'Soil moisture is below wilting in mixed grassland/cropland category at time step',ktau + print*,' lat,lon=',xlat,xlon, & + 'lufrac(natural),k,soilm1d(k),wilt', & + lufrac(natural),k,soilm1d(k),wilt + endif ENDIF - soilm1d(k) = cropsm * lufrac(natural)*0.4_kind_phys + soilm1d(k) = cropsm * lufrac(natural)*0.4_kind_phys + IF (debug_print ) THEN - print * ,'Added soil water to grassland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print*,' lat,lon=',xlat,xlon + print * ,'Added soil water to grassland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) + endif ENDIF endif enddo ENDIF - endif ! 1==2 + endif ! mosaic_lu !*** DIAGNOSTICS !--- available and maximum soil moisture content in the soil @@ -1046,7 +1075,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & do k=1,nzs -! soilmois(i,k,j) = soilm1d(k) soilmois(i,k,j) = soilm1d(k) + qmin sh2o (i,k,j) = min(soiliqw(k) + qmin,soilmois(i,k,j)) tso(i,k,j) = tso1d(k) @@ -1102,7 +1130,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & !tgs - SMF.NE.0. when there is phase change in the top soil layer ! The heat of soil water freezing/thawing is not computed explicitly ! and is responsible for the residual in the energy budget. -! endif !--- SNOWC snow cover flag SNOWC(I,J)=SNOWFRAC @@ -1157,9 +1184,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then - print *,'LAND, i,j,tso1d,soilm1d,soilt - end of time step', & - i,j,tso1d,soilm1d,soilt(i,j) - print *,'LAND, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + print *,'LAND, i,tso1d,soilm1d,soilt - end of time step', & + i,tso1d,soilm1d,soilt(i,j) + print *,'LAND, QFX, HFX after SFCTMP', i,lh(i,j),hfx(i,j) endif ENDIF @@ -1187,6 +1214,7 @@ END SUBROUTINE LSMRUC SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input variables xlat,xlon,testptlat,testptlon, & nzs,nddzs,nroot,meltfactor, & + isncond_opt,isncovr_opt, & ILAND,ISOIL,IVGTYP,ISLTYP,PRCPMS, & NEWSNMS,SNWE,SNHEI,SNOWFRAC, & exticeden,RHOSN,RHONEWSN_ex,RHONEWSN,RHOSNFALL, & @@ -1215,6 +1243,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: isice,i,j,nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) + integer, intent(in ) :: isncond_opt,isncovr_opt real (kind_phys), INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon real (kind_phys), INTENT(IN ) :: testptlat,testptlon @@ -1923,6 +1952,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif CALL SNOWSOIL (debug_print,xlat,xlon,testptlat,testptlon, & !--- input variables i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & + isncond_opt,isncovr_opt, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & RHOSN,PATM,QVATM,QCATM, & @@ -1951,8 +1981,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia snfr=snowfrac endif - CALL SNOWSEAICE (debug_print,xlat,xlon, & + CALL SNOWSEAICE (debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & + isncond_opt,isncovr_opt, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & RHOSN,PATM,QVATM,QCATM, & @@ -3177,6 +3208,7 @@ END SUBROUTINE SICE SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & testptlat,testptlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & !--- input variables + isncond_opt,isncovr_opt, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC, & RHOSN, & @@ -3271,7 +3303,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - INTEGER, INTENT(IN ) :: i,j,isoil + INTEGER, INTENT(IN ) :: i,j,isoil,isncond_opt,isncovr_opt real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & RAINF,NEWSNOW,RHONEWSN, & @@ -3632,6 +3664,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & + isncond_opt,isncovr_opt, & snwe,snwepr,snhei,newsnow,snowfrac,snhei_crit, & beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor PRCPMS,RAINF, & @@ -3844,6 +3877,7 @@ END SUBROUTINE SNOWSOIL !! temperature, snow and ice temperatures, snow depth and snow melt. SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & + isncond_opt,isncovr_opt, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,snowfrac, & RHOSN,PATM,QVATM,QCATM, & @@ -3871,7 +3905,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: ktau,nzs , & nddzs !nddzs=2*(nzs-2) - INTEGER, INTENT(IN ) :: i,j,isoil + INTEGER, INTENT(IN ) :: i,j,isoil,isncond_opt,isncovr_opt real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & RAINF,NEWSNOW,RHONEWSN, & @@ -4961,6 +4995,7 @@ END SUBROUTINE SOILTEMP SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & testptlat,testptlon,i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & + isncond_opt,isncovr_opt, & snwe,snwepr,snhei,newsnow,snowfrac,snhei_crit, & beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor PRCPMS,RAINF, & @@ -5032,7 +5067,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - INTEGER, INTENT(IN ) :: i,j,iland,isoil + INTEGER, INTENT(IN ) :: i,j,iland,isoil,isncond_opt,isncovr_opt real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & @@ -6708,7 +6743,7 @@ END SUBROUTINE VILKA !! This subroutine computes effective land and soil parameters in the !! grid cell from the weighted contribution of soil and land categories !! represented in the grid cell. - SUBROUTINE SOILVEGIN ( debug_print, & + SUBROUTINE SOILVEGIN ( debug_print,mosaic_lu,mosaic_soil, & soilfrac,nscat,shdmin, shdmax, & NLCAT,IVGTYP,ISLTYP,iswater,MYJ, & IFOREST,lufrac,vegfrac,EMISS,PC, & @@ -6743,6 +6778,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & integer, parameter :: ilsnow=99 LOGICAL, INTENT(IN ) :: debug_print + INTEGER, INTENT(IN ) :: mosaic_lu, mosaic_soil INTEGER, INTENT(IN ) :: nlcat, nscat, iswater, i, j !--- soiltyp classification according to STATSGO(nclasses=16) From 98426eab3e6f275e1d947e85c38dbd53a65a7a5d Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 23 Mar 2023 22:13:36 +0000 Subject: [PATCH 22/28] Surface_snow_amount_vardens_over_land is changed to surface_snow_amount_vardens_over_land Same for ice. --- physics/lsm_ruc.meta | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 57bf0b3cf..f7a0dd5f0 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -1442,7 +1442,7 @@ kind = kind_phys intent = inout [snowfallac_lnd] - standard_name = surface_snow_amount_vardens_over_land + standard_name = surface_snow_amount_assuming_variable_snow_density_over_land long_name = run-total snow accumulation on the ground with variable snow density over land units = kg m-2 dimensions = (horizontal_loop_extent) @@ -1602,7 +1602,7 @@ kind = kind_phys intent = in [snowfallac_ice] - standard_name = surface_snow_amount_vardens_over_ice + standard_name = surface_snow_amount_assuming_variable_snow_density_over_ice long_name = run-total snow accumulation on the ground with variable snow density over ice units = kg m-2 dimensions = (horizontal_loop_extent) From 1f2b01c43129c5925b518420f7dcc2bed317f5b6 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 23 Mar 2023 22:15:08 +0000 Subject: [PATCH 23/28] Active = (control_for_land_surface_scheme == identifier_for_ruc_land_surface_scheme) is removed. --- physics/lsm_ruc.meta | 1 - 1 file changed, 1 deletion(-) diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index f7a0dd5f0..df2b11600 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -1665,7 +1665,6 @@ type = real kind = kind_phys intent = inout - active = (control_for_land_surface_scheme == identifier_for_ruc_land_surface_scheme) [sbsno] standard_name = snow_deposition_sublimation_upward_latent_heat_flux long_name = latent heat flux from snow depo/subl From 48e092fb529cd8fed83db3bba44ac3d13b6da909 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Fri, 24 Mar 2023 19:06:26 +0000 Subject: [PATCH 24/28] Updates to the MYNN surface-layer scheme --- physics/module_sf_mynn.F90 | 864 ++++++++++++++++++------------------ physics/mynnsfc_wrapper.F90 | 56 +-- 2 files changed, 443 insertions(+), 477 deletions(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 33678fa3a..c60247cf6 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -61,62 +61,50 @@ MODULE module_sf_mynn !NOTE: This code was primarily tested in combination with the RUC LSM. ! Performance with the Noah (or other) LSM is relatively unknown. !------------------------------------------------------------------- -!For WRF -! USE module_model_constants, only: & -! & p1000mb, ep_2 -! -!For non-WRF - use physcons, only : cp => con_cp, & - & g => con_g, & - & r_d => con_rd, & - & r_v => con_rv, & - & cpv => con_cvap, & - & cliq => con_cliq, & - & Cice => con_csol, & - & rcp => con_rocp, & - & XLV => con_hvap, & - & XLF => con_hfus, & - & EP_1 => con_fvirt, & - & EP_2 => con_eps - -!use subroutines from sfc_diff: -! USE sfc_diff, only: znot_t_v6, znot_t_v7, znot_m_v6, znot_m_v7 - -!use kind=kind_phys for real-types +!Include host model constants + use physcons, only : cp => con_cp, & !=7*Rd/2 + & grav => con_g, & !=9.81 + & Rd => con_rd, & !=287. + & Rv => con_rv, & !=461.6 +! & cpv => con_cvap, & !=4*Rv + & rovcp => con_rocp, & !=Rd/cp + & xlv => con_hvap, & !2.5e6 + & xlf => con_hfus, & !3.5e5 + & ep1 => con_fvirt, & !Rv/Rd - 1 + & ep2 => con_eps !Rd/Rv + +!use kind_phys for real-types use machine , only : kind_phys !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- -!For non-WRF -! REAL(kind=kind_phys), PARAMETER :: g = 9.81 -! REAL(kind=kind_phys), PARAMETER :: r_d = 287. -! REAL(kind=kind_phys), PARAMETER :: cp = 7.*r_d/2. -! REAL(kind=kind_phys), PARAMETER :: r_v = 461.6 -! REAL(kind=kind_phys), PARAMETER :: cpv = 4.*r_v -! REAL(kind=kind_phys), PARAMETER :: rcp = r_d/cp -! REAL(kind=kind_phys), PARAMETER :: XLV = 2.5E6 -! REAL(kind=kind_phys), PARAMETER :: XLF = 3.50E5 - REAL(kind=kind_phys), PARAMETER :: p1000mb = 100000. -! REAL(kind=kind_phys), PARAMETER :: EP_2 = r_d/r_v - - REAL(kind=kind_phys), PARAMETER :: xlvcp=xlv/cp, ep_3=1.-ep_2 - REAL(kind=kind_phys), PARAMETER :: wmin=0.1 ! Minimum wind speed - REAL(kind=kind_phys), PARAMETER :: VCONVC=1.25 - REAL(kind=kind_phys), PARAMETER :: onethird = 1./3. - REAL(kind=kind_phys), PARAMETER :: sqrt3 = 1.7320508075688773 - REAL(kind=kind_phys), PARAMETER :: atan1 = 0.785398163397 !in radians - REAL(kind=kind_phys), PARAMETER :: log01=log(0.01) - REAL(kind=kind_phys), PARAMETER :: log05=log(0.05) - REAL(kind=kind_phys), PARAMETER :: log07=log(0.07) - REAL(kind=kind_phys), PARAMETER :: SNOWZ0=0.011 - REAL(kind=kind_phys), PARAMETER :: COARE_OPT=3.0 ! 3.0 or 3.5 +!Drive and/or define more constant: + real(kind_phys), parameter :: ep3 = 1.-ep2 + real(kind_phys), parameter :: g_inv = 1.0/grav + real(kind_phys), parameter :: rvovrd = Rv/Rd + real(kind_phys), parameter :: wmin = 0.1 ! Minimum wind speed + real(kind_phys), parameter :: karman = 0.4 + real(kind_phys), parameter :: SVP1 = 0.6112 + real(kind_phys), parameter :: SVP2 = 17.67 + real(kind_phys), parameter :: SVP3 = 29.65 + real(kind_phys), parameter :: SVPT0 = 273.15 + real(kind_phys), parameter :: VCONVC = 1.25 + real(kind_phys), parameter :: onethird = 1./3. + real(kind_phys), parameter :: sqrt3 = 1.7320508075688773 + real(kind_phys), parameter :: atan1 = 0.785398163397 !in radians + real(kind_phys), parameter :: log01 = log(0.01) + real(kind_phys), parameter :: log05 = log(0.05) + real(kind_phys), parameter :: log07 = log(0.07) + real(kind_phys), parameter :: SNOWZ0 = 0.011 + real(kind_phys), parameter :: COARE_OPT = 3.0 ! 3.0 or 3.5 + !For debugging purposes: INTEGER, PARAMETER :: debug_code = 0 !0: no extra ouput !1: check input !2: everything - heavy I/O - REAL(kind=kind_phys), DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab, & + REAL(kind_phys), DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab, & psih_stab,psih_unstab CONTAINS @@ -129,8 +117,6 @@ SUBROUTINE SFCLAY_mynn( & U3D,V3D,T3D,QV3D,P3D,dz8w, & !in th3d,pi3d,qc3d, & !in PSFCPA,PBLH,MAVAIL,XLAND,DX, & !in - CP,G,ROVCP,R,XLV, & !in - SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & !in ISFFLX,isftcflx,lsm,lsm_ruc, & !in compute_flux,compute_diag, & !in iz0tlnd,psi_opt, & !in @@ -138,6 +124,7 @@ SUBROUTINE SFCLAY_mynn( & z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) itimestep,iter,flag_iter, & !in + flag_restart, & !in wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -177,9 +164,9 @@ SUBROUTINE SFCLAY_mynn( & !-- P3D 3D pressure (Pa) !-- dz8w 3D dz between full levels (m) !-- CP heat capacity at constant pressure for dry air (J/kg/K) -!-- G acceleration due to gravity (m/s^2) +!-- grav acceleration due to gravity (m/s^2) !-- ROVCP R/CP -!-- R gas constant for dry air (J/kg/K) +!-- Rd gas constant for dry air (J/kg/K) !-- XLV latent heat of vaporization for water (J/kg) !-- PSFCPA surface pressure (Pa) !-- ZNT roughness length (m) @@ -269,26 +256,24 @@ SUBROUTINE SFCLAY_mynn( & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte INTEGER, INTENT(IN) :: itimestep,iter - REAL(kind=kind_phys), INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 - REAL(kind=kind_phys), INTENT(IN) :: EP1,EP2,KARMAN - REAL(kind=kind_phys), INTENT(IN) :: CP,G,ROVCP,R,XLV !,DX !NAMELIST/CONFIGURATION OPTIONS: - INTEGER, INTENT(IN) :: ISFFLX, LSM, LSM_RUC - INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt - logical, intent(in) :: compute_flux,compute_diag + integer, intent(in) :: ISFFLX, LSM, LSM_RUC + INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND + INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt + logical, intent(in) :: compute_flux,compute_diag integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) + logical, intent(in) :: flag_restart !Input data integer, dimension(ims:ime), intent(in) :: vegtype - real(kind=kind_phys), dimension(ims:ime), intent(in) :: & + real(kind_phys), dimension(ims:ime), intent(in) :: & & sigmaf,shdmax,z0pert,ztpert !=================================== ! 3D VARIABLES !=================================== - REAL(kind=kind_phys), DIMENSION( ims:ime, kms:kme ) , & + REAL(kind_phys), DIMENSION( ims:ime, kms:kme ) , & INTENT(IN ) :: dz8w, & QV3D, & P3D, & @@ -298,24 +283,24 @@ SUBROUTINE SFCLAY_mynn( & th3d,pi3d !GJF: This array must be assumed-shape since it is conditionally-allocated - REAL(kind=kind_phys), DIMENSION( :,: ), & + REAL(kind_phys), DIMENSION( :,: ), & INTENT(IN) :: pattern_spp_sfc !=================================== ! 2D VARIABLES !=================================== - REAL(kind=kind_phys), DIMENSION( ims:ime ) , & + REAL(kind_phys), DIMENSION( ims:ime ) , & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & PSFCPA, & DX - REAL(kind=kind_phys), DIMENSION( ims:ime ) , & + REAL(kind_phys), DIMENSION( ims:ime ) , & INTENT(OUT ) :: U10,V10, & TH2,T2,Q2 - REAL(kind=kind_phys), DIMENSION( ims:ime ) , & + REAL(kind_phys), DIMENSION( ims:ime ) , & INTENT(INOUT) :: HFLX,HFX, & QFLX,QFX, & LH, & @@ -338,12 +323,12 @@ SUBROUTINE SFCLAY_mynn( & LOGICAL, DIMENSION( ims:ime ), INTENT(IN) :: & & wet, dry, icy, flag_iter - REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(IN) :: & + REAL(kind_phys), DIMENSION( ims:ime ), INTENT(IN) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & & snowh_wat, snowh_lnd, snowh_ice - REAL(kind=kind_phys), DIMENSION( ims:ime), INTENT(INOUT) :: & + REAL(kind_phys), DIMENSION( ims:ime), INTENT(INOUT) :: & & ZNT_wat, ZNT_lnd, ZNT_ice, & & UST_wat, UST_lnd, UST_ice, & & cm_wat, cm_lnd, cm_ice, & @@ -364,12 +349,12 @@ SUBROUTINE SFCLAY_mynn( & !ADDITIONAL OUTPUT !JOE-begin - REAL(kind=kind_phys), DIMENSION( ims:ime ) :: qstar + REAL(kind_phys), DIMENSION( ims:ime ) :: qstar !JOE-end !=================================== ! 1D LOCAL ARRAYS !=================================== - REAL(kind=kind_phys), DIMENSION( its:ite ) :: U1D,V1D, & !level1 winds + REAL(kind_phys), DIMENSION( its:ite ) :: U1D,V1D, & !level1 winds U1D2,V1D2, & !level2 winds QV1D, & P1D, & @@ -377,7 +362,7 @@ SUBROUTINE SFCLAY_mynn( & dz8w1d, & !level 1 height dz2w1d !level 2 height - REAL(kind=kind_phys), DIMENSION( its:ite ) :: rstoch1D + REAL(kind_phys), DIMENSION( its:ite ) :: rstoch1D INTEGER :: I,J,K,itf,ktf !----------------------------------------------------------- @@ -388,11 +373,10 @@ SUBROUTINE SFCLAY_mynn( & IF (debug_code >= 1) THEN write(*,*)"======= printing of constants:" - write(*,*)"cp=", cp," g=", g - write(*,*)"Rd=", r_d," Rv=", r_v, " cpc=", cpv - write(*,*)"cliq=", cliq," cice=", Cice," rcp=", rcp - write(*,*)"xlv=", XLV," xlf=", XLF - write(*,*)"ep1=", EP_1, " ep2=", EP_2 + write(*,*)"cp=", cp," g=", grav + write(*,*)"Rd=", Rd," ep1=", ep1 + write(*,*)"xlv=", XLV," xlf=", XLF + write(*,*)"ep2=", ep2 ENDIF itf=ite !MIN0(ite,ide-1) @@ -420,11 +404,19 @@ SUBROUTINE SFCLAY_mynn( & IF (itimestep==1 .AND. iter==1) THEN DO i=its,ite - !Everything here is used before calculated - UST_WAT(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) - UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) - UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) - MOL(i)=0.0 + IF (.not. flag_restart) THEN + !Everything here is used before calculated + if (ust_wat(i) .lt. 1e-4 .or. ust_wat(i) .gt. 3.0) then + UST_WAT(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) + endif + if (ust_lnd(i) .lt. 1e-4 .or. ust_lnd(i) .gt. 3.0) then + UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) + endif + if (ust_ice(i) .lt. 1e-4 .or. ust_ice(i) .gt. 3.0) then + UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) + endif + MOL(i)=0.0 + ENDIF ! restart QFLX(i)=0. HFLX(i)=0. if ( LSM == LSM_RUC ) then @@ -444,14 +436,12 @@ SUBROUTINE SFCLAY_mynn( & J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, & U1D2,V1D2,dz2w1d, & PSFCPA,PBLH,MAVAIL,XLAND,DX, & - CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & - EP1,EP2,KARMAN, & ISFFLX,isftcflx,iz0tlnd,psi_opt, & compute_flux,compute_diag, & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) - itimestep,iter,lsm,lsm_ruc, & + itimestep,iter,flag_restart,lsm,lsm_ruc, & wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -492,14 +482,12 @@ END SUBROUTINE SFCLAY_MYNN SUBROUTINE SFCLAY1D_mynn(flag_iter, & J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,U1D2,V1D2,dz2w1d, & PSFCPA,PBLH,MAVAIL,XLAND,DX, & - CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & - EP1,EP2,KARMAN, & ISFFLX,isftcflx,iz0tlnd,psi_opt, & compute_flux,compute_diag, & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) - itimestep,iter,lsm,lsm_ruc, & + itimestep,iter,flag_restart,lsm,lsm_ruc, & wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -535,44 +523,43 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !------------------------------------------------------------------- ! SCALARS !----------------------------- - INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & J, itimestep, iter, lsm, lsm_ruc + LOGICAL, INTENT(IN) :: flag_restart - REAL(kind=kind_phys), PARAMETER :: XKA=2.4E-5 !molecular diffusivity - REAL(kind=kind_phys), PARAMETER :: PRT=1. !prandlt number - REAL(kind=kind_phys), PARAMETER :: snowh_thresh = 50. !mm - REAL(kind=kind_phys), INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0,EP1,EP2 - REAL(kind=kind_phys), INTENT(IN) :: KARMAN,CP,G,ROVCP,R,XLV !,DX + REAL(kind_phys), PARAMETER :: XKA=2.4E-5 !molecular diffusivity + REAL(kind_phys), PARAMETER :: PRT=1. !prandlt number + REAL(kind_phys), PARAMETER :: snowh_thresh = 50. !mm !----------------------------- ! NAMELIST OPTIONS !----------------------------- - INTEGER, INTENT(IN) :: ISFFLX - INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND - logical, intent(in) :: compute_flux,compute_diag - INTEGER, INTENT(IN) :: spp_sfc, psi_opt + integer, intent(in) :: ISFFLX + integer, optional, intent(in) :: ISFTCFLX, IZ0TLND + logical, intent(in) :: compute_flux,compute_diag + integer, intent(in) :: spp_sfc, psi_opt integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) !Input data integer, dimension(ims:ime), intent(in) :: vegtype - real(kind=kind_phys), dimension(ims:ime), intent(in) :: & - & sigmaf,shdmax,z0pert,ztpert + real(kind_phys), dimension(ims:ime), intent(in) :: & + & sigmaf,shdmax,z0pert,ztpert !----------------------------- ! 1D ARRAYS !----------------------------- - REAL(kind=kind_phys), DIMENSION( ims:ime ), & + REAL(kind_phys), DIMENSION( ims:ime ), & INTENT(IN) :: MAVAIL, & PBLH, & XLAND, & PSFCPA, & DX - REAL(kind=kind_phys), DIMENSION( its:ite ), & + REAL(kind_phys), DIMENSION( its:ite ), & INTENT(IN) :: U1D,V1D, & U1D2,V1D2, & QV1D,P1D, & @@ -580,10 +567,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & dz8w1d, & dz2w1d - REAL(kind=kind_phys), DIMENSION( ims:ime ), & + REAL(kind_phys), DIMENSION( ims:ime ), & INTENT(OUT) :: QFX,HFX, & RMOL - REAL(kind=kind_phys), DIMENSION( ims:ime ), & + REAL(kind_phys), DIMENSION( ims:ime ), & INTENT(INOUT) :: HFLX,QFLX, & LH,MOL, & QGH,QSFC, & @@ -602,12 +589,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & LOGICAL, DIMENSION( ims:ime ), INTENT(IN) :: & & wet, dry, icy, flag_iter - REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(in) :: & + REAL(kind_phys), DIMENSION( ims:ime ), INTENT(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & & snowh_wat, snowh_lnd, snowh_ice - REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(inout) :: & + REAL(kind_phys), DIMENSION( ims:ime ), INTENT(inout) :: & & ZNT_wat, ZNT_lnd, ZNT_ice, & & UST_wat, UST_lnd, UST_ice, & & cm_wat, cm_lnd, cm_ice, & @@ -622,18 +609,18 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & & QFLX_wat, QFLX_lnd, QFLX_ice, & & qsfc_wat, qsfc_lnd, qsfc_ice - REAL(kind=kind_phys), DIMENSION( its:ite ), & + REAL(kind_phys), DIMENSION( its:ite ), & & INTENT(IN) :: rstoch1D ! DIAGNOSTIC OUTPUT - REAL(kind=kind_phys), DIMENSION( ims:ime ), & + REAL(kind_phys), DIMENSION( ims:ime ), & & INTENT(OUT) :: U10, V10, & & TH2, T2, & & Q2 !-------------------------------------------- !JOE-additinal output - REAL(kind=kind_phys), DIMENSION( ims:ime ), & + REAL(kind_phys), DIMENSION( ims:ime ), & & INTENT(OUT) :: wstar, & & qstar !JOE-end @@ -645,7 +632,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !---------------------------------------------------------------- ! LOCAL VARS !---------------------------------------------------------------- - REAL(kind=kind_phys), DIMENSION(its:ite) :: & + REAL(kind_phys), DIMENSION(its:ite) :: & ZA, & !Height of lowest 1/2 sigma level(m) ZA2, & !Height of 2nd lowest 1/2 sigma level(m) THV1D, & !Theta-v at lowest 1/2 sigma (K) @@ -658,7 +645,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & PSIM10, & !M-O stability functions at z=10 m PSIH10, & !M-O stability functions at z=10 m WSPDI, & - GOVRTH, & !g/theta + GOVRTH, & !grav/theta PSFC, & !press at surface (Pa/1000) QSFCMR, & !qv at surface (mixing ratio, kg/kg) THCON, & !conversion from temp to theta @@ -681,12 +668,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & INTEGER :: N,I,K,L,yesno - REAL(kind=kind_phys) :: PL,E1,TABS - REAL(kind=kind_phys) :: WSPD_lnd, WSPD_ice, WSPD_wat - REAL(kind=kind_phys) :: DTHVDZ,DTHVM,VCONV,ZOL2,ZOL10,ZOLZA,ZOLZ0,ZOLZT - REAL(kind=kind_phys) :: DTG,DTTHX,PSIQ,PSIQ2,PSIQ10,PSIT10 - REAL(kind=kind_phys) :: FLUXC,VSGD - REAL(kind=kind_phys) :: restar,VISC,DQG,OLDUST,OLDTST + REAL(kind_phys) :: PL,E1,TABS + REAL(kind_phys) :: WSPD_lnd, WSPD_ice, WSPD_wat + REAL(kind_phys) :: DTHVDZ,DTHVM,VCONV,ZOL2,ZOL10,ZOLZA,ZOLZ0,ZOLZT + REAL(kind_phys) :: DTG,DTTHX,PSIQ,PSIQ2,PSIQ10,PSIT10 + REAL(kind_phys) :: FLUXC,VSGD + REAL(kind_phys) :: restar,VISC,DQG,OLDUST,OLDTST ! Initialize error-handling errflg = 0 @@ -711,7 +698,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) E1=SVP1*EXP(SVP2*(TSK_wat(I)-SVPT0)/(TSK_wat(i)-SVP3)) ENDIF - QSFC_wat(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_wat(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity QSFCMR_wat(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio IF(QSFC_wat(I)>1..or.QSFC_wat(I)<0.) print *,' QSFC_wat(I)',itimestep,i,QSFC_wat(I),TSK_wat(i) ENDIF @@ -729,7 +716,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) E1=SVP1*EXP(SVP2*(TABS-SVPT0)/(TABS-SVP3)) ENDIF - QSFC_lnd(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_lnd(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity QSFC_lnd(I)=0.5*(QSFC_lnd(I) + QSFC(I)) QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) !mixing ratio endif ! lsm @@ -738,7 +725,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (icy(i)) THEN TSK_ice(I) = tskin_ice(i) if( lsm == lsm_ruc) then - QSFCMR_ice(I)=QSFC_ice(I)/(1.-QSFC_ice(I)) !mixing ratio + QSFCMR_ice(I)=QSFC_ice(I)/(1.-QSFC_ice(I)) !mixing ratio else IF (TSK_ice(I) .LT. 273.15) THEN !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) @@ -748,7 +735,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) E1=SVP1*EXP(SVP2*(TSK_ice(I)-SVPT0)/(TSK_ice(i)-SVP3)) ENDIF - QSFC_ice(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_ice(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity QSFCMR_ice(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio endif ! lsm IF(QSFC_ice(I)>1..or.QSFC_ice(I)<0.) print *,' QSFC_ice(I)',itimestep,i,QSFC_ice(I),TSK_ice(i) @@ -767,7 +754,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) E1=SVP1*EXP(SVP2*(TSK_wat(I)-SVPT0)/(TSK_wat(i)-SVP3)) ENDIF - QSFC_wat(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_wat(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity ENDIF IF (dry(i).and.(QSFC_lnd(I)>1..or.QSFC_lnd(I)<0.)) then !print *,'bad QSFC_lnd(I)',itimestep,iter,i,QSFC_lnd(I),TSKin_lnd(I) @@ -780,7 +767,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) E1=SVP1*EXP(SVP2*(TABS-SVPT0)/(TABS-SVP3)) ENDIF - QSFC_lnd(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_lnd(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity QSFC_lnd(I)=0.5*(QSFC_lnd(I) + QSFC(I)) ENDIF IF (icy(i).and.(QSFC_ice(I)>1..or.QSFC_ice(I)<0.)) then @@ -793,7 +780,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) E1=SVP1*EXP(SVP2*(TSKin_ice(I)-SVPT0)/(TSKin_ice(i)-SVP3)) ENDIF - QSFC_ice(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_ice(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity ENDIF IF (wet(i)) QSFCMR_wat(I)=QSFC_wat(I)/(1.-QSFC_wat(I)) @@ -879,10 +866,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDDO DO I=its,ite - RHO1D(I)=P1D(I)/(R*TV1D(I)) !now using value calculated in sfc driver - ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level - ZA2(I)=dz8w1d(I) + 0.5*dz2w1d(I) !height of 2nd half-sigma level - GOVRTH(I)=G/TH1D(I) + RHO1D(I)=P1D(I)/(Rd*TV1D(I)) !now using value calculated in sfc driver + ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level + ZA2(I)=dz8w1d(I) + 0.5*dz2w1d(I) !height of 2nd half-sigma level + GOVRTH(I)=grav/TH1D(I) ENDDO !tgs - should QFX and HFX be separate for land, ice and water? @@ -916,7 +903,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & E1=SVP1*EXP(SVP2*(T1D(I)-SVPT0)/(T1D(I)-SVP3)) ENDIF PL=P1D(I)/1000. - !QGH(I)=EP2*E1/(PL-ep_3*E1) !specific humidity + !QGH(I)=EP2*E1/(PL-ep3*E1) !specific humidity QGH(I)=EP2*E1/(PL-E1) !mixing ratio CPM(I)=CP*(1.+0.84*QV1D(I)) ENDDO @@ -962,8 +949,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !fluxc = max(hflx_wat(i) + ep1*THVSK_wat(I)*qflx_wat(i),0.) fluxc = max(hfx(i)/RHO1D(i)/cp & & + ep1*THVSK_wat(I)*qfx(i)/RHO1D(i),0._kind_phys) - !WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**onethird - WSTAR(I) = vconvc*(g/TSK_wat(i)*pblh(i)*fluxc)**onethird + !WSTAR(I) = vconvc*(grav/TSK(i)*pblh(i)*fluxc)**onethird + WSTAR(I) = vconvc*(grav/TSK_wat(i)*pblh(i)*fluxc)**onethird !-------------------------------------------------------- ! Mahrt and Sun low-res correction - modified for water points (halved) ! (for 13 km ~ 0.18 m/s; for 3 km == 0 m/s) @@ -976,13 +963,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! ACCORDING TO AKB(1976), EQ(12). !-------------------------------------------------------- rb_wat(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD_wat*WSPD_wat) - IF (ITIMESTEP == 1) THEN - rb_wat(I)=MAX(rb_wat(I),-2.0_kind_phys) - rb_wat(I)=MIN(rb_wat(I), 2.0_kind_phys) - ELSE - rb_wat(I)=MAX(rb_wat(I),-4.0_kind_phys) - rb_wat(I)=MIN(rb_wat(I), 4.0_kind_phys) - ENDIF + rb_wat(I)=MAX(rb_wat(I),-2.0_kind_phys) + rb_wat(I)=MIN(rb_wat(I), 2.0_kind_phys) ENDIF ! end water point IF (dry(i)) THEN @@ -1000,7 +982,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**onethird ! increase height scale, assuming that the non-local transoport ! from the mass-flux (plume) mixing exceedsd the PBLH. - WSTAR(I) = vconvc*(g/TSK_lnd(i)*MIN(1.5*pblh(i),4000._kind_phys)*fluxc)**onethird + WSTAR(I) = vconvc*(grav/TSK_lnd(i)*MIN(1.5*pblh(i),4000._kind_phys)*fluxc)**onethird !-------------------------------------------------------- ! Mahrt and Sun low-res correction ! (for 13 km ~ 0.37 m/s; for 3 km == 0 m/s) @@ -1019,13 +1001,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !ELSE ! ust_lnd(i)=WSPD_lnd*0.1*(1.0 - 10.0*rb_lnd(I))**onethird !ENDIF - IF (ITIMESTEP == 1) THEN - rb_lnd(I)=MAX(rb_lnd(I),-2.0_kind_phys) - rb_lnd(I)=MIN(rb_lnd(I), 2.0_kind_phys) - ELSE - rb_lnd(I)=MAX(rb_lnd(I),-4.0_kind_phys) - rb_lnd(I)=MIN(rb_lnd(I), 4.0_kind_phys) - ENDIF + rb_lnd(I)=MAX(rb_lnd(I),-2.0_kind_phys) + rb_lnd(I)=MIN(rb_lnd(I), 2.0_kind_phys) ENDIF ! end land point IF (icy(i)) THEN @@ -1043,7 +1020,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**onethird ! increase height scale, assuming that the non-local transport ! from the mass-flux (plume) mixing exceedsd the PBLH. - WSTAR(I) = vconvc*(g/TSK_ice(i)*MIN(1.5*pblh(i),4000._kind_phys)*fluxc)**onethird + WSTAR(I) = vconvc*(grav/TSK_ice(i)*MIN(1.5*pblh(i),4000._kind_phys)*fluxc)**onethird !-------------------------------------------------------- ! Mahrt and Sun low-res correction ! (for 13 km ~ 0.37 m/s; for 3 km == 0 m/s) @@ -1056,13 +1033,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! ACCORDING TO AKB(1976), EQ(12). !-------------------------------------------------------- rb_ice(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD_ice*WSPD_ice) - IF (ITIMESTEP == 1) THEN - rb_ice(I)=MAX(rb_ice(I),-2.0_kind_phys) - rb_ice(I)=MIN(rb_ice(I), 2.0_kind_phys) - ELSE - rb_ice(I)=MAX(rb_ice(I),-4.0_kind_phys) - rb_ice(I)=MIN(rb_ice(I), 4.0_kind_phys) - ENDIF + rb_ice(I)=MAX(rb_ice(I),-2.0_kind_phys) + rb_ice(I)=MIN(rb_ice(I), 2.0_kind_phys) ENDIF ! end ice point !NOW CONDENSE THE POSSIBLE WSPD VALUES BY TAKING THE MAXIMUM @@ -1175,7 +1147,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & CALL fairall_etal_2003(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& rstoch1D(i),spp_sfc) ELSE - !presumably, this will be published soon, but hasn't yet CALL fairall_etal_2014(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& rstoch1D(i),spp_sfc) ENDIF @@ -1345,27 +1316,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (wet(i)) THEN IF (rb_wat(I) .GT. 0.0) THEN - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0_kind_phys) - ZOL(I)=MIN(ZOL(I),20._kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN - write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) - write(0,*)" tsk=", tskin_wat(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& - " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) + !ZOL(I)=ZA(I)*KARMAN*grav*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0_kind_phys) + ZOL(I)=MIN(ZOL(I),20._kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN + write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) + write(0,*)" tsk=", tskin_wat(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& + " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) @@ -1411,26 +1384,28 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !========================================================== !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.001)) - ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) - ZOL(I)=MIN(ZOL(I),0.0_kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN - write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) - write(0,*)" tsk=", tskin_wat(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& - " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) + !ZOL(I)=ZA(I)*KARMAN*grav*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) + ZOL(I)=MIN(ZOL(I),0.0_kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN + write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) + write(0,*)" tsk=", tskin_wat(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& + " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) @@ -1478,27 +1453,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (dry(i)) THEN IF (rb_lnd(I) .GT. 0.0) THEN - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0_kind_phys) - ZOL(I)=MIN(ZOL(I),20._kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN - write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) - write(0,*)" tsk=", tskin_lnd(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& - " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) + !ZOL(I)=ZA(I)*KARMAN*grav*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0_kind_phys) + ZOL(I)=MIN(ZOL(I),20._kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN + write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) + write(0,*)" tsk=", tskin_lnd(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& + " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) @@ -1542,27 +1519,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-----CLASS 4; FREE CONVECTION: !========================================================== - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.001)) - ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) - ZOL(I)=MIN(ZOL(I),0.0_kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN - write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) - write(0,*)" tsk=", tskin_lnd(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& - " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) + !ZOL(I)=ZA(I)*KARMAN*grav*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) + ZOL(I)=MIN(ZOL(I),0.0_kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN + write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) + write(0,*)" tsk=", tskin_lnd(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& + " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) @@ -1609,27 +1588,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (icy(i)) THEN IF (rb_ice(I) .GT. 0.0) THEN - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0_kind_phys) - ZOL(I)=MIN(ZOL(I),20._kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN - write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) - write(0,*)" tsk=", tskin_ice(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& - " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) + !ZOL(I)=ZA(I)*KARMAN*grav*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0_kind_phys) + ZOL(I)=MIN(ZOL(I),20._kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN + write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) + write(0,*)" tsk=", tskin_ice(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& + " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) @@ -1673,27 +1654,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-----CLASS 4; FREE CONVECTION: !========================================================== - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.001)) - ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) - ZOL(I)=MIN(ZOL(I),0.0_kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN - write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) - write(0,*)" tsk=", tskin_ice(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& - " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) + !ZOL(I)=ZA(I)*KARMAN*grav*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) + ZOL(I)=MIN(ZOL(I),0.0_kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN + write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) + write(0,*)" tsk=", tskin_ice(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& + " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) @@ -1744,9 +1727,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (wet(I)) THEN ! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE OLDUST = UST_wat(I) - !UST_wat(I)=0.5*UST_wat(I)+0.5*KARMAN*WSPD(I)/PSIX_wat(I) + UST_wat(I)=0.5*UST_wat(I)+0.5*KARMAN*WSPD(I)/PSIX_wat(I) !NON-AVERAGED: - UST_wat(I)=KARMAN*WSPD(I)/PSIX_wat(I) + !UST_wat(I)=KARMAN*WSPD(I)/PSIX_wat(I) stress_wat(i)=ust_wat(i)**2 ! Compute u* without vconv for use in HFX calc when isftcflx > 0 @@ -2290,14 +2273,14 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& & landsea,IZ0TLND2,spp_sfc,rstoch) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea + REAL(kind_phys), INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea INTEGER, OPTIONAL, INTENT(IN) :: IZ0TLND2 - REAL(kind=kind_phys), INTENT(OUT) :: Zt,Zq - REAL(kind=kind_phys) :: CZIL !=0.100 in Chen et al. (1997) + REAL(kind_phys), INTENT(OUT) :: Zt,Zq + REAL(kind_phys) :: CZIL !=0.100 in Chen et al. (1997) !=0.075 in Zilitinkevich (1995) !=0.500 in Lemone et al. (2008) INTEGER, INTENT(IN) :: spp_sfc - REAL(kind=kind_phys), INTENT(IN) :: rstoch + REAL(kind_phys), INTENT(IN) :: rstoch IF (landsea-1.5 .GT. 0) THEN !WATER @@ -2359,16 +2342,16 @@ SUBROUTINE davis_etal_2008(Z_0,ustar) !corrects a small-bias in Z_0 (AHW real-time 2012). IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: ustar - REAL(kind=kind_phys), INTENT(OUT) :: Z_0 - REAL(kind=kind_phys) :: ZW, ZN1, ZN2 - REAL(kind=kind_phys), PARAMETER :: G=9.81, OZO=1.59E-5 + REAL(kind_phys), INTENT(IN) :: ustar + REAL(kind_phys), INTENT(OUT) :: Z_0 + REAL(kind_phys) :: ZW, ZN1, ZN2 + REAL(kind_phys), PARAMETER :: OZO=1.59E-5 !OLD FORM: Z_0 = 10.*EXP(-10./(ustar**onethird)) !NEW FORM: ZW = MIN((ustar/1.06)**(0.3),1.0_kind_phys) - ZN1 = 0.011*ustar*ustar/G + OZO + ZN1 = 0.011*ustar*ustar*g_inv + OZO ZN2 = 10.*exp(-9.5*ustar**(-onethird)) + & 0.11*1.5E-5/MAX(ustar,0.01_kind_phys) !0.11*1.5E-5/AMAX1(ustar,0.01) @@ -2387,17 +2370,17 @@ END SUBROUTINE davis_etal_2008 SUBROUTINE Taylor_Yelland_2001(Z_0,ustar,wsp10) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: ustar,wsp10 - REAL(kind=kind_phys), INTENT(OUT) :: Z_0 - REAL(kind=kind_phys), parameter :: g=9.81, pi=3.14159265 - REAL(kind=kind_phys) :: hs, Tp, Lp + REAL(kind_phys), INTENT(IN) :: ustar,wsp10 + REAL(kind_phys), INTENT(OUT) :: Z_0 + REAL(kind_phys), parameter :: pi=3.14159265 + REAL(kind_phys) :: hs, Tp, Lp !hs is the significant wave height hs = 0.0248*(wsp10**2.) !Tp dominant wave period Tp = 0.729*MAX(wsp10,0.1_kind_phys) !Lp is the wavelength of the dominant wave - Lp = g*Tp**2/(2*pi) + Lp = grav*Tp**2/(2*pi) Z_0 = 1200.*hs*(hs/Lp)**4.5 Z_0 = MAX( Z_0, 1.27e-7_kind_phys) !These max/mins were suggested by @@ -2415,16 +2398,16 @@ END SUBROUTINE Taylor_Yelland_2001 SUBROUTINE charnock_1955(Z_0,ustar,wsp10,visc,zu) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu - REAL(kind=kind_phys), INTENT(OUT) :: Z_0 - REAL(kind=kind_phys), PARAMETER :: G=9.81, CZO2=0.011 - REAL(kind=kind_phys) :: CZC ! variable charnock "constant" - REAL(kind=kind_phys) :: wsp10m ! logarithmically calculated 10 m + REAL(kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu + REAL(kind_phys), INTENT(OUT) :: Z_0 + REAL(kind_phys), PARAMETER :: CZO2=0.011 + REAL(kind_phys) :: CZC ! variable charnock "constant" + REAL(kind_phys) :: wsp10m ! logarithmically calculated 10 m wsp10m = wsp10*log(10./1e-4)/log(zu/1e-4) CZC = CZO2 + 0.007*MIN(MAX((wsp10m-10.)/8., 0._kind_phys), 1.0_kind_phys) - Z_0 = CZC*ustar*ustar/G + (0.11*visc/MAX(ustar,0.05_kind_phys)) + Z_0 = CZC*ustar*ustar*g_inv + (0.11*visc/MAX(ustar,0.05_kind_phys)) Z_0 = MAX( Z_0, 1.27e-7_kind_phys) !These max/mins were suggested by Z_0 = MIN( Z_0, 2.85e-3_kind_phys) !Davis et al. (2008) @@ -2440,19 +2423,18 @@ END SUBROUTINE charnock_1955 SUBROUTINE edson_etal_2013(Z_0,ustar,wsp10,visc,zu) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu - REAL(kind=kind_phys), INTENT(OUT) :: Z_0 - REAL(kind=kind_phys), PARAMETER :: G=9.81 - REAL(kind=kind_phys), PARAMETER :: m=0.0017, b=-0.005 - REAL(kind=kind_phys) :: CZC ! variable charnock "constant" - REAL(kind=kind_phys) :: wsp10m ! logarithmically calculated 10 m + REAL(kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu + REAL(kind_phys), INTENT(OUT) :: Z_0 + REAL(kind_phys), PARAMETER :: m=0.0017, b=-0.005 + REAL(kind_phys) :: CZC ! variable charnock "constant" + REAL(kind_phys) :: wsp10m ! logarithmically calculated 10 m wsp10m = wsp10*log(10/1e-4)/log(zu/1e-4) wsp10m = MIN(19._kind_phys, wsp10m) CZC = m*wsp10m + b CZC = MAX(CZC, 0.0_kind_phys) - Z_0 = CZC*ustar*ustar/G + (0.11*visc/MAX(ustar,0.07_kind_phys)) + Z_0 = CZC*ustar*ustar*g_inv + (0.11*visc/MAX(ustar,0.07_kind_phys)) Z_0 = MAX( Z_0, 1.27e-7_kind_phys) !These max/mins were suggested by Z_0 = MIN( Z_0, 2.85e-3_kind_phys) !Davis et al. (2008) @@ -2470,10 +2452,10 @@ END SUBROUTINE edson_etal_2013 SUBROUTINE garratt_1992(Zt,Zq,Z_0,Ren,landsea) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: Ren, Z_0,landsea - REAL(kind=kind_phys), INTENT(OUT) :: Zt,Zq - REAL(kind=kind_phys) :: Rq - REAL(kind=kind_phys), PARAMETER :: e=2.71828183 + REAL(kind_phys), INTENT(IN) :: Ren, Z_0,landsea + REAL(kind_phys), INTENT(OUT) :: Zt,Zq + REAL(kind_phys) :: Rq + REAL(kind_phys), PARAMETER :: e=2.71828183 IF (landsea-1.5 .GT. 0) THEN !WATER @@ -2506,9 +2488,9 @@ END SUBROUTINE garratt_1992 SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch - INTEGER, INTENT(IN):: spp_sfc - REAL(kind=kind_phys), INTENT(OUT) :: Zt,Zq + REAL(kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch + INTEGER, INTENT(IN) :: spp_sfc + REAL(kind_phys), INTENT(OUT) :: Zt,Zq IF (Ren .le. 2.) then @@ -2545,14 +2527,14 @@ END SUBROUTINE fairall_etal_2003 !> This formulation for thermal and moisture roughness length (Zt and Zq) !! as a function of the roughness Reynolds number (Ren) comes from the !! COARE 3.5/4.0 formulation, empirically derived from COARE and HEXMAX data -!! [Fairall et al. (2014? coming soon, not yet published as of July 2014)]. -!! This is for use over water only. +!! The actual reference is unknown. This was passed along by Jim Edson (personal communication). +!! This is for use over water only, preferably open ocean. SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch - INTEGER, INTENT(IN):: spp_sfc - REAL(kind=kind_phys), INTENT(OUT) :: Zt,Zq + REAL(kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch + INTEGER, INTENT(IN) :: spp_sfc + REAL(kind_phys), INTENT(OUT) :: Zt,Zq !Zt = (5.5e-5)*(Ren**(-0.60)) Zt = MIN(1.6E-4_kind_phys, 5.8E-5/(Ren**0.72)) @@ -2597,17 +2579,17 @@ END SUBROUTINE fairall_etal_2014 SUBROUTINE Yang_2008(Z_0,Zt,Zq,ustar,tstar,qst,Ren,visc) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: Z_0, Ren, ustar, tstar, qst, visc - REAL(kind=kind_phys) :: ht, &! roughness height at critical Reynolds number + REAL(kind_phys), INTENT(IN) :: Z_0, Ren, ustar, tstar, qst, visc + REAL(kind_phys) :: 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(kind=kind_phys), INTENT(OUT) :: Zt,Zq - REAL(kind=kind_phys), 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 + REAL(kind_phys), INTENT(OUT) :: Zt,Zq + REAL(kind_phys), 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_kind_phys) Z_02 = MAX(Z_02,0.04_kind_phys) @@ -2631,10 +2613,10 @@ END SUBROUTINE Yang_2008 !>\ingroup mynn_sfc SUBROUTINE GFS_z0_lnd(z0max,shdmax,z1,vegtype,ivegsrc,z0pert) - REAL(kind=kind_phys), INTENT(OUT) :: z0max - REAL(kind=kind_phys), INTENT(IN) :: shdmax,z1,z0pert - INTEGER, INTENT(IN) :: vegtype,ivegsrc - REAL(kind=kind_phys) :: tem1, tem2 + REAL(kind_phys), INTENT(OUT) :: z0max + REAL(kind_phys), INTENT(IN) :: shdmax,z1,z0pert + INTEGER, INTENT(IN) :: vegtype,ivegsrc + REAL(kind_phys) :: tem1, tem2 ! z0max = max(1.0e-6, min(0.01 * z0max, z1)) !already converted into meters in the wrapper @@ -2691,10 +2673,10 @@ END SUBROUTINE GFS_z0_lnd !>\ingroup mynn_sfc SUBROUTINE GFS_zt_lnd(ztmax,z0max,sigmaf,ztpert,ustar_lnd) - REAL(kind=kind_phys), INTENT(OUT) :: ztmax - REAL(kind=kind_phys), INTENT(IN) :: z0max,sigmaf,ztpert,ustar_lnd - REAL(kind=kind_phys) :: czilc, tem1, tem2 - REAL(kind=kind_phys), PARAMETER :: ca = 0.4 + REAL(kind_phys), INTENT(OUT) :: ztmax + REAL(kind_phys), INTENT(IN) :: z0max,sigmaf,ztpert,ustar_lnd + REAL(kind_phys) :: czilc, tem1, tem2 + REAL(kind_phys), PARAMETER :: ca = 0.4 ! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil czilc = 0.8 @@ -2719,25 +2701,25 @@ END SUBROUTINE GFS_zt_lnd !>\ingroup mynn_sfc SUBROUTINE GFS_z0_wat(z0rl_wat,ustar_wat,WSPD,z1,sfc_z0_type,redrag) - REAL(kind=kind_phys), INTENT(OUT) :: z0rl_wat - REAL(kind=kind_phys), INTENT(INOUT):: ustar_wat - REAL(kind=kind_phys), INTENT(IN) :: wspd,z1 - LOGICAL, INTENT(IN):: redrag - INTEGER, INTENT(IN):: sfc_z0_type - REAL(kind=kind_phys) :: z0,z0max,wind10m - REAL(kind=kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2 + REAL(kind_phys), INTENT(OUT) :: z0rl_wat + REAL(kind_phys), INTENT(INOUT):: ustar_wat + REAL(kind_phys), INTENT(IN) :: wspd,z1 + LOGICAL, INTENT(IN) :: redrag + INTEGER, INTENT(IN) :: sfc_z0_type + REAL(kind_phys) :: z0,z0max,wind10m + REAL(kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2 ! z0 = 0.01 * z0rl_wat !Already converted to meters in the wrapper z0 = z0rl_wat z0max = max(1.0e-6_kind_phys, min(z0,z1)) - ustar_wat = sqrt(g * z0 / charnock) + ustar_wat = sqrt(grav * z0 / charnock) wind10m = wspd*log(10./1e-4)/log(z1/1e-4) !wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) ! if (sfc_z0_type >= 0) then if (sfc_z0_type == 0) then - z0 = (charnock / g) * ustar_wat * ustar_wat + z0 = (charnock / grav) * ustar_wat * ustar_wat ! mbek -- toga-coare flux algorithm ! z0 = (charnock / g) * ustar(i)*ustar(i) + arnu/ustar(i) @@ -2772,13 +2754,13 @@ END SUBROUTINE GFS_z0_wat !>\ingroup mynn_sfc SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg) - REAL(kind=kind_phys), INTENT(OUT) :: ztmax - REAL(kind=kind_phys), INTENT(IN) :: wspd,z1,z0rl_wat,restar - INTEGER, INTENT(IN):: sfc_z0_type + real(kind_phys), INTENT(OUT) :: ztmax + real(kind_phys), INTENT(IN) :: wspd,z1,z0rl_wat,restar + INTEGER, INTENT(IN) :: sfc_z0_type character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - REAL(kind=kind_phys) :: z0,z0max,wind10m,rat,ustar_wat - REAL(kind=kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2 + real(kind_phys) :: z0,z0max,wind10m,rat,ustar_wat + real(kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2 ! Initialize error-handling errflg = 0 @@ -2788,7 +2770,7 @@ SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg) !Already converted to meters in the wrapper z0 = z0rl_wat z0max = max(1.0e-6_kind_phys, min(z0,z1)) - ustar_wat = sqrt(g * z0 / charnock) + ustar_wat = sqrt(grav * z0 / charnock) wind10m = wspd*log(10./1e-4)/log(z1/1e-4) !** test xubin's new z0 @@ -2837,9 +2819,9 @@ SUBROUTINE znot_m_v6(uref, znotm) ! znotm(meter): areodynamical roughness scale over water ! - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znotm - REAL(kind=kind_phys), PARAMETER :: p13 = -1.296521881682694e-02,& + REAL(kind_phys), INTENT(IN) :: uref + REAL(kind_phys), INTENT(OUT):: znotm + REAL(kind_phys), PARAMETER :: p13 = -1.296521881682694e-02, & & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00,& & p10 = -8.396975715683501e+00, & @@ -2884,9 +2866,9 @@ SUBROUTINE znot_t_v6(uref, znott) ! uref(m/s) : wind speed at 10-m height ! znott(meter): scalar roughness scale over water ! - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znott - REAL(kind=kind_phys), PARAMETER :: p00 = 1.100000000000000e-04,& + REAL(kind_phys), INTENT(IN) :: uref + REAL(kind_phys), INTENT(OUT):: znott + REAL(kind_phys), PARAMETER :: p00 = 1.100000000000000e-04,& & p15 = -9.144581627678278e-10, p14 = 7.020346616456421e-08,& & p13 = -2.155602086883837e-06, p12 = 3.333848806567684e-05,& & p11 = -2.628501274963990e-04, p10 = 8.634221567969181e-04,& @@ -2952,12 +2934,12 @@ SUBROUTINE znot_m_v7(uref, znotm) ! znotm(meter): areodynamical roughness scale over water ! - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znotm + REAL(kind_phys), INTENT(IN) :: uref + REAL(kind_phys), INTENT(OUT):: znotm - REAL(kind=kind_phys), PARAMETER :: p13 = -1.296521881682694e-02,& + REAL(kind_phys), PARAMETER :: p13 = -1.296521881682694e-02,& & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00,& - & p10 = -8.396975715683501e+00,& + & p10 = -8.396975715683501e+00, & & p25 = 3.790846746036765e-10, p24 = 3.281964357650687e-09,& & p23 = 1.962282433562894e-07, p22 = -1.240239171056262e-06,& @@ -3001,11 +2983,9 @@ SUBROUTINE znot_t_v7(uref, znott) ! znott(meter): scalar roughness scale over water ! - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znott - - REAL(kind=kind_phys), PARAMETER :: p00 = 1.100000000000000e-04,& - + REAL(kind_phys), INTENT(IN) :: uref + REAL(kind_phys), INTENT(OUT):: znott + REAL(kind_phys), PARAMETER :: p00 = 1.100000000000000e-04,& & p15 = -9.193764479895316e-10, p14 = 7.052217518653943e-08,& & p13 = -2.163419217747114e-06, p12 = 3.342963077911962e-05,& & p11 = -2.633566691328004e-04, p10 = 8.644979973037803e-04,& @@ -3061,23 +3041,23 @@ END SUBROUTINE znot_t_v7 SUBROUTINE Andreas_2002(Z_0,bvisc,ustar,Zt,Zq) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: Z_0, bvisc, ustar - REAL(kind=kind_phys), INTENT(OUT) :: Zt, Zq - REAL(kind=kind_phys) :: Ren2, zntsno + REAL(kind_phys), INTENT(IN) :: Z_0, bvisc, ustar + REAL(kind_phys), INTENT(OUT) :: Zt, Zq + REAL(kind_phys) :: Ren2, zntsno - REAL(kind=kind_phys), PARAMETER :: & + REAL(kind_phys), 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(kind=kind_phys), PARAMETER :: & + REAL(kind_phys), 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) * & + zntsno = 0.135*bvisc/ustar + & + (0.035*(ustar*ustar)*g_inv) * & (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.) Ren2 = ustar*zntsno/bvisc @@ -3112,9 +3092,9 @@ END SUBROUTINE Andreas_2002 SUBROUTINE PSI_Hogstrom_1996(psi_m, psi_h, zL, Zt, Z_0, Za) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL, Zt, Z_0, Za - REAL(kind=kind_phys), INTENT(OUT) :: psi_m, psi_h - REAL(kind=kind_phys) :: x, x0, y, y0, zmL, zhL + REAL(kind_phys), INTENT(IN) :: zL, Zt, Z_0, Za + REAL(kind_phys), INTENT(OUT) :: psi_m, psi_h + REAL(kind_phys) :: x, x0, y, y0, zmL, zhL zmL = Z_0*zL/Za zhL = Zt*zL/Za @@ -3131,7 +3111,7 @@ SUBROUTINE PSI_Hogstrom_1996(psi_m, psi_h, zL, Zt, Z_0, Za) y = (1.-11.6*zL)**0.5 y0= (1.-11.6*zhL)**0.5 - psi_m = 2.*LOG((1.+x)/(1.+x0)) + & + psi_m = 2.*LOG((1.+x)/(1.+x0)) + & &LOG((1.+x**2.)/(1.+x0**2.)) - & &2.0*ATAN(x) + 2.0*ATAN(x0) psi_h = 2.*LOG((1.+y)/(1.+y0)) @@ -3150,9 +3130,9 @@ END SUBROUTINE PSI_Hogstrom_1996 SUBROUTINE PSI_DyerHicks(psi_m, psi_h, zL, Zt, Z_0, Za) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL, Zt, Z_0, Za - REAL(kind=kind_phys), INTENT(OUT) :: psi_m, psi_h - REAL(kind=kind_phys) :: x, x0, y, y0, zmL, zhL + REAL(kind_phys), INTENT(IN) :: zL, Zt, Z_0, Za + REAL(kind_phys), INTENT(OUT) :: psi_m, psi_h + REAL(kind_phys) :: x, x0, y, y0, zmL, zhL zmL = Z_0*zL/Za !Zo/L zhL = Zt*zL/Za !Zt/L @@ -3170,7 +3150,7 @@ SUBROUTINE PSI_DyerHicks(psi_m, psi_h, zL, Zt, Z_0, Za) y = (1.-16.*zL)**0.5 y0= (1.-16.*zhL)**0.5 - psi_m = 2.*LOG((1.+x)/(1.+x0)) + & + psi_m = 2.*LOG((1.+x)/(1.+x0)) + & &LOG((1.+x**2.)/(1.+x0**2.)) - & &2.0*ATAN(x) + 2.0*ATAN(x0) psi_h = 2.*LOG((1.+y)/(1.+y0)) @@ -3188,9 +3168,9 @@ END SUBROUTINE PSI_DyerHicks SUBROUTINE PSI_Beljaars_Holtslag_1991(psi_m, psi_h, zL) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL - REAL(kind=kind_phys), INTENT(OUT) :: psi_m, psi_h - REAL(kind=kind_phys), PARAMETER :: a=1., b=0.666, c=5., d=0.35 + REAL(kind_phys), INTENT(IN) :: zL + REAL(kind_phys), INTENT(OUT) :: psi_m, psi_h + REAL(kind_phys), PARAMETER :: a=1., b=0.666, c=5., d=0.35 IF (zL .lt. 0.) THEN !UNSTABLE @@ -3220,9 +3200,9 @@ END SUBROUTINE PSI_Beljaars_Holtslag_1991 SUBROUTINE PSI_Zilitinkevich_Esau_2007(psi_m, psi_h, zL) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL - REAL(kind=kind_phys), INTENT(OUT) :: psi_m, psi_h - REAL(kind=kind_phys), PARAMETER :: Cm=3.0, Ct=2.5 + REAL(kind_phys), INTENT(IN) :: zL + REAL(kind_phys), INTENT(OUT) :: psi_m, psi_h + REAL(kind_phys), PARAMETER :: Cm=3.0, Ct=2.5 IF (zL .lt. 0.) THEN !UNSTABLE @@ -3249,10 +3229,10 @@ END SUBROUTINE PSI_Zilitinkevich_Esau_2007 SUBROUTINE PSI_Businger_1971(psi_m, psi_h, zL) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL - REAL(kind=kind_phys), INTENT(OUT) :: psi_m, psi_h - REAL(kind=kind_phys) :: x, y - REAL(kind=kind_phys), PARAMETER :: Pi180 = 3.14159265/180. + REAL(kind_phys), INTENT(IN) :: zL + REAL(kind_phys), INTENT(OUT) :: psi_m, psi_h + REAL(kind_phys) :: x, y + REAL(kind_phys), PARAMETER :: Pi180 = 3.14159265/180. IF (zL .lt. 0.) THEN !UNSTABLE @@ -3285,9 +3265,9 @@ END SUBROUTINE PSI_Businger_1971 SUBROUTINE PSI_Suselj_Sood_2010(psi_m, psi_h, zL) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL - REAL(kind=kind_phys), INTENT(OUT) :: psi_m, psi_h - REAL(kind=kind_phys), PARAMETER :: Rfc=0.19, Ric=0.183, PHIT=0.8 + REAL(kind_phys), INTENT(IN) :: zL + REAL(kind_phys), INTENT(OUT) :: psi_m, psi_h + REAL(kind_phys), PARAMETER :: Rfc=0.19, Ric=0.183, PHIT=0.8 IF (zL .gt. 0.) THEN !STABLE @@ -3315,10 +3295,10 @@ END SUBROUTINE PSI_Suselj_Sood_2010 SUBROUTINE PSI_CB2005(psim1,psih1,zL,z0L) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL,z0L - REAL(kind=kind_phys), INTENT(OUT) :: psim1,psih1 + REAL(kind_phys), INTENT(IN) :: zL,z0L + REAL(kind_phys), INTENT(OUT) :: psim1,psih1 - psim1 = -6.1*LOG(zL + (1.+ zL**2.5)**0.4) & + psim1 = -6.1*LOG(zL + (1.+ zL**2.5)**0.4) & -6.1*LOG(z0L + (1.+ z0L**2.5)**0.4) psih1 = -5.5*log(zL + (1.+ zL**1.1)**0.90909090909) & -5.5*log(z0L + (1.+ z0L**1.1)**0.90909090909) @@ -3334,18 +3314,18 @@ END SUBROUTINE PSI_CB2005 SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(OUT) :: zL - REAL(kind=kind_phys), INTENT(IN) :: Rib, zaz0, z0zt - REAL(kind=kind_phys) :: alfa, beta, zaz02, z0zt2 - REAL(kind=kind_phys), PARAMETER :: & + REAL(kind_phys), INTENT(OUT) :: zL + REAL(kind_phys), INTENT(IN) :: Rib, zaz0, z0zt + REAL(kind_phys) :: alfa, beta, zaz02, z0zt2 + REAL(kind_phys), 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(kind=kind_phys), PARAMETER :: & + REAL(kind_phys), 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(kind=kind_phys), PARAMETER :: & + REAL(kind_phys), PARAMETER :: & & as11=0.7529, as21=14.94, bs11=0.1569, & & bs21=-0.3091, bs22=-1.303 @@ -3392,7 +3372,7 @@ SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) END SUBROUTINE Li_etal_2010 !------------------------------------------------------------------- !>\ingroup mynn_sfc - REAL(kind=kind_phys) function zolri(ri,za,z0,zt,zol1,psi_opt) + REAL(kind_phys) function zolri(ri,za,z0,zt,zol1,psi_opt) !> This iterative algorithm was taken from the revised surface layer !! scheme in WRF-ARW, written by Pedro Jimenez and Jimy Dudhia and @@ -3401,12 +3381,12 @@ REAL(kind=kind_phys) function zolri(ri,za,z0,zt,zol1,psi_opt) !! estimate of z/L. IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: ri,za,z0,zt,zol1 + REAL(kind_phys), INTENT(IN) :: ri,za,z0,zt,zol1 INTEGER, INTENT(IN) :: psi_opt - REAL(kind=kind_phys) :: x1,x2,fx1,fx2 + REAL(kind_phys) :: x1,x2,fx1,fx2 INTEGER :: n INTEGER, PARAMETER :: nmax = 20 - !REAL(kind=kind_phys), DIMENSION(nmax):: zLhux + !REAL(kind_phys), DIMENSION(nmax):: zLhux if (ri.lt.0.)then x1=zol1 - 0.02 !-5. @@ -3447,7 +3427,7 @@ REAL(kind=kind_phys) function zolri(ri,za,z0,zt,zol1,psi_opt) return end function !------------------------------------------------------------------- - REAL(kind=kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt) + REAL(kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt) ! INPUT: ================================= ! zol2 - estimated z/L @@ -3459,10 +3439,10 @@ REAL(kind=kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt) ! zolri2 - delta Ri IMPLICIT NONE - INTEGER, INTENT(IN) :: psi_opt - REAL(kind=kind_phys), INTENT(IN) :: ri2,za,z0,zt - REAL(kind=kind_phys), INTENT(INOUT) :: zol2 - REAL(kind=kind_phys) :: zol20,zol3,psim1,psih1,psix2,psit2,zolt + INTEGER, INTENT(IN) :: psi_opt + REAL(kind_phys), INTENT(IN) :: ri2,za,z0,zt + REAL(kind_phys), INTENT(INOUT) :: zol2 + REAL(kind_phys) :: zol20,zol3,psim1,psih1,psix2,psit2,zolt if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 @@ -3489,19 +3469,19 @@ REAL(kind=kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt) end function !==================================================================== - REAL(kind=kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) + REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) ! This iterative algorithm to compute z/L from bulk-Ri IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: ri,za,z0,zt,logz0,logzt - INTEGER, INTENT(IN) :: psi_opt - REAL(kind=kind_phys), INTENT(INOUT) :: zol1 - REAL(kind=kind_phys) :: zol20,zol3,zolt,zolold + REAL(kind_phys), INTENT(IN) :: ri,za,z0,zt,logz0,logzt + INTEGER, INTENT(IN) :: psi_opt + REAL(kind_phys), INTENT(INOUT) :: zol1 + REAL(kind_phys) :: zol20,zol3,zolt,zolold INTEGER :: n INTEGER, PARAMETER :: nmax = 20 - REAL(kind=kind_phys), DIMENSION(nmax):: zLhux - REAL(kind=kind_phys) :: psit2,psix2 + REAL(kind_phys), DIMENSION(nmax):: zLhux + REAL(kind_phys) :: psit2,psix2 !print*,"+++++++INCOMING: z/L=",zol1," ri=",ri if (zol1*ri .lt. 0.) THEN @@ -3569,7 +3549,7 @@ REAL(kind=kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) SUBROUTINE psi_init(psi_opt,errmsg,errflg) integer :: N,psi_opt - real(kind=kind_phys) :: zolf + real(kind_phys) :: zolf character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -3614,8 +3594,8 @@ END SUBROUTINE psi_init ! ... integrated similarity functions from MYNN... ! !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psim_stable_full(zolf) - REAL(kind=kind_phys) :: zolf + real(kind_phys) function psim_stable_full(zolf) + real(kind_phys) :: 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) @@ -3624,8 +3604,8 @@ REAL(kind=kind_phys) function psim_stable_full(zolf) end function !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psih_stable_full(zolf) - REAL(kind=kind_phys) :: zolf + real(kind_phys) function psih_stable_full(zolf) + real(kind_phys) :: 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) @@ -3634,8 +3614,8 @@ REAL(kind=kind_phys) function psih_stable_full(zolf) end function !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psim_unstable_full(zolf) - REAL(kind=kind_phys) :: zolf,x,ym,psimc,psimk + real(kind_phys) function psim_unstable_full(zolf) + real(kind_phys) :: 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.) @@ -3652,8 +3632,8 @@ REAL(kind=kind_phys) function psim_unstable_full(zolf) end function !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psih_unstable_full(zolf) - REAL(kind=kind_phys) :: zolf,y,yh,psihc,psihk + real(kind_phys) function psih_unstable_full(zolf) + real(kind_phys) :: zolf,y,yh,psihc,psihk y=(1.-16.*zolf)**.5 !psihk=2.*log((1+y)/2.) @@ -3673,10 +3653,10 @@ REAL(kind=kind_phys) function psih_unstable_full(zolf) ! !>\ingroup mynn_sfc !! - REAL(kind=kind_phys) function psim_stable_full_gfs(zolf) - REAL(kind=kind_phys) :: zolf - REAL(kind=kind_phys), PARAMETER :: alpha4 = 20. - REAL(kind=kind_phys) :: aa + REAL(kind_phys) function psim_stable_full_gfs(zolf) + REAL(kind_phys) :: zolf + REAL(kind_phys), PARAMETER :: alpha4 = 20. + REAL(kind_phys) :: aa aa = sqrt(1. + alpha4 * zolf) psim_stable_full_gfs = -1.*aa + log(aa + 1.) @@ -3686,10 +3666,10 @@ REAL(kind=kind_phys) function psim_stable_full_gfs(zolf) !>\ingroup mynn_sfc !! - REAL(kind=kind_phys) function psih_stable_full_gfs(zolf) - REAL(kind=kind_phys) :: zolf - REAL(kind=kind_phys), PARAMETER :: alpha4 = 20. - REAL(kind=kind_phys) :: bb + real(kind_phys) function psih_stable_full_gfs(zolf) + real(kind_phys) :: zolf + real(kind_phys), PARAMETER :: alpha4 = 20. + real(kind_phys) :: bb bb = sqrt(1. + alpha4 * zolf) psih_stable_full_gfs = -1.*bb + log(bb + 1.) @@ -3699,10 +3679,10 @@ REAL(kind=kind_phys) function psih_stable_full_gfs(zolf) !>\ingroup mynn_sfc !! - REAL(kind=kind_phys) function psim_unstable_full_gfs(zolf) - REAL(kind=kind_phys) :: zolf - REAL(kind=kind_phys) :: hl1,tem1 - REAL(kind=kind_phys), PARAMETER :: a0=-3.975, a1=12.32, & + real(kind_phys) function psim_unstable_full_gfs(zolf) + real(kind_phys) :: zolf + real(kind_phys) :: hl1,tem1 + real(kind_phys), PARAMETER :: a0=-3.975, a1=12.32, & b1=-7.755, b2=6.041 if (zolf .ge. -0.5) then @@ -3719,10 +3699,10 @@ REAL(kind=kind_phys) function psim_unstable_full_gfs(zolf) !>\ingroup mynn_sfc !! - REAL(kind=kind_phys) function psih_unstable_full_gfs(zolf) - REAL(kind=kind_phys) :: zolf - REAL(kind=kind_phys) :: hl1,tem1 - REAL(kind=kind_phys), PARAMETER :: a0p=-7.941, a1p=24.75, & + real(kind_phys) function psih_unstable_full_gfs(zolf) + real(kind_phys) :: zolf + real(kind_phys) :: hl1,tem1 + real(kind_phys), PARAMETER :: a0p=-7.941, a1p=24.75, & b1p=-8.705, b2p=7.899 if (zolf .ge. -0.5) then @@ -3739,9 +3719,9 @@ REAL(kind=kind_phys) function psih_unstable_full_gfs(zolf) !>\ingroup mynn_sfc !! look-up table functions - or, if beyond -10 < z/L < 10, recalculate - REAL(kind=kind_phys) function psim_stable(zolf,psi_opt) + real(kind_phys) function psim_stable(zolf,psi_opt) integer :: nzol,psi_opt - real(kind=kind_phys) :: rzol,zolf + real(kind_phys) :: rzol,zolf nzol = int(zolf*100.) rzol = zolf*100. - nzol @@ -3759,9 +3739,9 @@ REAL(kind=kind_phys) function psim_stable(zolf,psi_opt) end function !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psih_stable(zolf,psi_opt) + real(kind_phys) function psih_stable(zolf,psi_opt) integer :: nzol,psi_opt - real(kind=kind_phys) :: rzol,zolf + real(kind_phys) :: rzol,zolf nzol = int(zolf*100.) rzol = zolf*100. - nzol @@ -3779,9 +3759,9 @@ REAL(kind=kind_phys) function psih_stable(zolf,psi_opt) end function !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psim_unstable(zolf,psi_opt) + real(kind_phys) function psim_unstable(zolf,psi_opt) integer :: nzol,psi_opt - real(kind=kind_phys) :: rzol,zolf + real(kind_phys) :: rzol,zolf nzol = int(-zolf*100.) rzol = -zolf*100. - nzol @@ -3799,9 +3779,9 @@ REAL(kind=kind_phys) function psim_unstable(zolf,psi_opt) end function !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psih_unstable(zolf,psi_opt) + real(kind_phys) function psih_unstable(zolf,psi_opt) integer :: nzol,psi_opt - real(kind=kind_phys) :: rzol,zolf + real(kind_phys) :: rzol,zolf nzol = int(-zolf*100.) rzol = -zolf*100. - nzol diff --git a/physics/mynnsfc_wrapper.F90 b/physics/mynnsfc_wrapper.F90 index 4be912ab7..1a970c9f4 100644 --- a/physics/mynnsfc_wrapper.F90 +++ b/physics/mynnsfc_wrapper.F90 @@ -87,15 +87,14 @@ SUBROUTINE mynnsfc_wrapper_run( & & FLHC, FLQC, & & U10, V10, TH2, T2, Q2, & & wstar, CHS2, CQS2, & - & spp_wts_sfc, spp_sfc, & -! & CP, G, ROVCP, R, XLV, & -! & SVP1, SVP2, SVP3, SVPT0, & -! & EP1,EP2,KARMAN, & - & lprnt, errmsg, errflg ) + & spp_wts_sfc, spp_sfc, & + & lprnt, errmsg, errflg ) ! should be moved to inside the mynn: use machine , only : kind_phys + use physcons, only : cp => con_cp, & + & grav => con_g ! USE module_sf_mynn, only : SFCLAY_mynn !tgs - info on iterations: @@ -111,22 +110,11 @@ SUBROUTINE mynnsfc_wrapper_run( & !------------------------------------------------------------------- implicit none !------------------------------------------------------------------- -! --- constant parameters: -! real(kind=kind_phys), parameter :: rvovrd = r_v/r_d - real(kind=kind_phys), parameter :: karman = 0.4 -! real(kind=kind_phys), parameter :: XLS = 2.85E6 -! real(kind=kind_phys), parameter :: p1000mb = 100000. - real(kind=kind_phys), parameter :: SVP1 = 0.6112 - real(kind=kind_phys), parameter :: SVP2 = 17.67 - real(kind=kind_phys), parameter :: SVP3 = 29.65 - real(kind=kind_phys), parameter :: SVPT0 = 273.15 +! --- derive more constant parameters: + real(kind_phys), parameter :: g_inv=1./grav - REAL(kind=kind_phys), PARAMETER :: xlvcp=xlv/cp, xlscp=(xlv+xlf)/cp, ev=xlv,& - &rd=r_d, rk=cp/rd, svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2, g_inv=1./g - - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !MISC CONFIGURATION OPTIONS INTEGER, PARAMETER :: isfflx = 1 @@ -141,29 +129,29 @@ SUBROUTINE mynnsfc_wrapper_run( & logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) integer, intent(in) :: spp_sfc ! flag for using SPP perturbations - real(kind=kind_phys), intent(in) :: delt + real(kind_phys), intent(in) :: delt !Input data integer, dimension(:), intent(in) :: vegtype - real(kind=kind_phys), dimension(:), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & & sigmaf,shdmax,z0pert,ztpert - real(kind=kind_phys), dimension(:,:), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & & spp_wts_sfc - real(kind=kind_phys), dimension(:,:), & + real(kind_phys), dimension(:,:), & & intent(in) :: phii - real(kind=kind_phys), dimension(:,:), & + real(kind_phys), dimension(:,:), & & intent(in) :: exner, PRSL, & & u, v, t3d, qvsh, qc logical, dimension(:), intent(in) :: wet, dry, icy - real(kind=kind_phys), dimension(:), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & & snowh_lnd, snowh_ice - real(kind=kind_phys), dimension(:), intent(inout) :: & + real(kind_phys), dimension(:), intent(inout) :: & & znt_wat, znt_lnd, znt_ice, & & ust_wat, ust_lnd, ust_ice, & & cm_wat, cm_lnd, cm_ice, & @@ -179,22 +167,22 @@ SUBROUTINE mynnsfc_wrapper_run( & & qsfc_wat, qsfc_lnd, qsfc_ice !MYNN-2D - real(kind=kind_phys), dimension(:), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & & dx, pblh, slmsk, ps, & & qsfc_lnd_ruc, qsfc_ice_ruc - real(kind=kind_phys), dimension(:), intent(inout) :: & + real(kind_phys), dimension(:), intent(inout) :: & & ustm, hflx, qflx, wspd, qsfc, & & FLHC, FLQC, U10, V10, TH2, T2, Q2, & & CHS2, CQS2, rmol, zol, mol, ch, & & lh, wstar !LOCAL - real(kind=kind_phys), dimension(im) :: & + real(kind_phys), dimension(im) :: & & hfx, znt, psim, psih, & & chs, ck, cd, mavail, xland, GZ1OZ0, & & cpm, qgh, qfx, snowh_wat - real(kind=kind_phys), dimension(im,levs) :: & + real(kind_phys), dimension(im,levs) :: & & dz, th, qv !MYNN-1D @@ -291,9 +279,6 @@ SUBROUTINE mynnsfc_wrapper_run( & u3d=u,v3d=v,t3d=t3d,qv3d=qv,p3d=prsl,dz8w=dz, & th3d=th,pi3d=exner,qc3d=qc, & PSFCPA=ps,PBLH=pblh,MAVAIL=mavail,XLAND=xland,DX=dx, & - CP=cp,G=g,ROVCP=rcp,R=r_d,XLV=xlv, & - SVP1=svp1,SVP2=svp2,SVP3=svp3,SVPT0=svpt0, & - EP1=ep_1,EP2=ep_2,KARMAN=karman, & ISFFLX=isfflx,isftcflx=isftcflx,LSM=lsm,LSM_RUC=lsm_ruc, & iz0tlnd=iz0tlnd,psi_opt=psi_opt, & compute_flux=sfclay_compute_flux,compute_diag=sfclay_compute_diag,& @@ -301,6 +286,7 @@ SUBROUTINE mynnsfc_wrapper_run( & z0pert=z0pert,ztpert=ztpert, & !intent(in) redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) itimestep=itimestep,iter=iter,flag_iter=flag_iter, & + flag_restart=flag_restart, & wet=wet, dry=dry, icy=icy, & !intent(in) tskin_wat=tskin_wat, tskin_lnd=tskin_lnd, tskin_ice=tskin_ice, & !intent(in) tsurf_wat=tsurf_wat, tsurf_lnd=tsurf_lnd, tsurf_ice=tsurf_ice, & !intent(in) @@ -322,7 +308,7 @@ SUBROUTINE mynnsfc_wrapper_run( & ZNT=znt,USTM=ustm,ZOL=zol,MOL=mol,RMOL=rmol, & psim=psim,psih=psih, & HFLX=hflx,HFX=hfx,QFLX=qflx,QFX=qfx,LH=lh,FLHC=flhc,FLQC=flqc, & - QGH=qgh,QSFC=qsfc, & + QGH=qgh,QSFC=qsfc, & U10=u10,V10=v10,TH2=th2,T2=t2,Q2=q2, & GZ1OZ0=GZ1OZ0,WSPD=wspd,wstar=wstar, & spp_sfc=spp_sfc,pattern_spp_sfc=spp_wts_sfc, & From 46bcac5d18eb7311b2e9a7201d2471530dd017f3 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 24 Mar 2023 20:15:46 +0000 Subject: [PATCH 25/28] Modifications to 2-m diagnostics will affect the results only with the use of RUC LSM. --- physics/sfc_diag.f | 232 ++++++++++++++++++++++----------------------- 1 file changed, 113 insertions(+), 119 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 7a3defa62..ad132f20e 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -1,21 +1,13 @@ !> \file sfc_diag.f !! This file contains the land surface diagnose calculation scheme. -!> \defgroup Sfc_diag Land Surface Diagnose Calculation -!! @{ - module sfc_diag contains - - subroutine sfc_diag_init - end subroutine sfc_diag_init - - subroutine sfc_diag_finalize - end subroutine sfc_diag_finalize - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_sfc_diag_run Arguments + +!> \defgroup sfc_diag_mod GFS sfc_diag module +!! This module contains the land surface diagose calculation. +!> @{ +!! \section arg_table_sfc_diag_run Argument Table !! \htmlinclude sfc_diag_run.html !! !! \section general General Algorithm @@ -34,10 +26,6 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & use funcphys, only : fpvs use physcons, only : con_t0c implicit none - - real (kind_phys), parameter :: zero = 0._kind_dbl_prec - real (kind_phys), parameter :: one = 1._kind_dbl_prec - real (kind_phys), parameter :: qmin = 1.0e-8_kind_dbl_prec ! integer, intent(in) :: im, lsm, lsm_ruc logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. @@ -56,13 +44,17 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & ! ! locals ! + real (kind_phys), parameter :: zero = 0._kind_dbl_prec + real (kind_phys), parameter :: one = 1._kind_dbl_prec + real (kind_phys), parameter :: qmin=1.0e-8 + integer :: k,i + logical :: debug_print real(kind=kind_phys) :: q1c, qv, tem, qv1, th2m, x2m, rho real(kind=kind_phys) :: dT, dQ, qsfcmr, qsfcprox, ff, fac, dz1 real(kind=kind_phys) :: t2_alt, q2_alt real(kind=kind_phys) :: thcon, cqs, chs, chs2, cqs2 real(kind=kind_phys) :: testptlat, testptlon - integer :: k,i ! real(kind=kind_phys) :: fhi, qss, wrk ! real(kind=kind_phys) sig2k, fhi, qss @@ -94,117 +86,119 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) fhi = fh2(i) / fh(i) - wrk = one - fhi - - thcon = (1.e5_kind_dbl_prec/ps(i))**con_rocp - !-- make sure 1st level q is not higher than saturated value - qss = fpvs(t1(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) - q1c = min(q1(i),qss) ! lev 1 spec. humidity - - qv1 = q1c / (one - q1c) ! lev 1 mixing ratio - qsfcmr = qsurf(i)/(one - qsurf(i)) ! surface mixing ratio - chs = cdq(i) * wind(i) - cqs = chs - chs2 = ust(i)*con_karman/fh2(i) - cqs2 = chs2 - qsfcprox = max(qmin,qv1 + evap(i)/cqs) ! surface mix. ratio computed from the flux - - if(.not. diag_flux) then + wrk = 1. - fhi + + if(lsm /= lsm_ruc) then !-- original method - if(lsm /= lsm_ruc) then - if(thsfc_loc) then ! Use local potential temperature - t2m(i)=tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp - else ! Use potential temperature referenced to 1000 hPa - t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp - endif - if(evap(i) >= zero) then ! for evaporation>0, use inferred qsurf to deduce q2m - q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi - else ! for dew formation, use saturated q at tskin - qss = fpvs(tskin(i)) - qss = eps * qss/(ps(i) + epsm1 * qss) - q2m(i) = qss*wrk + max(qmin,q1c)*fhi - endif - else - t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + if(thsfc_loc) then ! Use local potential temperature + t2m(i)=tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp + else ! Use potential temperature referenced to 1000 hPa + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + endif + if(evap(i) >= zero) then ! for evaporation>0, use inferred qsurf to deduce q2m q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi - endif ! RUC lsm - + else ! for dew formation, use saturated q at tskin + qss = fpvs(tskin(i)) + qss = eps * qss/(ps(i) + epsm1 * qss) + q2m(i) = qss*wrk + max(qmin,q1c)*fhi + endif + qss = fpvs(t2m(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q2m(i) = min(q2m(i),qss) else - !-- flux method + !RUC lsm + thcon = (1.e5_kind_phys/ps(i))**con_rocp + !-- make sure 1st level q is not higher than saturated value + qss = fpvs(t1(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q1c = min(q1(i),qss) ! lev 1 spec. humidity + + qv1 = q1c / (one - q1c) ! lev 1 mixing ratio + qsfcmr = qsurf(i)/(one - qsurf(i)) ! surface mixing ratio + chs = cdq(i) * wind(i) + cqs = chs + chs2 = ust(i)*con_karman/fh2(i) + cqs2 = chs2 + qsfcprox = max(qmin,qv1 + evap(i)/cqs) ! surface mix. ratio computed from the flux + + if(diag_flux) then + !-- flux method th2m = tskin(i)*thcon - shflx(i)/chs2 t2m(i) = th2m/thcon - x2m = max(qmin,qsfcprox - evap(i)/cqs2) ! mix. ratio q2m(i) = x2m/(one + x2m) ! spec. humidity - endif ! flux method - - if(diag_log) then - !-- Alternative logarithmic diagnostics: - dT = t1(i) - tskin(i) - dQ = qv1 - qsfcmr - dz1= zf(i) ! level of atm. forcing - IF (dT > zero) THEN - ff = MIN(MAX(one-dT/10._kind_phys,0.01_kind_phys), one) - !for now, set zt = 0.05 - fac = LOG((2._kind_phys + .05_kind_phys)/(0.05_kind_phys + & + else + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi + endif ! flux method + + if(diag_log) then + !-- Alternative logarithmic diagnostics: + dT = t1(i) - tskin(i) + dQ = qv1 - qsfcmr + dz1= zf(i) ! level of atm. forcing + IF (dT > zero) THEN + ff = MIN(MAX(one-dT/10._kind_phys,0.01_kind_phys), one) + !for now, set zt = 0.05 + fac = LOG((2._kind_phys +.05_kind_phys)/(0.05_kind_phys + & & ff))/LOG((dz1 + .05_kind_phys)/(0.05_kind_phys + ff)) - T2_alt = tskin(i) + fac * dT - ELSE - !no alternatives (yet) for unstable conditions - T2_alt = t2m(i) - ENDIF - - IF (dQ > zero) THEN - ff = MIN(MAX(one-dQ/0.003_kind_phys,0.01_kind_phys), one) - !-- for now, set zt = 0.05 - fac = LOG((2._kind_phys + .05_kind_phys)/(0.05_kind_phys + & + T2_alt = tskin(i) + fac * dT + ELSE + !no alternatives (yet) for unstable conditions + T2_alt = t2m(i) + ENDIF + + IF (dQ > zero) THEN + ff = MIN(MAX(one-dQ/0.003_kind_phys,0.01_kind_phys), one) + !-- for now, set zt = 0.05 + fac = LOG((2._kind_phys +.05_kind_phys)/(0.05_kind_phys + & & ff))/LOG((dz1 + .05_kind_phys)/(0.05_kind_phys + ff)) - Q2_alt = qsfcmr + fac * dQ ! mix. ratio - Q2_alt = Q2_alt/(one + Q2_alt) ! spec. humidity - ELSE + Q2_alt = qsfcmr + fac * dQ ! mix. ratio + Q2_alt = Q2_alt/(one + Q2_alt) ! spec. humidity + ELSE !no alternatives (yet) for unstable conditions - Q2_alt = q2m(i) - ENDIF - !-- Note: use of alternative diagnostics will make - ! it cooler and drier with stable stratification - t2m(i) = T2_alt - q2m(i) = Q2_alt - endif ! log method for stable regime - - !-- check that T2m values lie in the range between tskin and t1 - x2m = max(min(tskin(i),t1(i)) , t2m(i)) - t2m(i) = min(max(tskin(i),t1(i)) , x2m) - !-- check that Q2m values lie in the range between qsurf and q1 - x2m = max(min(qsurf(i),q1c) , q2m(i)) - q2m(i) = min(max(qsurf(i),q1c) , x2m) - - !-- make sure q2m is not oversaturated - qss = fpvs(t2m(i)) - qss = eps * qss/(ps(i) + epsm1 * qss) - q2m(i) = min(q2m(i),qss) - - if(diag_flux) then - !-- from WRF, applied in HRRR - Jimy Dudhia - ! Limit Q2m diagnostic to no more than 5 percent higher than lowest level value - ! This prevents unrealistic values when QFX is not mostly surface - ! flux because calculation is based on surface flux only. - ! Problems occurred in transition periods and weak winds and vegetation source - q2m(i) = min(q2m(i),1.05_kind_dbl_prec*q1c) ! works if qsurf > q1c, evaporation - endif - - - !-- Compute dew point, using vapor pressure - qv = max(qmin,(q2m(i)/(1.-q2m(i)))) - tem = max(ps(i) * qv/( eps - epsm1 *qv), qmin) - dpt2m(i) = 243.5_kind_dbl_prec/( ( 17.67_kind_dbl_prec / & + Q2_alt = q2m(i) + ENDIF + !-- Note: use of alternative diagnostics will make + ! it cooler and drier with stable stratification + t2m(i) = T2_alt + q2m(i) = Q2_alt + endif ! log method for stable regime + + !-- check that T2m values lie in the range between tskin and t1 + x2m = max(min(tskin(i),t1(i)) , t2m(i)) + t2m(i) = min(max(tskin(i),t1(i)) , x2m) + !-- check that Q2m values lie in the range between qsurf and q1 + x2m = max(min(qsurf(i),q1c) , q2m(i)) + q2m(i) = min(max(qsurf(i),q1c) , x2m) + + + !-- make sure q2m is not oversaturated + qss = fpvs(t2m(i)) + qss = eps * qss/(ps(i) + epsm1 * qss) + q2m(i) = min(q2m(i),qss) + + if(diag_flux) then + !-- from WRF, applied in HRRR - Jimy Dudhia + ! Limit Q2m diagnostic to no more than 5 percent higher than lowest level value + ! This prevents unrealistic values when QFX is not mostly surface + ! flux because calculation is based on surface flux only. + ! Problems occurred in transition periods and weak winds and vegetation source + q2m(i) = min(q2m(i),1.05_kind_dbl_prec*q1c) ! works if qsurf > q1c, evaporation + endif + + + !-- Compute dew point, using vapor pressure + qv = max(qmin,(q2m(i)/(1.-q2m(i)))) + tem = max(ps(i) * qv/( eps - epsm1 *qv), qmin) + dpt2m(i) = 243.5_kind_dbl_prec/( ( 17.67_kind_dbl_prec / & & log(tem/611.2_kind_dbl_prec) ) - one) + con_t0c - dpt2m(i) = min(dpt2m(i),t2m(i)) + dpt2m(i) = min(dpt2m(i),t2m(i)) - if (debug_print) then - !-- diagnostics for a test point with known lat/lon - if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & + if (debug_print) then + !-- diagnostics for a test point with known lat/lon + if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & & abs(xlon_d(i)-testptlon).lt.0.2)then print 100,'(ruc_lsm_diag) i=',i, & & ' lat,lon=',xlat_d(i),xlon_d(i),'zf ',zf(i), & @@ -212,9 +206,10 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & & 'qsurf ',qsurf(i),'qsfcprox ',qsfcprox,'q2m ',q2m(i), & & 'q1 ',q1(i),'evap ',evap(i),'dpt2m ',dpt2m(i), & & 'chs2 ',chs2,'cqs2 ',cqs2,'cqs ',cqs,'cdq',cdq(i) - endif - endif + endif + endif 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es11.4))) + endif ! RUC LSM enddo @@ -223,4 +218,3 @@ end subroutine sfc_diag_run !> @} end module sfc_diag -!> @} From 1804b5f0140059ee6e691ac148cc5d22521f3a75 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 24 Mar 2023 20:35:48 +0000 Subject: [PATCH 26/28] Use q1(i) instead of q1c in original diagnostics. --- physics/sfc_diag.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index ad132f20e..88305652d 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -96,11 +96,11 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp endif if(evap(i) >= zero) then ! for evaporation>0, use inferred qsurf to deduce q2m - q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi + q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi else ! for dew formation, use saturated q at tskin qss = fpvs(tskin(i)) qss = eps * qss/(ps(i) + epsm1 * qss) - q2m(i) = qss*wrk + max(qmin,q1c)*fhi + q2m(i) = qss*wrk + max(qmin,q1(i))*fhi endif qss = fpvs(t2m(i)) qss = eps * qss / (ps(i) + epsm1 * qss) From fe94d71c0b72174eebb3e50fd4c1b50a037e0e13 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 24 Mar 2023 23:41:54 +0000 Subject: [PATCH 27/28] Replaced double precision zero with 0. as it was in the original version. --- physics/sfc_diag.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 88305652d..169b8493a 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -86,7 +86,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) fhi = fh2(i) / fh(i) - wrk = 1. - fhi + wrk = 1.0 - fhi if(lsm /= lsm_ruc) then !-- original method @@ -95,7 +95,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & else ! Use potential temperature referenced to 1000 hPa t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp endif - if(evap(i) >= zero) then ! for evaporation>0, use inferred qsurf to deduce q2m + if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi else ! for dew formation, use saturated q at tskin qss = fpvs(tskin(i)) From b6337e6f08f69e1d7b4f21f3470534128d806b6d Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 28 Mar 2023 21:40:06 +0000 Subject: [PATCH 28/28] Removed mosaic_lu and mosaic_soil from namelist_soilveg_ruc and set_soilveg_ruc as they are moved to the namelist options in GFS_typedefs.F90. --- physics/namelist_soilveg_ruc.F90 | 2 -- physics/set_soilveg_ruc.F90 | 9 +-------- 2 files changed, 1 insertion(+), 10 deletions(-) diff --git a/physics/namelist_soilveg_ruc.F90 b/physics/namelist_soilveg_ruc.F90 index d71d2ebfd..d93dc5c64 100644 --- a/physics/namelist_soilveg_ruc.F90 +++ b/physics/namelist_soilveg_ruc.F90 @@ -45,7 +45,6 @@ module namelist_soilveg_ruc INTEGER DEFINED_VEG INTEGER DEFINED_SOIL INTEGER DEFINED_SLOPE - INTEGER MOSAIC_LU !> -- soils real(kind_phys) BB(MAX_SOILTYP) real(kind_phys) DRYSMC(MAX_SOILTYP) @@ -63,5 +62,4 @@ module namelist_soilveg_ruc real(kind_phys) SATDKnoah(MAX_SOILTYP) real(kind_phys) SATPSInoah(MAX_SOILTYP) real(kind_phys) MAXSMCnoah(MAX_SOILTYP) - INTEGER MOSAIC_SOIL end module namelist_soilveg_ruc diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index f04a49648..7c4f0ffdf 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -36,8 +36,7 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) & RSMAX_DATA, BARE, GLACIER, NATURAL, CROP, URBAN, & & DEFINED_VEG, DEFINED_SOIL, DEFINED_SLOPE, & & BB, DRYSMC, HC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, & - & WLTSMC, QTZ, mosaic_soil, mosaic_lu, & - & REFSMCnoah, WLTSMCnoah, MAXSMCnoah + & WLTSMC, QTZ, REFSMCnoah, WLTSMCnoah, MAXSMCnoah ! Initialize error-handling errflg = 0 @@ -235,9 +234,6 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) endif ! end if veg table -! - set mosaic_lu=1 when info for fractional landuse is available - mosaic_lu = 0 - topt_data =298.0 cmcmax_data =0.2e-3 cfactr_data =0.5 @@ -440,9 +436,6 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) endif END DO -! - set mosaic_soil=1 when info for fractional landuse is available - mosaic_soil = 0 - ! PT 5/18/2015 - changed to FALSE to match atm_namelist setting ! PT LPARAM is not used anywhere LPARAM =.FALSE.