From f0117dfcf75a5fd0ea74383ae2b0f36c3df9d48e Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 12 Oct 2023 16:27:32 +0000 Subject: [PATCH 01/10] Changes in RUC LSM: 1. adding a heat source from fires. It is icontrolled by a flag and not turned on yet. Needs more testing. 2. Adding output of surface paramteres: leaf area index (LAI), wilting point and soil field capacity. --- physics/lsm_ruc.F90 | 105 ++++++++++++++++++++++++----------- physics/lsm_ruc.meta | 17 +++++- physics/module_sf_ruclsm.F90 | 29 +++++++++- 3 files changed, 115 insertions(+), 36 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 665fe6d14..d3754b68c 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -359,6 +359,7 @@ subroutine lsm_ruc_run & ! inputs & qsurf_ice, gflux_ice, evap_ice, ep1d_ice, hflx_ice, & & cm_ice, ch_ice, snowfallac_ice, acsnow_ice, snowmt_ice, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & + & add_fire_heat_flux, fire_heat_flux_out, & ! --- out & rhosnf, sbsno, & & cmm_lnd, chh_lnd, cmm_ice, chh_ice, & @@ -381,7 +382,7 @@ subroutine lsm_ruc_run & ! inputs real (kind_phys), dimension(:), intent(in) :: oro, sigma real (kind_phys), dimension(:), intent(in) :: & - & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & + & t1, sigmaf, dlwflx, dswsfc, tg3, & & coszen, prsl1, wind, shdmin, shdmax, & & sfalb_lnd_bck, snoalb, zf, qc, q1, & ! for land @@ -417,7 +418,7 @@ subroutine lsm_ruc_run & ! inputs real (kind_phys), dimension(:), intent(in) :: zs real (kind_phys), dimension(:), intent(in) :: srflag real (kind_phys), dimension(:), intent(inout) :: & - & canopy, trans, smcwlt2, smcref2, & + & canopy, trans, smcwlt2, smcref2, laixy, & ! for land & weasd_lnd, snwdph_lnd, tskin_lnd, & & tsurf_lnd, z0rl_lnd, tsnow_lnd, & @@ -430,6 +431,8 @@ subroutine lsm_ruc_run & ! inputs ! --- in real (kind_phys), dimension(:), intent(in) :: & & rainnc, rainc, ice, snow, graupel, rhonewsn1 + real (kind_phys), dimension(:), intent(in) :: fire_heat_flux_out + logical, intent(in) :: add_fire_heat_flux ! --- in/out: ! --- on RUC levels real (kind_phys), dimension(:,:), intent(inout) :: & @@ -505,12 +508,13 @@ subroutine lsm_ruc_run & ! inputs & solnet_lnd, sfcexc, & & runoff1, runoff2, acrunoff, semis_bck, & & sfcems_lnd, hfx_lnd, shdfac, shdmin1d, shdmax1d, & + & fire_heat_flux1d, & & sneqv_lnd, snoalb1d_lnd, snowh_lnd, snoh_lnd, tsnav_lnd, & & snomlt_lnd, sncovr_lnd, soilw, soilm, ssoil_lnd, & & soilt_lnd, tbot, & & xlai, swdn, z0_lnd, znt_lnd, rhosnfr, infiltr, & - & precipfr, snfallac_lnd, acsn_lnd, & - & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq + & precipfr, snfallac_lnd, acsn_lnd, soilt1_lnd, chklowq, & + & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, smcwlt, smcref ! ice real (kind_phys),dimension (im,1) :: & & albbck_ice, alb_ice, chs_ice, flhc_ice, flqc_ice, & @@ -540,7 +544,7 @@ subroutine lsm_ruc_run & ! inputs integer :: l, k, i, j, fractional_seaice, ilst real (kind_phys) :: dm, cimin(im) logical :: flag(im), flag_ice(im), flag_ice_uncoupled(im) - logical :: rdlai2d, myj, frpcpn + logical :: myj, frpcpn logical :: debug_print !-- diagnostic point @@ -645,15 +649,38 @@ subroutine lsm_ruc_run & ! inputs nsoil = lsoil_ruc do i = 1, im ! i - horizontal loop - ! reassign smcref2 and smcwlt2 to RUC values - if(.not. land(i)) then - !water and sea ice - smcref2 (i) = one - smcwlt2 (i) = zero + ! reassign smcref2 and smcwlt2 to RUC values at kdt=1 + if(kdt == 1) then + if(.not. land(i)) then + !water and sea ice + smcref (i,1) = one + smcwlt (i,1) = zero + xlai (i,1) = zero + else + !land + smcref (i,1) = REFSMC(stype(i)) + smcwlt (i,1) = WLTSMC(stype(i)) + + !-- rdlai is .true. when the LAI data is available in the INPUT/sfc_data.nc on cold-start + if(rdlai) then + xlai(i,1) = laixy(i) + else + xlai(i,1) = LAITBL(vtype(i)) + endif + endif else - !land - smcref2 (i) = REFSMC(stype(i)) - smcwlt2 (i) = WLTSMC(stype(i)) + !-- if kdt > 1, parameters with sub-grid heterogeneity + if(.not. land(i)) then + !water and sea ice + smcref (i,1) = one + smcwlt (i,1) = zero + xlai (i,1) = zero + else + !land + smcref (i,1) = smcref2 (i) + smcwlt (i,1) = smcwlt2 (i) + xlai (i,1) = laixy (i) + endif endif enddo @@ -813,10 +840,6 @@ subroutine lsm_ruc_run & ! inputs ffrozp(i,j) = real(nint(srflag(i)),kind_phys) endif - !-- rdlai is .false. when the LAI data is not available in the - ! - INPUT/sfc_data.nc - - rdlai2d = rdlai conflx2(i,1,j) = zf(i) * 2._kind_phys ! factor 2. is needed to get the height of ! atm. forcing inside RUC LSM (inherited @@ -843,14 +866,15 @@ subroutine lsm_ruc_run & ! inputs !!\n \a graupelncv - time-step graupel (\f$kg m^{-2} \f$) !!\n \a snowncv - time-step snow (\f$kg m^{-2} \f$) !!\n \a precipfr - time-step precipitation in solid form (\f$kg m^{-2} \f$) -!!\n \a shdfac - areal fractional coverage of green vegetation (0.0-1.0) -!!\n \a shdmin - minimum areal fractional coverage of green vegetation -> !shdmin1d -!!\n \a shdmax - maximum areal fractional coverage of green vegetation -> !shdmax1d +!!\n \a shdfac - areal fractional coverage of green vegetation (0.0-100.%) +!!\n \a shdmin - minimum areal fractional coverage of green vegetation in % -> !shdmin1d +!!\n \a shdmax - maximum areal fractional coverage of green vegetation in % -> !shdmax1d !!\n \a tbot - bottom soil temperature (local yearly-mean sfc air temp) lwdn(i,j) = dlwflx(i) !..downward lw flux at sfc in w/m2 swdn(i,j) = dswsfc(i) !..downward sw flux at sfc in w/m2 + ! all precip input to RUC LSM is in [mm] !prcp(i,j) = rhoh2o * tprcp(i) ! tprcp in [m] - convective plus explicit !raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip @@ -918,17 +942,12 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'MODIS landuse is not available' endif - if(rdlai2d) then - xlai(i,j) = laixy(i) - else - xlai(i,j) = zero - endif - semis_bck(i,j) = semisbase(i) ! --- units % shdfac(i,j) = sigmaf(i)*100._kind_phys shdmin1d(i,j) = shdmin(i)*100._kind_phys shdmax1d(i,j) = shdmax(i)*100._kind_phys + fire_heat_flux1d(i,j) = fire_heat_flux_out(i) ! JLS if (land(i)) then ! at least some land in the grid cell @@ -976,6 +995,12 @@ subroutine lsm_ruc_run & ! inputs snoalb1d_lnd(i,j) = snoalb(i) albbck_lnd(i,j) = min(0.9_kind_phys,albbcksol(i)) !sfalb_lnd_bck(i) + IF ( add_fire_heat_flux .and. fire_heat_flux_out(i) > 0) then ! JLS + ! limit albedo and greenness in the areas affected by the fire + albbck_lnd(i,j) = min(0.1_kind_phys,albbck_lnd(i,j)) + shdfac(i,j) = min(50._kind_phys,shdfac(i,j)) ! % + ENDIF + !-- spp_lsm if (spp_lsm == 1) then @@ -1163,7 +1188,7 @@ subroutine lsm_ruc_run & ! inputs & wet(i,j), cmc(i,j), shdfac(i,j), alb_lnd(i,j), znt_lnd(i,j), & & z0_lnd(i,j), snoalb1d_lnd(i,j), albbck_lnd(i,j), & & xlai(i,j), landusef(i,:,j), nlcat, & - & soilctop(i,:,j), nscat, & + & soilctop(i,:,j), nscat, smcwlt(i,j), smcref(i,j), & & qsfc_lnd(i,j), qsg_lnd(i,j), qvg_lnd(i,j), qcg_lnd(i,j), & & dew_lnd(i,j), soilt1_lnd(i,j), & & tsnav_lnd(i,j), tbot(i,j), vtype_lnd(i,j), stype_lnd(i,j), & @@ -1178,8 +1203,9 @@ subroutine lsm_ruc_run & ! inputs & infiltr(i,j), runoff1(i,j), runoff2(i,j), acrunoff(i,j), & & sfcexc(i,j), acceta(i,j), ssoil_lnd(i,j), & & snfallac_lnd(i,j), acsn_lnd(i,j), snomlt_lnd(i,j), & - & smfrsoil(i,:,j),keepfrsoil(i,:,j), .false., & - & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & + & smfrsoil(i,:,j),keepfrsoil(i,:,j), & + & add_fire_heat_flux,fire_heat_flux1d(i,j), .false., & + & shdmin1d(i,j), shdmax1d(i,j), rdlai, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte, errmsg, errflg ) if(debug_print) then @@ -1218,7 +1244,7 @@ subroutine lsm_ruc_run & ! inputs 'ssoil(i,j) =',ssoil_lnd(i,j), & 'snfallac(i,j) =',snfallac_lnd(i,j), & 'acsn_lnd(i,j) =',acsn_lnd(i,j), & - 'snomlt(i,j) =',snomlt_lnd(i,j) + 'snomlt(i,j) =',snomlt_lnd(i,j),'xlai(i,j) =',xlai(i,j) endif endif @@ -1289,6 +1315,10 @@ subroutine lsm_ruc_run & ! inputs ! --- ... unit conversion (from m to mm) snwdph_lnd(i) = snowh_lnd(i,j) * rhoh2o + laixy(i) = xlai(i,j) + smcwlt2(i) = smcwlt(i,j) + smcref2(i) = smcref(i,j) + canopy(i) = cmc(i,j) ! mm weasd_lnd(i) = sneqv_lnd(i,j) ! mm sncovr1_lnd(i) = sncovr_lnd(i,j) @@ -1318,6 +1348,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'LAND -i,j,stype_lnd,vtype_lnd',i,j,stype_lnd(i,j),vtype_lnd(i,j) write (0,*)'i,j,tsurf_lnd(i)',i,j,tsurf_lnd(i) write (0,*)'kdt,iter,stsoil(i,:,j)',kdt,iter,stsoil(i,:,j) + write (0,*)'laixy(i)',laixy(i) endif endif ! end of land @@ -1449,7 +1480,7 @@ subroutine lsm_ruc_run & ! inputs & wet_ice(i,j), cmc(i,j), shdfac(i,j), alb_ice(i,j), & & znt_ice(i,j), z0_ice(i,j), snoalb1d_ice(i,j), & & albbck_ice(i,j), xlai(i,j),landusef(i,:,j), nlcat, & - & soilctop(i,:,j), nscat, & + & soilctop(i,:,j), nscat, smcwlt(i,j), smcref(i,j), & & qsfc_ice(i,j), qsg_ice(i,j), qvg_ice(i,j), qcg_ice(i,j), & & dew_ice(i,j), soilt1_ice(i,j), & & tsnav_ice(i,j), tbot(i,j), vtype_ice(i,j), stype_ice(i,j), & @@ -1464,8 +1495,9 @@ subroutine lsm_ruc_run & ! inputs & infiltr(i,j), runoff1(i,j), runoff2(i,j), acrunoff(i,j), & & sfcexc(i,j), acceta(i,j), ssoil_ice(i,j), & & snfallac_ice(i,j), acsn_ice(i,j), snomlt_ice(i,j), & - & smfrice(i,:,j),keepfrice(i,:,j), .false., & - & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & + & smfrice(i,:,j),keepfrice(i,:,j), & + & add_fire_heat_flux,fire_heat_flux1d(i,j), .false., & + & shdmin1d(i,j), shdmax1d(i,j), rdlai, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte, & & errmsg, errflg) @@ -1502,6 +1534,10 @@ subroutine lsm_ruc_run & ! inputs albivis_ice(i) = sfalb_ice(i) albinir_ice(i) = sfalb_ice(i) + laixy(i) = zero + smcwlt2(i) = zero + smcref2(i) = one + stm(i) = 3.e3_kind_phys ! kg m-2 do k = 1, lsoil_ruc tsice(i,k) = stsice(i,k,j) @@ -1517,6 +1553,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'ICE - i,j,stype_ice,vtype_ice)',i,j,stype_ice(i,j),vtype_ice(i,j) write (0,*)'i,j,tsurf_ice(i)',i,j,tsurf_ice(i) write (0,*)'kdt,iter,stsice(i,:,j)',kdt,iter,stsice(i,:,j) + write (0,*)'laixy(i)',laixy(i) endif endif ! ice @@ -1762,6 +1799,8 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in tbot(i,j) = tg3(i) ivgtyp(i,j) = vtype(i) isltyp(i,j) = stype(i) + if(isltyp(i,j)==0) isltyp(i,j)=14 + if(ivgtyp(i,j)==0) ivgtyp(i,j)=17 if (landfrac(i) > zero .or. fice(i) > zero) then !-- land or ice tsk(i,j) = tskin_lnd(i) diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 34a5b8a8b..4cc6a9419 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -813,7 +813,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in + intent = inout [dlwflx] standard_name = surface_downwelling_longwave_flux long_name = surface downwelling longwave flux at current time @@ -1747,6 +1747,21 @@ dimensions = () type = logical intent = in +[add_fire_heat_flux] + standard_name = flag_for_fire_heat_flux + long_name = flag to add fire heat flux to LSM + units = flag + dimensions = () + type = logical + intent = in +[fire_heat_flux_out] + standard_name = surface_fire_heat_flux + long_name = heat flux of fire at the surface + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 160127e43..2bb29d440 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -97,6 +97,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & MAVAIL,CANWAT,VEGFRA, & ALB,ZNT,Z0,SNOALB,ALBBCK,LAI, & landusef, nlcat, soilctop, nscat, & + smcwlt, smcref, & QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, & TBOT,IVGTYP,ISLTYP,XLAND, & ISWATER,ISICE,XICE,XICE_THRESHOLD, & @@ -107,6 +108,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & RUNOFF1,RUNOFF2,ACRUNOFF,SFCEXC, & SFCEVP,GRDFLX,SNOWFALLAC,ACSNOW,SNOM, & SMFR3D,KEEPFR3DFLAG, & + add_fire_heat_flux,fire_heat_flux, & myj,shdmin,shdmax,rdlai2d, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -239,6 +241,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev + LOGICAL, intent(in) :: add_fire_heat_flux + real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: fire_heat_flux LOGICAL, intent(in) :: rdlai2d real (kind_phys), DIMENSION( 1:nsl), INTENT(IN ) :: ZS @@ -252,6 +256,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & SNOALB, & ALB, & LAI, & + SMCWLT, & + SMCREF, & EMISS, & EMISBCK, & MAVAIL, & @@ -757,6 +763,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & !-- update background emissivity for land points, can have vegetation mosaic effect EMISBCK(I,J) = EMISSL(I,J) + smcwlt(i,j) = wilt + smcref(i,j) = ref IF (debug_print ) THEN if(init)then @@ -961,6 +969,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & snoalb(i,j),albbck(i,j),lai(i,j), & hgt(i,j),stdev(i,j), & !new myj,seaice(i,j),isice, & + add_fire_heat_flux,fire_heat_flux(i,j), & !--- soil fixed fields QWRTZ, & rhocs,dqm,qmin,ref, & @@ -1212,6 +1221,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia QKMS,TKMS,PC,MAVAIL,CST,VEGFRA,ALB,ZNT, & ALB_SNOW,ALB_SNOW_FREE,lai,hgt,stdev, & MYJ,SEAICE,ISICE, & + add_fire_heat_flux,fire_heat_flux, & QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & !--- soil fixed fields sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & cp,rovcp,g0,lv,stbolt,cw,c1sn,c2sn, & !--- constants @@ -1256,7 +1266,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SEAICE, & RHO, & QKMS, & - TKMS + TKMS, & + fire_heat_flux + LOGICAL, INTENT(IN ) :: add_fire_heat_flux INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP !--- 2-D variables @@ -1813,6 +1825,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia UPFLUX = T3 *SOILT XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET + IF ( add_fire_heat_flux ) then ! JLS + RNET = RNET + fire_heat_flux + ENDIF + IF (debug_print ) THEN print *,'Fractional snow - snowfrac=',snowfrac print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet @@ -1933,6 +1949,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if (SEAICE .LT. 0.5_kind_phys) then ! LAND + IF ( add_fire_heat_flux ) then ! JLS + RNET = RNET + fire_heat_flux + ENDIF if(snow_mosaic==one)then snfr=one else @@ -2049,6 +2068,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia eeta = eetas*(one-snowfrac) + eeta*snowfrac qfx = qfxs*(one-snowfrac) + qfx*snowfrac hfx = hfxs*(one-snowfrac) + hfx*snowfrac + !IF ( add_fire_heat_flux ) then ! JLS + ! hfx = hfx + fire_heat_flux + !ENDIF s = ss*(one-snowfrac) + s*snowfrac evapl = evapls*(one-snowfrac) sublim = sublim*snowfrac @@ -2094,6 +2116,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia eeta = eetas*(one-snowfrac) + eeta*snowfrac qfx = qfxs*(one-snowfrac) + qfx*snowfrac hfx = hfxs*(one-snowfrac) + hfx*snowfrac + !IF ( add_fire_heat_flux ) then ! JLS + ! hfx = hfx + fire_heat_flux + !ENDIF s = ss*(one-snowfrac) + s*snowfrac prcpl = prcpls*(one-snowfrac) + prcpl*snowfrac fltot = fltots*(one-snowfrac) + fltot*snowfrac @@ -6611,7 +6636,7 @@ SUBROUTINE TRANSF( debug_print, & /(REF-WILT)*DID ENDIF !-- uncomment next line for non-linear root distribution -! TRANF(k)=part(k) + TRANF(k)=part(k) END DO ! For LAI> 3 => transpiration at potential rate (F.Tardieu, 2013) From 876a1ac17df62f40a936418da7f22b15923bc10c Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 12 Oct 2023 19:34:14 +0000 Subject: [PATCH 02/10] Fire heat flux computation is added to the smoke-dust code. --- physics/smoke_dust/module_plumerise1.F90 | 4 ++++ physics/smoke_dust/module_smoke_plumerise.F90 | 12 ++++++++++-- physics/smoke_dust/rrfs_smoke_wrapper.F90 | 13 ++++++++++--- physics/smoke_dust/rrfs_smoke_wrapper.meta | 8 ++++++++ 4 files changed, 32 insertions(+), 5 deletions(-) diff --git a/physics/smoke_dust/module_plumerise1.F90 b/physics/smoke_dust/module_plumerise1.F90 index 3c23faa6a..189bf981a 100755 --- a/physics/smoke_dust/module_plumerise1.F90 +++ b/physics/smoke_dust/module_plumerise1.F90 @@ -38,6 +38,7 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & t_phy,q_vap, & ! RAR: moist is replaced with q_vap rho_phy,vvel,u_phy,v_phy,p_phy, & z_at_w,z,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags + fire_heat_flux,dxy, & plume_frp, k_min, k_max, & ! RAR: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -66,6 +67,8 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & real(kind=kind_phys), INTENT(IN ) :: g, con_cp, con_rd real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ebb_smoke real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: flam_frac + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: fire_heat_flux + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: dxy ! real(kind=kind_phys), DIMENSION( ims:ime, 1, jms:jme ), & ! INTENT(IN ) :: ebu_in @@ -184,6 +187,7 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & !num_ebu, eburn_in, eburn_out, & u_in, v_in, w_in, theta_in ,pi_in, & rho_phyin, qv_in, zmid, z_lev, & + fire_heat_flux(i,j),dxy(i,j), & plume_frp(i,j,1), k_min(i,j), & k_max(i,j), dbg_opt, g, con_cp, & con_rd, cpor, errmsg, errflg ) diff --git a/physics/smoke_dust/module_smoke_plumerise.F90 b/physics/smoke_dust/module_smoke_plumerise.F90 index 61be06181..9c0dfa49d 100755 --- a/physics/smoke_dust/module_smoke_plumerise.F90 +++ b/physics/smoke_dust/module_smoke_plumerise.F90 @@ -28,6 +28,7 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & ! firesize,mean_fct, & ! nspecies,eburn_in,eburn_out, & up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & + fire_heat_flux, dxy, & frp_inst,k1,k2, dbg_opt, g, cp, rgas, & cpor, errmsg, errflg ) @@ -43,6 +44,9 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & integer :: ng,m1,m2,m3,ia,iz,ja,jz,ibcon,mynum,i,j,k,imm,ixx,ispc !,nspecies + real(kind=kind_phys), intent(in) :: dxy + real(kind=kind_phys), intent(out) :: fire_heat_flux ! JLS + INTEGER, INTENT (OUT) :: k1,k2 character(*), intent(inout) :: errmsg integer, intent(inout) :: errflg @@ -106,6 +110,7 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & IF (frp_inst Date: Thu, 12 Oct 2023 21:31:36 +0000 Subject: [PATCH 03/10] Fix the segmentation fault error in computing fire heat flux. --- physics/smoke_dust/rrfs_smoke_wrapper.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.F90 b/physics/smoke_dust/rrfs_smoke_wrapper.F90 index f9b15a494..e6a398363 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.F90 +++ b/physics/smoke_dust/rrfs_smoke_wrapper.F90 @@ -353,10 +353,10 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, errmsg, errflg ) if(errflg/=0) return - end if - do i = its,ite + do i = its,ite fire_heat_flux_out(i) = min(max(0.,fire_heat_flux(i,1)),50000.) ! JLS - W m-2 [0 - 10,000] - enddo + enddo + end if ! -- add biomass burning emissions at every timestep if (addsmoke_flag == 1) then call add_emis_burn(dt,dz8w,rho_phy,rel_hum,chem, & From fe5322b0da1fa904f1cb36ff8b1a99b67c14495f Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 18 Oct 2023 18:53:03 +0000 Subject: [PATCH 04/10] Addressed the reviewer's comments. --- physics/lsm_ruc.F90 | 47 +++++++++++++++++---------------------------- 1 file changed, 18 insertions(+), 29 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index d3754b68c..79bcbf7b1 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -649,38 +649,27 @@ subroutine lsm_ruc_run & ! inputs nsoil = lsoil_ruc do i = 1, im ! i - horizontal loop - ! reassign smcref2 and smcwlt2 to RUC values at kdt=1 - if(kdt == 1) then - if(.not. land(i)) then - !water and sea ice - smcref (i,1) = one - smcwlt (i,1) = zero - xlai (i,1) = zero + if(.not. land(i)) then + !water and sea ice + smcref (i,1) = one + smcwlt (i,1) = zero + xlai (i,1) = zero + elseif (kdt == 1) then + !land + ! reassign smcref2 and smcwlt2 to RUC values at kdt=1 + smcref (i,1) = REFSMC(stype(i)) + smcwlt (i,1) = WLTSMC(stype(i)) + !-- rdlai is .true. when the LAI data is available in the INPUT/sfc_data.nc on cold-start + if(rdlai) then + xlai(i,1) = laixy(i) else - !land - smcref (i,1) = REFSMC(stype(i)) - smcwlt (i,1) = WLTSMC(stype(i)) - - !-- rdlai is .true. when the LAI data is available in the INPUT/sfc_data.nc on cold-start - if(rdlai) then - xlai(i,1) = laixy(i) - else - xlai(i,1) = LAITBL(vtype(i)) - endif + xlai(i,1) = LAITBL(vtype(i)) endif else - !-- if kdt > 1, parameters with sub-grid heterogeneity - if(.not. land(i)) then - !water and sea ice - smcref (i,1) = one - smcwlt (i,1) = zero - xlai (i,1) = zero - else - !land - smcref (i,1) = smcref2 (i) - smcwlt (i,1) = smcwlt2 (i) - xlai (i,1) = laixy (i) - endif + !-- land and kdt > 1, parameters has sub-grid heterogeneity + smcref (i,1) = smcref2 (i) + smcwlt (i,1) = smcwlt2 (i) + xlai (i,1) = laixy (i) endif enddo From 056f42021aa0a12715bbc07bfe85a2222759b41b Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 18 Oct 2023 19:00:20 +0000 Subject: [PATCH 05/10] Changes in module_sf_ruclsm.F90: 1. Removed commented lines in fire feedback to RUC LSM. 2. The coordinates of a test point are passed to the RUC LSM subroutines to make debug printing more manageable. 3. Reverted change in the TRANSF subroutine to original version. The non-linear root distribution needs scientific evaluation in the retro runs. --- physics/module_sf_ruclsm.F90 | 119 +++++++++++++++++++++++------------ 1 file changed, 79 insertions(+), 40 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 2bb29d440..83d7a04d6 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -1853,7 +1853,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ilands = ivgtyp - CALL SOIL(debug_print,xlat,xlon, & + CALL SOIL(debug_print,xlat, xlon, testptlat, testptlon,& !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,gswin, & @@ -2068,9 +2068,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia eeta = eetas*(one-snowfrac) + eeta*snowfrac qfx = qfxs*(one-snowfrac) + qfx*snowfrac hfx = hfxs*(one-snowfrac) + hfx*snowfrac - !IF ( add_fire_heat_flux ) then ! JLS - ! hfx = hfx + fire_heat_flux - !ENDIF s = ss*(one-snowfrac) + s*snowfrac evapl = evapls*(one-snowfrac) sublim = sublim*snowfrac @@ -2116,9 +2113,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia eeta = eetas*(one-snowfrac) + eeta*snowfrac qfx = qfxs*(one-snowfrac) + qfx*snowfrac hfx = hfxs*(one-snowfrac) + hfx*snowfrac - !IF ( add_fire_heat_flux ) then ! JLS - ! hfx = hfx + fire_heat_flux - !ENDIF s = ss*(one-snowfrac) + s*snowfrac prcpl = prcpls*(one-snowfrac) + prcpl*snowfrac fltot = fltots*(one-snowfrac) + fltot*snowfrac @@ -2248,7 +2242,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(SEAICE .LT. 0.5_kind_phys) then ! LAND - CALL SOIL(debug_print,xlat,xlon, & + CALL SOIL(debug_print,xlat, xlon, testptlat, testptlon,& !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,GSWin, & @@ -2341,7 +2335,7 @@ END FUNCTION QSN !>\ingroup lsm_ruc_group !> This subroutine calculates energy and moisture budget for vegetated surfaces !! without snow, heat diffusion and Richards eqns in soil. - SUBROUTINE SOIL (debug_print,xlat,xlon, & + SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,& !--- input variables PRCPMS,RAINF,PATM,QVATM,QCATM, & GLW,GSW,GSWin,EMISS,RNET, & @@ -2423,7 +2417,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon + real (kind_phys), INTENT(IN ) :: DELT,CONFLX + real (kind_phys), INTENT(IN ) :: xlat,xlon,testptlat,testptlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables real (kind_phys), & @@ -2647,6 +2642,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! hydraulic condeuctivities !****************************************************************** CALL SOILPROP( debug_print, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,fwsat,lwsat,tav,keepfr, & soilmois,soiliqw,soilice, & @@ -2682,6 +2678,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! TRANSF computes transpiration function !************************************************************** CALL TRANSF(debug_print, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,nroot,soiliqw,tabs,lai,gswin, & !--- soil fixed fields @@ -2739,7 +2736,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! SOILTEMP soilves heat budget and diffusion eqn. in soil !************************************************************** - CALL SOILTEMP(debug_print,xlat,xlon, & + CALL SOILTEMP(debug_print,xlat,xlon,testptlat,testptlon,& !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & @@ -2809,6 +2806,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! and Richards eqn. !************************************************************************* CALL SOILMOIST (debug_print, & + xlat, xlon, testptlat, testptlon, & !-- input delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & zsmain,zshalf,diffu,hydro, & @@ -3603,6 +3601,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ! hydraulic condeuctivities !****************************************************************** CALL SOILPROP(debug_print, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,fwsat,lwsat,tav,keepfr, & soilmois,soiliqw,soilice, & @@ -3653,6 +3652,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ! TRANSF computes transpiration function !************************************************************** CALL TRANSF(debug_print, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,nroot,soiliqw,tabs,lai,gswin, & !--- soil fixed fields @@ -3748,7 +3748,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- TQCAN FOR SOLUTION OF MOISTURE BALANCE (Smirnova et al. 1996, EQ.22,28) ! AND TSO,ETA PROFILES !************************************************************************* - CALL SOILMOIST (debug_print, & + CALL SOILMOIST (debug_print,xlat,xlon,testptlat,testptlon,& !-- input delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & zsmain,zshalf,diffu,hydro, & @@ -4704,7 +4704,7 @@ END SUBROUTINE SNOWSEAICE !>\ingroup lsm_ruc_group !> This subroutine solves energy budget equation and heat diffusion !! equation. - SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & + SUBROUTINE SOILTEMP( debug_print,xlat,xlon,testptlat,testptlon,& i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,TABS,QVATM,QCATM, & @@ -4774,7 +4774,8 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF + real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon real (kind_phys), INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables real (kind_phys), & @@ -5984,6 +5985,7 @@ END SUBROUTINE SNOWTEMP !! This subroutine solves moisture budget and computes soil moisture !! and surface and sub-surface runoffs. SUBROUTINE SOILMOIST ( debug_print, & + xlat, xlon, testptlat, testptlon, & DELT,NZS,NDDZS,DTDZS,DTDZS2,RIW, & !--- input parameters ZSMAIN,ZSHALF,DIFFU,HYDRO, & QSG,QVG,QCG,QCATM,QVATM,PRCP, & @@ -6037,6 +6039,7 @@ SUBROUTINE SOILMOIST ( debug_print, & !--- input variables LOGICAL, INTENT(IN ) :: debug_print real (kind_phys), INTENT(IN ) :: DELT + real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon INTEGER, INTENT(IN ) :: NZS,NDDZS ! input variables @@ -6124,8 +6127,12 @@ SUBROUTINE SOILMOIST ( debug_print, & DENOM=one+X2+X4-Q2*COSMC(K) COSMC(K+1)=Q4/DENOM IF (debug_print ) THEN - print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' & - ,q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' & + ,q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k + endif ENDIF RHSMC(K+1)=(SOILMOIS(KN)+Q2*RHSMC(K) & +TRANSP(KN) & @@ -6156,8 +6163,12 @@ SUBROUTINE SOILMOIST ( debug_print, & TOTLIQ=PRCP-DRIP/DELT-(one-VEGFRAC)*DEW*RAS-SMELT IF (debug_print ) THEN -print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & - UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & + UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT + endif ENDIF FLX=TOTLIQ @@ -6200,7 +6211,7 @@ SUBROUTINE SOILMOIST ( debug_print, & INFMAX1 = zero ENDIF IF (debug_print ) THEN - print *,'INFMAX1 before frozen part',INFMAX1 + print *,'INFMAX1 before frozen part',INFMAX1 ENDIF ! ----------- FROZEN GROUND VERSION -------------------------- @@ -6234,8 +6245,8 @@ SUBROUTINE SOILMOIST ( debug_print, & INFMAX = MAX(INFMAX1,HYDRO(1)*SOILMOIS(1)) INFMAX = MIN(INFMAX, -TOTLIQ) IF (debug_print ) THEN -print *,'INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ', & - INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ + print *,'INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ', & + INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ ENDIF !---- IF (-TOTLIQ.GT.INFMAX)THEN @@ -6285,8 +6296,12 @@ SUBROUTINE SOILMOIST ( debug_print, & END IF IF (debug_print ) THEN - print *,'SOILMOIS,SOILIQW, soilice',SOILMOIS,SOILIQW,soilice*riw - print *,'COSMC,RHSMC',COSMC,RHSMC + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'SOILMOIS,SOILIQW, soilice',SOILMOIS,SOILIQW,soilice*riw + print *,'COSMC,RHSMC',COSMC,RHSMC + endif ENDIF !--- FINAL SOLUTION FOR SOILMOIS ! DO K=2,NZS1 @@ -6312,7 +6327,11 @@ SUBROUTINE SOILMOIST ( debug_print, & END IF END DO IF (debug_print ) THEN - print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw + endif ENDIF MAVAIL=max(.00001_kind_phys,min(one,(SOILMOIS(1)/(REF-QMIN)*(one-snowfrac)+one*snowfrac))) @@ -6324,6 +6343,7 @@ END SUBROUTINE SOILMOIST !! This subroutine computes thermal diffusivity, and diffusional and !! hydraulic condeuctivities in soil. SUBROUTINE SOILPROP( debug_print, & + xlat, xlon, testptlat, testptlon, & nzs,fwsat,lwsat,tav,keepfr, & !--- input variables soilmois,soiliqw,soilice, & soilmoism,soiliqwm,soilicem, & @@ -6357,6 +6377,8 @@ SUBROUTINE SOILPROP( debug_print, & !--- soil properties LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: NZS + real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon + real (kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & @@ -6533,6 +6555,7 @@ END SUBROUTINE SOILPROP !> This subroutine solves the transpiration function (EQs. 18,19 in !! Smirnova et al.(1997) \cite Smirnova_1997) SUBROUTINE TRANSF( debug_print, & + xlat,xlon,testptlat,testptlon, & nzs,nroot,soiliqw,tabs,lai,gswin, & !--- input variables dqm,qmin,ref,wilt,zshalf,pc,iland, & !--- soil fixed fields tranf,transum) !--- output variables @@ -6553,6 +6576,7 @@ SUBROUTINE TRANSF( debug_print, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: nroot,nzs,iland + real (kind_phys), INTENT(IN ) :: xlat,xlon,testptlat,testptlon real (kind_phys) , & INTENT(IN ) :: GSWin, TABS, lai @@ -6599,7 +6623,7 @@ SUBROUTINE TRANSF( debug_print, & ap4=59.656_kind_phys gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4 if(totliq.ge.ref) gx=one - if(totliq.le.zero) gx=zero + if(totliq.le.wilt) gx=zero if(gx.gt.one) gx=one if(gx.lt.zero) gx=zero DID=zshalf(2) @@ -6612,7 +6636,7 @@ SUBROUTINE TRANSF( debug_print, & TRANF(1)=(TOTLIQ-WILT)/(REF-WILT)*DID ENDIF !-- uncomment next line for non-linear root distribution - TRANF(1)=part(1) + !TRANF(1)=part(1) DO K=2,NROOT totliq=soiliqw(k)+qmin @@ -6622,7 +6646,7 @@ SUBROUTINE TRANSF( debug_print, & sm4=sm3*sm1 gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4 if(totliq.ge.ref) gx=one - if(totliq.le.zero) gx=zero + if(totliq.le.wilt) gx=zero if(gx.gt.one) gx=one if(gx.lt.zero) gx=zero DID=zshalf(K+1)-zshalf(K) @@ -6636,8 +6660,16 @@ SUBROUTINE TRANSF( debug_print, & /(REF-WILT)*DID ENDIF !-- uncomment next line for non-linear root distribution - TRANF(k)=part(k) + !TRANF(k)=part(k) END DO + IF (debug_print ) THEN + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'soiliqw =',soiliqw,'wilt=',wilt,'qmin= ',qmin + print *,'tranf = ',tranf + endif + ENDIF ! For LAI> 3 => transpiration at potential rate (F.Tardieu, 2013) if(lai > 4._kind_phys) then @@ -6649,7 +6681,11 @@ SUBROUTINE TRANSF( debug_print, & ! pctot=min(0.8,max(pc,pc*lai)) endif IF ( debug_print ) THEN - print *,'pctot,lai,pc',pctot,lai,pc + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'pctot,lai,pc',pctot,lai,pc + endif ENDIF !--- !--- air temperature function @@ -6659,9 +6695,6 @@ SUBROUTINE TRANSF( debug_print, & ELSE FTEM = one / (one + EXP(0.5_kind_phys * (TABS - 314.0_kind_phys))) ENDIF - IF ( debug_print ) THEN - print *,'tabs,ftem',tabs,ftem - ENDIF !--- incoming solar function cmin = one/rsmax_data cmax = one/rstbl(iland) @@ -6684,27 +6717,33 @@ SUBROUTINE TRANSF( debug_print, & else fsol = one endif - IF ( debug_print ) THEN - print *,'GSWin,lai,f1,fsol',gswin,lai,f1,fsol - ENDIF !--- total conductance totcnd =(cmin + (cmax - cmin)*pctot*ftem*fsol)/cmax IF ( debug_print ) THEN - print *,'iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd' & - ,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'GSWin,Tabs,lai,f1,cmax,cmin,pc,pctot,ftem,fsol',GSWin,Tabs,lai,f1,cmax,cmin,pc,pctot,ftem,fsol + print *,'iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd' & + ,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd + endif ENDIF !-- TRANSUM - total for the rooting zone transum=zero DO K=1,NROOT ! linear root distribution - TRANF(k)=max(cmin,TRANF(k)*totcnd) + TRANF(k)=max(zero,TRANF(k)*totcnd) transum=transum+tranf(k) END DO IF ( debug_print ) THEN - print *,'transum,TRANF',transum,tranf - endif + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'transum,TRANF',transum,tranf + endif + ENDIF !----------------------------------------------------------------- END SUBROUTINE TRANSF From a515ec34081d5b55894191b15655e5f83c96de3b Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Mon, 23 Oct 2023 18:19:59 +0000 Subject: [PATCH 06/10] Based on 1-D testing in ESM-SnowMIP a change to computation of snow thermal conductivity is made in module_sf_ruclsm.F90. --- physics/module_sf_ruclsm.F90 | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 83d7a04d6..fe02ccdc8 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -4071,7 +4071,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & RHOnewCSN=sheatsn * RHOnewSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. @@ -4088,13 +4088,13 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5._kind_phys + !fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - fact = 2._kind_phys + !fact = 2._kind_phys endif - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. @@ -4535,7 +4535,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & RHOCSN=sheatsn* RHOSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. @@ -4552,13 +4552,13 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(rhosn < 156._kind_phys .or. (newsn > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5._kind_phys + !fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - fact = 2._kind_phys + !fact = 2._kind_phys endif - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. @@ -5219,7 +5219,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & RHOCSN=sheatsn* RHOSN RHOnewCSN=sheatsn* RHOnewSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. @@ -5236,10 +5236,10 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5._kind_phys + !fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - fact = 2._kind_phys + !fact = 2._kind_phys if(debug_print) then print *,'SnowTemp xlat,xlon,rhosn,keff', xlat,xlon,rhosn,keff,keff/rhocsn*fact print *,'SNOWTEMP - 0.265/rhocsn',0.265_kind_phys/rhocsn @@ -5249,7 +5249,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,'SNOWTEMP - xlat,xlon,newsnow,rhonewsn,rhosn,fact,keff',xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff endif - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. @@ -5802,7 +5802,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & RHOCSN=sheatsn* RHOSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. @@ -5819,10 +5819,10 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5._kind_phys + !fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - fact = 2._kind_phys + !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 @@ -5833,7 +5833,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff,keff/rhocsn*fact endif - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. From ce11da759b562845cee1722ec36e8f46aebd0c67 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 24 Oct 2023 17:28:40 +0000 Subject: [PATCH 07/10] In module_sf_ruclsm.F90: clean-up comments, changed the constant for hard snow slab thermal conductivity. --- physics/module_sf_ruclsm.F90 | 76 ++++++++++++------------------------ 1 file changed, 24 insertions(+), 52 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index fe02ccdc8..74d2719d4 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -4071,23 +4071,15 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & RHOnewCSN=sheatsn * RHOnewSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. - !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys - else - !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265_kind_phys/RHOCSN - endif + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) fact = one if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys - !-- fact is added by tgs based on 4 Jan 2017 testing + !-- fact is tuning parameter added by tgs based on 4 Jan 2017 testing !fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys @@ -4097,9 +4089,10 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -4535,23 +4528,15 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & RHOCSN=sheatsn* RHOSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. - !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys - else - !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265_kind_phys/RHOCSN - endif + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) fact = one if(rhosn < 156._kind_phys .or. (newsn > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys - !-- fact is added by tgs based on 4 Jan 2017 testing + !-- fact is a tuning parameter !fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys @@ -4561,9 +4546,10 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -5219,23 +5205,15 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & RHOCSN=sheatsn* RHOSN RHOnewCSN=sheatsn* RHOnewSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. - !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys - else - !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265_kind_phys/RHOCSN - endif + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) fact = one if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys - !-- fact is added by tgs based on 4 Jan 2017 testing + !-- fact is a tuning parameter !fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys @@ -5252,9 +5230,10 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -5802,23 +5781,15 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & RHOCSN=sheatsn* RHOSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. - !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys - else - !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265_kind_phys/RHOCSN - endif + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) fact = one if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys - !-- fact is added by tgs based on 4 Jan 2017 testing + !-- fact is a tuning parameter !fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys @@ -5836,9 +5807,10 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif From e0991a8a2c653ffe989d2e77ea2ecc018512b294 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 2 Nov 2023 19:57:39 +0000 Subject: [PATCH 08/10] Removed requested by the reviewer commented lines. --- physics/module_sf_ruclsm.F90 | 14 +------------- 1 file changed, 1 insertion(+), 13 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 74d2719d4..47c03c49d 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -1521,7 +1521,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ENDIF if(snhei.gt.0.0081_kind_phys*rhowater/rhosn) then -!*** Update snow density for current temperature (Koren et al. 1999) +!*** Update snow density for current temperature (Koren et al 1999,doi:10.1029/1999JD900232.) BSN=delt/3600._kind_phys*c1sn*exp(0.08_kind_phys*min(zero,tsnav)-c2sn*rhosn*1.e-3_kind_phys) if(bsn*snwe*100._kind_phys.lt.1.e-4_kind_phys) goto 777 XSN=rhosn*(exp(bsn*snwe*100._kind_phys)-one)/(bsn*snwe*100._kind_phys) @@ -4079,11 +4079,8 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & 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 tuning parameter added by tgs based on 4 Jan 2017 testing - !fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - !fact = 2._kind_phys endif if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then @@ -4536,11 +4533,8 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & 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 a tuning parameter - !fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - !fact = 2._kind_phys endif if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then @@ -5213,11 +5207,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & 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 a tuning parameter - !fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - !fact = 2._kind_phys if(debug_print) then print *,'SnowTemp xlat,xlon,rhosn,keff', xlat,xlon,rhosn,keff,keff/rhocsn*fact print *,'SNOWTEMP - 0.265/rhocsn',0.265_kind_phys/rhocsn @@ -5789,11 +5780,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & 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 a tuning parameter - !fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - !fact = 2._kind_phys if(debug_print) then print *,'End SNOWTEMP - xlat,xlon,rhosn,keff',xlat,xlon,rhosn,keff print *,'End SNOWTEMP - 0.265/rhocsn',0.265/rhocsn From d595541a964499d15c9664092dbbe76f21487763 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 9 Nov 2023 23:43:13 +0000 Subject: [PATCH 09/10] Computation of surface fire heat for use in LSM to rrfs_smoke_wrapper. Also, added the fraction of grid cell that is burned out. --- physics/smoke_dust/module_plumerise1.F90 | 4 ---- physics/smoke_dust/module_smoke_plumerise.F90 | 12 ++---------- physics/smoke_dust/rrfs_smoke_wrapper.F90 | 18 +++++++++++------- physics/smoke_dust/rrfs_smoke_wrapper.meta | 8 ++++++++ 4 files changed, 21 insertions(+), 21 deletions(-) diff --git a/physics/smoke_dust/module_plumerise1.F90 b/physics/smoke_dust/module_plumerise1.F90 index 189bf981a..3c23faa6a 100755 --- a/physics/smoke_dust/module_plumerise1.F90 +++ b/physics/smoke_dust/module_plumerise1.F90 @@ -38,7 +38,6 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & t_phy,q_vap, & ! RAR: moist is replaced with q_vap rho_phy,vvel,u_phy,v_phy,p_phy, & z_at_w,z,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags - fire_heat_flux,dxy, & plume_frp, k_min, k_max, & ! RAR: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -67,8 +66,6 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & real(kind=kind_phys), INTENT(IN ) :: g, con_cp, con_rd real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ebb_smoke real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: flam_frac - real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: fire_heat_flux - real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: dxy ! real(kind=kind_phys), DIMENSION( ims:ime, 1, jms:jme ), & ! INTENT(IN ) :: ebu_in @@ -187,7 +184,6 @@ subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & !num_ebu, eburn_in, eburn_out, & u_in, v_in, w_in, theta_in ,pi_in, & rho_phyin, qv_in, zmid, z_lev, & - fire_heat_flux(i,j),dxy(i,j), & plume_frp(i,j,1), k_min(i,j), & k_max(i,j), dbg_opt, g, con_cp, & con_rd, cpor, errmsg, errflg ) diff --git a/physics/smoke_dust/module_smoke_plumerise.F90 b/physics/smoke_dust/module_smoke_plumerise.F90 index 9c0dfa49d..61be06181 100755 --- a/physics/smoke_dust/module_smoke_plumerise.F90 +++ b/physics/smoke_dust/module_smoke_plumerise.F90 @@ -28,7 +28,6 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & ! firesize,mean_fct, & ! nspecies,eburn_in,eburn_out, & up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & - fire_heat_flux, dxy, & frp_inst,k1,k2, dbg_opt, g, cp, rgas, & cpor, errmsg, errflg ) @@ -44,9 +43,6 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & integer :: ng,m1,m2,m3,ia,iz,ja,jz,ibcon,mynum,i,j,k,imm,ixx,ispc !,nspecies - real(kind=kind_phys), intent(in) :: dxy - real(kind=kind_phys), intent(out) :: fire_heat_flux ! JLS - INTEGER, INTENT (OUT) :: k1,k2 character(*), intent(inout) :: errmsg integer, intent(inout) :: errflg @@ -110,7 +106,6 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & IF (frp_inst Date: Thu, 9 Nov 2023 23:56:17 +0000 Subject: [PATCH 10/10] Small changes to fire feedback to RUC LSM. One more variable is added: fraction of grid cell burned by the fire. This fraction is used to take into account fire's effect on surface albedo. Also, added some debug prints. These changes will change the results only when fire feedback is turned on. The default is .false. --- physics/lsm_ruc.F90 | 24 ++++++++++++++++-------- physics/lsm_ruc.meta | 8 ++++++++ physics/module_sf_ruclsm.F90 | 17 +++++++++++++++-- 3 files changed, 39 insertions(+), 10 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 79bcbf7b1..ba1b1b4e9 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -360,6 +360,7 @@ subroutine lsm_ruc_run & ! inputs & cm_ice, ch_ice, snowfallac_ice, acsnow_ice, snowmt_ice, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & & add_fire_heat_flux, fire_heat_flux_out, & + & frac_grid_burned_out, & ! --- out & rhosnf, sbsno, & & cmm_lnd, chh_lnd, cmm_ice, chh_ice, & @@ -431,7 +432,8 @@ subroutine lsm_ruc_run & ! inputs ! --- in real (kind_phys), dimension(:), intent(in) :: & & rainnc, rainc, ice, snow, graupel, rhonewsn1 - real (kind_phys), dimension(:), intent(in) :: fire_heat_flux_out + real (kind_phys), dimension(:), intent(in) :: fire_heat_flux_out, & + frac_grid_burned_out logical, intent(in) :: add_fire_heat_flux ! --- in/out: ! --- on RUC levels @@ -984,13 +986,6 @@ subroutine lsm_ruc_run & ! inputs snoalb1d_lnd(i,j) = snoalb(i) albbck_lnd(i,j) = min(0.9_kind_phys,albbcksol(i)) !sfalb_lnd_bck(i) - IF ( add_fire_heat_flux .and. fire_heat_flux_out(i) > 0) then ! JLS - ! limit albedo and greenness in the areas affected by the fire - albbck_lnd(i,j) = min(0.1_kind_phys,albbck_lnd(i,j)) - shdfac(i,j) = min(50._kind_phys,shdfac(i,j)) ! % - ENDIF - - !-- spp_lsm if (spp_lsm == 1) then !-- spp for LSM is dimentioned as (1:lsoil_ruc) @@ -1013,6 +1008,19 @@ subroutine lsm_ruc_run & ! inputs alb_lnd(i,j) = albbck_lnd(i,j) * (one-sncovr_lnd(i,j)) + snoalb(i) * sncovr_lnd(i,j) ! sfalb_lnd(i) solnet_lnd(i,j) = dswsfc(i)*(one-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 + IF ( add_fire_heat_flux .and. fire_heat_flux_out(i) > 0) then ! JLS + if (debug_print) then + print *,'alb_lnd before fire, xlat/xlon ', alb_lnd(i,j), xlat_d(i),xlon_d(i) + print *,'fire_heat_flux_out, frac_grid_burned_out, xlat/xlon ', & + fire_heat_flux_out(i),frac_grid_burned_out(i),xlat_d(i),xlon_d(i) + endif + ! limit albedo in the areas affected by the fire + alb_lnd(i,j) = alb_lnd(i,j) * (one-frac_grid_burned_out(i)) + 0.08_kind_phys*frac_grid_burned_out(i) + if (debug_print) then + print *,'alb_lnd after fire, xlat/xlon ', alb_lnd(i,j), xlat_d(i),xlon_d(i) + endif + ENDIF + cmc(i,j) = canopy(i) ! [mm] soilt_lnd(i,j) = tsurf_lnd(i) ! sanity check for snow temperature tsnow diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 4cc6a9419..9bc7fa10a 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -1762,6 +1762,14 @@ type = real kind = kind_phys intent = in +[frac_grid_burned_out] + standard_name = fraction_of_grid_cell_burning + long_name = ration of the burnt area to the grid cell area + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 47c03c49d..52fbc8123 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -1825,7 +1825,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia UPFLUX = T3 *SOILT XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET - IF ( add_fire_heat_flux ) then ! JLS + IF ( add_fire_heat_flux .and. fire_heat_flux >0 ) then ! JLS + IF (debug_print ) THEN + print *,'RNET snow-free, fire_heat_flux, xlat/xlon',RNET, fire_heat_flux,xlat,xlon + ENDIF RNET = RNET + fire_heat_flux ENDIF @@ -1949,7 +1952,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if (SEAICE .LT. 0.5_kind_phys) then ! LAND - IF ( add_fire_heat_flux ) then ! JLS + IF ( add_fire_heat_flux .and. fire_heat_flux>0 ) then ! JLS + IF (debug_print ) THEN + print *,'RNET snow, fire_heat_flux, xlat/xlon',RNET, fire_heat_flux,xlat,xlon + ENDIF RNET = RNET + fire_heat_flux ENDIF if(snow_mosaic==one)then @@ -2242,6 +2248,13 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(SEAICE .LT. 0.5_kind_phys) then ! LAND + IF ( add_fire_heat_flux .and. fire_heat_flux>0) then ! JLS + IF (debug_print ) THEN + print *,'RNET no snow, fire_heat_flux, xlat/xlon',RNET, fire_heat_flux,xlat,xlon + endif + RNET = RNET + fire_heat_flux + ENDIF + CALL SOIL(debug_print,xlat, xlon, testptlat, testptlon,& !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, &