From 1a778352ccc16afd6e0a0c4a99dfd0e5ccd007f2 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 18 Aug 2021 18:41:17 +0000 Subject: [PATCH 01/36] minor change in ras --- physics/rascnv.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index b23b04e9a..a2574b25f 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -353,11 +353,11 @@ subroutine rascnv_run(IM, k, itc, ntc, ntr, dt, dtf & &, cnv_dqldt, clcn & &, cnv_fice, cnv_ndrop & &, cnv_nice, cf_upi - real(kind=kind_phys), dimension(:) , intent(in) :: area, cdrag + real(kind=kind_phys), dimension(:) , intent(in) :: area, cdrag real(kind=kind_phys), dimension(:) , intent(out) :: rainc, ddvel - real(kind=kind_phys), dimension(:,:), intent(in) :: rannum + real(kind=kind_phys), dimension(:,:), intent(in) :: rannum real(kind=kind_phys), intent(inout) :: ccin(:,:,:) - real(kind=kind_phys), intent(in) :: dt, dtf + real(kind=kind_phys), intent(in) :: dt, dtf ! ! Added for aerosol scavenging for GOCART ! @@ -373,7 +373,8 @@ subroutine rascnv_run(IM, k, itc, ntc, ntr, dt, dtf & real(kind=kind_phys), dimension(k) :: toi, qoi, tcu, qcu & &, pcu, clw, cli, qii, qli& &, phi_l, prsm,psjm & - &, alfinq, alfind, rhc_l & + &, alfind, rhc_l & +! &, alfinq, alfind, rhc_l & &, qoi_l, qli_l, qii_l real(kind=kind_phys), dimension(k+1) :: prs, psj, phi_h, flx, flxd From 3721df1561514a15b6141a6461d26a33472a3fa7 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 19 Aug 2021 18:00:56 +0000 Subject: [PATCH 02/36] a fix for slianl in sfcsub.F --- physics/sfcsub.F | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index b0aefb858..53a907cc0 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -2019,11 +2019,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! *,' tsffcs=',tsffcs(iprnt),' slianl=',slianl(iprnt) do i=1,len - if (sicanl(i) >= min_ice(i)) then - slianl(i) = 2.0_kind_io8 - else - slianl(i) = zero - sicanl(i) = zero + if (nint(slmskl(i)) /= 1) then + if (sicanl(i) >= min_ice(i)) then + slianl(i) = 2.0_kind_io8 + else + slianl(i) = zero + sicanl(i) = zero + endif endif enddo From 915ce6f87e0571b0feb1cc7675a540e4320a4460 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 21 Aug 2021 00:27:59 +0000 Subject: [PATCH 03/36] adding alternate cires*solv2 routine --- physics/cires_ugwpv1_solv2.F90 | 1033 +++++++++++++------------- physics/cires_ugwpv1_solv2.F90_mine | 1049 +++++++++++++++++++++++++++ physics/cires_ugwpv1_solv2.F90_orig | 1036 ++++++++++++++++++++++++++ 3 files changed, 2608 insertions(+), 510 deletions(-) create mode 100644 physics/cires_ugwpv1_solv2.F90_mine create mode 100644 physics/cires_ugwpv1_solv2.F90_orig diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/cires_ugwpv1_solv2.F90 index afd94ff5c..8f417ea1d 100644 --- a/physics/cires_ugwpv1_solv2.F90 +++ b/physics/cires_ugwpv1_solv2.F90 @@ -14,7 +14,7 @@ module cires_ugwpv1_solv2 subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & xlatd, sinlat, coslat, & - pdudt, pdvdt, pdtdt, dked, zngw) + pdudt, pdvdt, pdtdt, dked, zngw) ! !-------------------------------------------------------------------------------- ! nov 2015 alternative gw-solver for nggps-wam @@ -24,7 +24,7 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! oct 2020 Diagnostics of "tauabs, wrms, trms" is taken out ! -------------------------------------------------------------------------------- ! - use machine, only : kind_phys + use machine, only : kind_phys use cires_ugwpv1_module,only : krad, kvg, kion, ktg, iPr_ktgw, Pr_kdis, Pr_kvkt @@ -157,7 +157,8 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! real(kind=kind_phys) :: zdelp, zdelm, taud_min - real(kind=kind_phys) :: tvc, tvm, ptc, ptm + real(kind=kind_phys) :: tvc, tvm +! real(kind=kind_phys) :: tvc, tvm, ptc, ptm real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 real(kind=kind_phys) :: fmode, expdis, fdis real(kind=kind_phys) :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit @@ -181,85 +182,85 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp real(kind=kind_phys) :: rstar, rstar2 - real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm - real(kind=kind_phys) :: taub_ch, sigu2_ch - real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max - real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr + real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm + real(kind=kind_phys) :: taub_ch, sigu2_ch + real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max + real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr !-------------------------------------------------------------------------- ! nslope3 = nslope + 3.0 - Pr_kdis_eff = gw_eff*pr_kdis - iPr_max = max(1.0, iPr_ktgw) - gipr = grav* Ipr_ktgw + Pr_kdis_eff = gw_eff*pr_kdis + iPr_max = max(1.0, iPr_ktgw) + gipr = grav* Ipr_ktgw ! ! test for input fields -! if (mpi_id == master .and. kdt < -2) then -! print *, im, levs, dtp, kdt, ' vay-solv2-v1' -! print *, minval(tm), maxval(tm), ' min-max-tm ' -! print *, minval(vm), maxval(vm), ' min-max-vm ' -! print *, minval(um), maxval(um), ' min-max-um ' -! print *, minval(qm), maxval(qm), ' min-max-qm ' -! print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' -! print *, minval(prsi), maxval(prsi), ' min-max-Pint ' -! print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' -! print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' -! print *, minval(prslk), maxval(prslk), ' min-max-Exner ' -! print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' -! print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' -! -! endif - - if (idebug_gwrms == 1) then - tauabs=0.0; wrms =0.0 ; trms =0.0 - endif +! if (mpi_id == master .and. kdt < -2) then +! print *, im, levs, dtp, kdt, ' vay-solv2-v1' +! print *, minval(tm), maxval(tm), ' min-max-tm ' +! print *, minval(vm), maxval(vm), ' min-max-vm ' +! print *, minval(um), maxval(um), ' min-max-um ' +! print *, minval(qm), maxval(qm), ' min-max-qm ' +! print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' +! print *, minval(prsi), maxval(prsi), ' min-max-Pint ' +! print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' +! print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' +! print *, minval(prslk), maxval(prslk), ' min-max-Exner ' +! print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' +! print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' +! +! endif + + if (idebug_gwrms == 1) then + tauabs = 0.0 ; wrms = 0.0 ; trms = 0.0 + endif - rci(:) = 1./zci(:) - rdci(:) = 1./zdci(:) + rci(:) = 1.0 / zci(:) + rdci(:) = 1.0 / zdci(:) - rdtp = 1./dtp - rdtp2 = 0.5*rdtp + rdtp = 1.0 / dtp + rdtp2 = 0.5 * rdtp - ksrc= max(ilaunch, 3) - km2 = ksrc - 2 - km1 = ksrc - 1 - kp1 = ksrc + 1 - ktop= levs+1 + ksrc = max(ilaunch, 3) + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + ktop = levs + 1 - suprf(ktop) = kion(levs) + suprf(ktop) = kion(levs) - do k=1,levs - suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 - pdvdt(:,k) = 0.0 - pdudt(:,k) = 0.0 - pdtdt(:,k) = 0.0 - dked(: ,k) = 0.0 - enddo + do k=1,levs + suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 + pdvdt(:,k) = 0.0 + pdudt(:,k) = 0.0 + pdtdt(:,k) = 0.0 + dked(: ,k) = 0.0 + enddo !----------------------------------------------------------- ! column-based j=1,im pjysics with 1D-arrays !----------------------------------------------------------- - DO j=1, im - jl =j - tx1 = omega2 * sinlat(j) *rv_kxw - cf1 = abs(tx1) - c2f2 = tx1 * tx1 - ucrit_max = max(ucrit, cf1) - ucrit3 = ucrit_max*ucrit_max*ucrit_max + DO j=1, im + jl = j + tx1 = omega2 * sinlat(j) *rv_kxw + cf1 = abs(tx1) + c2f2 = tx1 * tx1 + ucrit_max = max(ucrit, cf1) + ucrit3 = ucrit_max*ucrit_max*ucrit_max ! ! ngw-fluxes at all gridpoints (with tau_min at least) -! - aprsl(1:levs) = prsl(jl,1:levs) +! + aprsl(1:levs) = prsl(jl,1:levs) ! ! ksrc-define "aprsi(1:levs+1) redefine "ilaunch" ! do k=1, levs - if (aprsl(k) .lt. psrc ) exit - enddo - ilaunch = max(k-1, 3) - ksrc= max(ilaunch, 3) + if (aprsl(k) < psrc ) exit + enddo + ilaunch = max(k-1, 3) + ksrc = max(ilaunch, 3) - zngw(j) = zmet(j, ksrc) + zngw(j) = zmet(j, ksrc) km2 = ksrc - 2 km1 = ksrc - 1 @@ -267,338 +268,340 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & !=====ksrc - aum(1:levs) = um(jl,1:levs) - avm(1:levs) = vm(jl,1:levs) - atm(1:levs) = tm(jl,1:levs) - aqm(1:levs) = qm(jl,1:levs) - azmet(1:levs) = zmet(jl,1:levs) - aprsi(1:levs+1) = prsi(jl,1:levs+1) - azmeti(1:levs+1) = zmeti(jl,1:levs+1) + do k=1, levs + aum(k) = um(jl,k) + avm(k) = vm(jl,k) + atm(k) = tm(jl,k) + aqm(k) = qm(jl,k) + azmet(k) = zmet(jl,k) + aprsi(k) = prsi(jl,k) + azmeti(k) = zmeti(jl,k) + enddo + aprsi(levs+1) = prsi(jl,levs+1) + azmeti(levs+1) = zmeti(jl,levs+1) - rho_src = aprsl(ksrc)*rdi/atm(ksrc) - taub_ch = max(tau_ngw(jl), tau_min) - taub_src = taub_ch + rho_src = aprsl(ksrc)*rdi/atm(ksrc) + taub_ch = max(tau_ngw(jl), tau_min) + taub_src = taub_ch - sigu2 = taub_src/rho_src/v_kxw * zms - sig_u2az(1:nazd) = sigu2 + sigu2 = zms * taub_src / (rho_src*v_kxw) + sig_u2az(1:nazd) = sigu2 ! ! compute diffusion-based arrays km2:levs ! - do jk = km2, levs - dz_meti(jk) = azmeti(jk+1)-azmeti(jk) - dz_met(jk) = azmet(jk)-azmeti(jk-1) - enddo + do jk = km2, levs + dz_meti(jk) = azmeti(jk+1) - azmeti(jk) + dz_met(jk) = azmet(jk) - azmeti(jk-1) + enddo ! --------------------------------------------- ! interface mean flow parameters launch -> levs+1 ! --------------------------------------------- - do jk= km1,levs - tvc = atm(jk)*(1. +fv*aqm(jk)) - tvm = atm(jk-1)*(1. +fv*aqm(jk-1)) - ptc = tvc/ prslk(jl, jk) - ptm = tvm/prslk(jl,jk-1) -! - zthm = 2.0/(tvc+tvm) - rhp_wam = zthm*gor + do jk= km1,levs + tvc = atm(jk) * (1.0 + fv*aqm(jk)) + tvm = atm(jk-1) * (1.0 + fv*aqm(jk-1)) +! ptc = tvc / prslk(jl,jk) ! not used +! ptm = tvm / prslk(jl,jk-1) ! notused +! + zthm = 2.0 / (tvc+tvm) + rhp_wam = zthm*gor !interface - uint(jk) = 0.5*(aum(jk-1)+aum(jk)) - vint(jk) = 0.5*(avm(jk-1)+avm(jk)) - tint(jk) = 0.5*(tvc+tvm) - rhomid(jk) = aprsl(jk)*rdi/atm(jk) - rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) - zdelp = dz_meti(jk) ! >0 ...... dz-meters - v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] - zdelm = 1./dz_met(jk) ! 1/dz ...... 1/meters + uint(jk) = 0.5*(aum(jk-1)+aum(jk)) + vint(jk) = 0.5*(avm(jk-1)+avm(jk)) + tint(jk) = 0.5*(tvc+tvm) + rhomid(jk) = aprsl(jk)*rdi/atm(jk) + rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) + zdelp = dz_meti(jk) ! >0 ...... dz-meters + v_zmet(jk) = zdelp + zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] + zdelm = 1.0 / dz_met(jk) ! 1/dz ...... 1/meters ! -! bvf2 = grav2*zdelm*(ptc-ptm)/(ptc + ptm) ! N2=[g/PT]*(dPT/dz) +! bvf2 = grav2*zdelm*(ptc-ptm) / (ptc + ptm) ! N2=[g/PT]*(dPT/dz) ! - bn2(jk) = grav2cpd*zthm*(1.0+rcpdl*(tvc-tvm)*zdelm) - bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) - bn(jk) = sqrt(bn2(jk)) + bn2(jk) = grav2cpd*zthm*(1.0+rcpdl*(tvc-tvm)*zdelm) + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + bn(jk) = sqrt(bn2(jk)) - wrk3(jk)= 1./zdelp/rhomid(jk) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] - irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src + wrk3(jk) = 1.0 / (zdelp*rhomid(jk)) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] + irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src ! ! ! diagnostics -Kzz above PBL ! - uz = aum(jk) - aum(jk-1) - vz = avm(jk) - avm(jk-1) - shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + uz = aum(jk) - aum(jk-1) + vz = avm(jk) - avm(jk-1) + shr2 = max(uz*uz+vz*vz, dw2min) * zdelm *zdelm - zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 - zgrow = exp(zmetk) - ritur = bn2(jk)/shr2 - kamp = sqrt(shr2)*sc2 *zgrow - w1 = 1./(1. + 5*ritur) - ktur= min(max(kamp * w1 * w1, dked_min), dked_max) - zmetk = azmet(jk)* rhp - vueff(jk) = ktur + kvg(jk) + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk) / shr2 + kamp = sqrt(shr2) * sc2 * zgrow + w1 = 1.0 / (1.0 + 5*ritur) + ktur = min(max(kamp * w1 * w1, dked_min), dked_max) + zmetk = azmet(jk)* rhp + vueff(jk) = ktur + kvg(jk) - akt(jk) = gipr/tvc - enddo + akt(jk) = gipr / tvc + enddo if (idebug_gwrms == 1) then - do jk= km1,levs - wrk1(jk) = rv_kxw/rhoint(jk) - wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) + do jk= km1,levs + wrk1(jk) = rv_kxw/rhoint(jk) + wrk2(jk) = rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) enddo endif ! ! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) ! - jk = levs + jk = levs - rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) - tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) - uint(ktop) = aum(jk) - vint(ktop) = avm(jk) + rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) + tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) + uint(ktop) = aum(jk) + vint(ktop) = avm(jk) - v_zmet(ktop) = v_zmet(jk) - vueff(ktop) = vueff(jk) - bn2(ktop) = bn2(jk) - bn(ktop) = bn(jk) + v_zmet(ktop) = v_zmet(jk) + vueff(ktop) = vueff(jk) + bn2(ktop) = bn2(jk) + bn(ktop) = bn(jk) ! ! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity ! - do jk=km1, levs - akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) - enddo + do jk=km1, levs + akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) + enddo - bvi = bn(ksrc); bvi2 = bvi * bvi; - bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi + bvi = bn(ksrc); bvi2 = bvi * bvi; + bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi ! ! project winds at ksrc ! do iaz=1, nazd - ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) + ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) enddo ! - do jk=ksrc, ktop - cstar(jk) = bn(jk)/zms - cstar2(jk) = cstar(jk)*cstar(jk) + do jk=ksrc, ktop + cstar(jk) = bn(jk)/zms + cstar2(jk) = cstar(jk)*cstar(jk) - fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 - - do iaz=1, nazd - zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) - ui(iaz, jk) = zu !- ul(iaz)*0. - enddo + fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 + + do iaz=1, nazd + zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) + ui(iaz, jk) = zu !- ul(iaz)*0. enddo + enddo - rstar = 1./cstar(ksrc) - rstar2 = rstar*rstar + rstar = 1.0 / cstar(ksrc) + rstar2 = rstar*rstar ! ----------------------------------------- ! set launch momentum flux spectral density ! ----------------------------------------- - fpu(1:nazd, km2:ktop) =0. + fpu(1:nazd, km2:ktop) = 0. - do inc=1,nwav + do inc=1,nwav - zcin = zci(inc)*rstar + zcin = zci(inc)*rstar ! ! integrate (flux(cin) x dcin ) old tau-flux and normalization ! - flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) + flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) ! -! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] +! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] ! - fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less - - do iaz=1,nazd - akzw(inc, iaz, ksrc) = bvi*rci(inc) - enddo + fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less + + do iaz=1,nazd + akzw(inc, iaz, ksrc) = bvi*rci(inc) + enddo - enddo + enddo ! ! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) - flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] - ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 - do jk=ksrc, ktop - fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 - enddo + flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] + ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 + do jk=ksrc, ktop + fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 + enddo ! - do inc=1, nwav - flux(inc,1) = flux_norm*flux(inc,1) - enddo - + do inc=1, nwav + flux(inc,1) = flux_norm*flux(inc,1) + enddo - if (ener_norm == 1) then - snorm_ener = 0. - do inc=1,nwav - zcin = zci(inc)*rstar - - ze2 = zcin /(1.+ zcin**nslope3) + if (ener_norm == 1) then + snorm_ener = 0. + do inc=1,nwav + zcin = zci(inc)*rstar + ze2 = zcin / (1.0 + zcin**nslope3) + snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less + flux(inc,1) = ze2 * zcin + enddo - snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less - flux(inc,1) = ze2 * zcin - enddo + ekin_norm = 1.0 / snorm_ener - ekin_norm = 1./snorm_ener - ! taub_src = sigu2 * rho_src * [v_kxw / zms ] ! sigu2 = taub_src*zms/(rho_src/v_kxw) ! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns - ze1 = taub_src*zms/bvi * ekin_norm + ze1 = taub_src*zms/bvi * ekin_norm taub_src = 0. - - do inc=1,nwav - flux(inc,1) = ze1* flux(inc,1) - taub_src = taub_src + flux(inc,1)*zdci(inc) - enddo - ze1 = ekin_norm * v_kxw * rstar2 - do jk=ksrc, ktop - fden_bnen(jk) = rhoint(jk) / bn(jk) *ze1 ! mult on => sigu2(z)*cdf2 => flux_sat - enddo - - endif + + do inc=1,nwav + flux(inc,1) = ze1* flux(inc,1) + taub_src = taub_src + flux(inc,1)*zdci(inc) + enddo + ze1 = ekin_norm * v_kxw * rstar2 + do jk=ksrc, ktop + fden_bnen(jk) = rhoint(jk) / bn(jk) * ze1 ! mult on => sigu2(z)*cdf2 => flux_sat + enddo + + endif ! - do iaz=1,nazd - fpu(iaz, ksrc) = taub_src - fpu(iaz, km1) = taub_src - enddo + do iaz=1,nazd + fpu(iaz, ksrc) = taub_src + fpu(iaz, km1) = taub_src + enddo ! copy flux-1 into other azimuths ! -------------------------------- - do iaz=2, nazd - do inc=1,nwav - flux(inc,iaz) = flux(inc,1) + do iaz=2, nazd + do inc=1,nwav + flux(inc,iaz) = flux(inc,1) + enddo enddo - enddo -! if (mpi_id == master .and. ener_norm == 1) then -! print * -! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm -! print * -! endif - - if (idebug_gwrms == 1) then - pwrms =0. - ptrms =0. - tx1 = real(nazd)/rhoint(ksrc)*rv_kxw - ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 - do inc=1, nwav - v_kzw = bvi*rci(inc) - ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw - pwrms = pwrms + ze1 - ptrms = ptrms + ze1 * ze2 - enddo - wrms(jl, ksrc) = pwrms - trms(jl, ksrc) = ptrms - endif +! if (mpi_id == master .and. ener_norm == 1) then +! print * +! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm +! print * +! endif + + if (idebug_gwrms == 1) then + pwrms = 0. + ptrms = 0. + tx1 = real(nazd)/rhoint(ksrc)*rv_kxw + ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 + do inc=1, nwav + v_kzw = bvi*rci(inc) + ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw + pwrms = pwrms + ze1 + ptrms = ptrms + ze1 * ze2 + enddo + wrms(jl, ksrc) = pwrms + trms(jl, ksrc) = ptrms + endif ! -------------------------------- - wave_act(:,:) = 1.0 + wave_act(:,:) = 1.0 ! vertical do-loop - do jk=ksrc, levs + do jk=ksrc, levs - jkp = jk+1 + jkp = jk+1 ! azimuth do-loop - do iaz=1, nazd + do iaz=1, nazd - sig_u2az_m(iaz) = sig_u2az(iaz) + sig_u2az_m(iaz) = sig_u2az(iaz) - umfp = ui(iaz, jkp) - umfm = ui(iaz, jk) - umfc = .5*(umfm + umfp) + umfp = ui(iaz, jkp) + umfm = ui(iaz, jk) + umfc = .5*(umfm + umfp) ! wave-cin loop - dfdz_v(iaz, jk) = 0.0 - dfdz_heat(iaz, jk) = 0.0 - fpu(iaz, jkp) = 0.0 - sig_u2az(iaz) =0.0 + dfdz_v(iaz, jk) = 0.0 + dfdz_heat(iaz, jk) = 0.0 + fpu(iaz, jkp) = 0.0 + sig_u2az(iaz) = 0.0 ! ! wave_dis(iaz, :) = vueff(jk) - do inc=1, nwav - flux_m(inc, iaz) = flux(inc, iaz) + do inc=1, nwav + flux_m(inc, iaz) = flux(inc, iaz) - zcin = zci(inc) ! zcin =/0 by definition - zcinc = rci(inc) + zcin = zci(inc) ! zcin =/0 by definition + zcinc = rci(inc) - if(wave_act(inc,iaz) == 1.0) then + if (wave_act(inc,iaz) == 1.0) then !======================================================================= ! discrete mode ! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat ! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) !======================================================================= - v_cdp = zcin - umfp - v_cdp2=v_cdp*v_cdp - cdf2 = v_cdp2 - c2f2 - if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then + v_cdp = zcin - umfp + v_cdp2=v_cdp*v_cdp + cdf2 = v_cdp2 - c2f2 + if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then ! ! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max, wave's absorption ! - wave_act(inc,iaz) =0. - akzw(inc, iaz, jkp) = pi/dz_meti(jk) ! pi2/dzmet - fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) - flux(inc,iaz) = fluxs + wave_act(inc,iaz) = 0. + akzw(inc, iaz, jkp) = pi/dz_meti(jk) ! pi2/dzmet + fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) + flux(inc,iaz) = fluxs - else + else - v_wdp = v_kxw*v_cdp - wdop2 = v_wdp* v_wdp + v_wdp = v_kxw * v_cdp + wdop2 = v_wdp * v_wdp ! ! rotational cut-off ! - kzw2 = (bn2(jkp)-wdop2)/Cdf2 + kzw2 = (bn2(jkp)-wdop2)/Cdf2 ! !cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 ! - if ( kzw2 > mkz2min ) then - v_kzw = sqrt(kzw2) - akzw(inc, iaz, jkp) = v_kzw + if ( kzw2 > mkz2min ) then + v_kzw = sqrt(kzw2) + akzw(inc, iaz, jkp) = v_kzw ! !linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 ! !kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) ! Kds_sat = kxw*Cdf1*rhp2/kzw3 !krad, kvg, kion, ktg - v_cdp = sqrt( cdf2 ) - v_wdp = v_kxw * v_cdp - v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due for "all" vars - v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) - v_kzi = v_kzw*v_wdi/v_wdpc + v_cdp = sqrt( cdf2 ) + v_wdp = v_kxw * v_cdp + v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due for "all" vars + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc ! - ze1 = v_kzi*v_zmet(jk) + ze1 = v_kzi*v_zmet(jk) - if (ze1 .ge. 1.e-2) then - expdis = max(exp(-ze1), 0.01) - else - expdis = 1./(1.+ ze1) - endif + if (ze1 .ge. 1.e-2) then + expdis = max(exp(-ze1), 0.01) + else + expdis = 1.0 / (1.0 + ze1) + endif ! - wave_act(inc,iaz) = 1.0 - fmode = flux(inc,iaz) + wave_act(inc,iaz) = 1.0 + fmode = flux(inc,iaz) - flux_2_sig = v_kzw/v_kxw/rhoint(jkp) - w1 = v_wdpc/kzw2/v_kzw/v_zmet(jk) - else ! kzw2 <= mkz2min large "Lz"-reflection + flux_2_sig = v_kzw / (v_kxw*rhoint(jkp)) + w1 = v_wdpc / (kzw2*v_kzw*v_zmet(jk)) + else ! kzw2 <= mkz2min large "Lz"-reflection - expdis = 1.0 - v_kzw = mkzmin + expdis = 1.0 + v_kzw = mkzmin - v_cdp = 0. ! no effects of reflected waves - wave_act(inc,iaz) = 0.0 - akzw(inc, iaz, jkp) = v_kzw - fmode = 0. - w1 =0. - endif -! expdis =1.0 + v_cdp = 0. ! no effects of reflected waves + wave_act(inc,iaz) = 0.0 + akzw(inc, iaz, jkp) = v_kzw + fmode = 0. + w1 = 0. + endif + +! expdis =1.0 - fdis = fmode*expdis*wave_act(inc,iaz) + fdis = fmode*expdis*wave_act(inc,iaz) !============================================================================== ! ! Saturated Fluxes and Energy: Spectral and Dicrete Modes @@ -612,7 +615,7 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) ! new sat fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) ! -! fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) +! fluxs = fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) ! ! @@ -621,131 +624,136 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! [fden_bn(jkp)] = Pa/dc ! fsat = rstar*(zcin*zcin) * [taub_src / SN * [ rstar3*rho/rho_src *N_src/N] = fden_bn ] - if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] + if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] ! ! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc ! - if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) - if (ener_norm == 1) then + if (ener_norm == 1) then ! spectral saturation limit - - if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) + + if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) ! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc - if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) ! - endif + endif !---------------------------------------------------------------------------- ! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw -! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat -! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat !---------------------------------------------------------------------------- - zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa - if(zdep > 0.0 ) then + zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa + if (zdep > 0.0 ) then ! subs on sat-limit - ze1 = flux(inc,iaz) - flux(inc,iaz) = fluxs - ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs - ! here we can add extra-dissip for the next layer - else + ze1 = flux(inc,iaz) + flux(inc,iaz) = fluxs + ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs + ! here we can add extra-dissip for the next layer +!Moorthi the above ze2 is not used it appears! + + else ! assign dis-ve flux - flux(inc,iaz) = fdis - endif + flux(inc,iaz) = fdis + endif - dtau = flux_m(inc,iaz)-flux(inc,iaz) - if (dtau .lt. 0) then - flux(inc,iaz) = flux_m(inc,iaz) - endif + dtau = flux_m(inc,iaz)-flux(inc,iaz) + if (dtau .lt. 0) then + flux(inc,iaz) = flux_m(inc,iaz) + endif ! ! GW-sponge domain: saturate all "GW"-modes above "zsp_gw" ! - if ( azmeti(jkp) .ge. zsp_gw) then - mi_sponge = .5/dz_meti(jk) - ze2 = v_wdp /v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] - v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge - v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) - v_kzi = v_kzw*v_wdi/v_wdpc + if ( azmeti(jkp) >= zsp_gw) then +! mi_sponge = 0.5 / dz_meti(jk) +! ze2 = v_wdp / v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] +! v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge + + v_wdi = 0.5 * v_wdp / (v_kzw *dz_meti(jk)) + v_wdi*0.25 ! diss-sat GW-sponge + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc ! - ze1 = v_kzi*v_zmet(jk) - exp_sponge = exp(-ze1) +! ze1 = v_kzi*v_zmet(jk) +! exp_sponge = exp(-ze1) + exp_sponge = exp(-v_kzi*v_zmet(jk)) ! ! additional sponge ! - flux(inc,iaz) = flux(inc,iaz) *exp_sponge - endif + flux(inc,iaz) = flux(inc,iaz) *exp_sponge + endif - endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then - endif ! only for waves w/o CL-absorption wave_act=1 + endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then + endif ! only for waves w/o CL-absorption wave_act=1 ! ! sum for given (jk, iaz) all active "wave" contributions ! - if (wave_act(inc,iaz) == 1) then + if (wave_act(inc,iaz) == 1) then - zcinc =zdci(inc) - vc_zflx_mode = flux(inc,iaz) - vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) - if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) - ze1 = vc_zflx_mode*zcinc - fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at - sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz + zcinc = zdci(inc) + vc_zflx_mode = flux(inc,iaz) + vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) + if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) + ze1 = vc_zflx_mode*zcinc + fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at + sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! (heat deposition integration over spectral mode for each azimuth ! later sum over selected azimuths as "non-negative" scalars) ! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! zdelp = wrk3(jk)*cdf1 *zcinc +! zdelp = wrk3(jk)*cdf1 *zcinc - zdelp = wrk3(jk)* v_cdp *zcinc * vmdiff + zdelp = wrk3(jk) * v_cdp * zcinc * vmdiff -! zcool = 1. ! COOL=(-3.5 + Pr)/Pr -! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp -! edis = (c-u)*ax/cp = Kv_dis*N2/cp -! cool = -Kt*N2/R +! zcool = 1. ! COOL=(-3.5 + Pr)/Pr +! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp +! edis = (c-u)*ax/cp = Kv_dis*N2/cp +! cool = -Kt*N2/R ! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] ! - dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 - dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 - endif !wave_act(inc,iaz) == 1) + dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 + dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 + endif !wave_act(inc,iaz) == 1) ! - enddo ! wave-inc-loop + enddo ! wave-inc-loop - ze1 =fpu(iaz, jk) - if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 + ze1 = fpu(iaz, jk) + if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 ! ! compute wind and temp-re rms ! - if (idebug_gwrms == 1) then - pwrms =0. - ptrms =0. - do inc=1, nwav - if (wave_act(inc,iaz) > 0.) then - v_kzw =akzw(inc, iaz, jk) - ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) - pwrms = pwrms + ze1 - ptrms = ptrms + ze1*wrk2(jk) - endif - enddo - Awrms(iaz, jk) = pwrms - Atrms(iaz, jk) = ptrms - endif + if (idebug_gwrms == 1) then + pwrms = 0. + ptrms = 0. + do inc=1, nwav + if (wave_act(inc,iaz) > 0.) then + v_kzw = akzw(inc, iaz, jk) + ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) + pwrms = pwrms + ze1 + ptrms = ptrms + ze1*wrk2(jk) + endif + enddo + Awrms(iaz, jk) = pwrms + Atrms(iaz, jk) = ptrms + endif ! -------------- - enddo ! end Azimuth do-loop + enddo ! end Azimuth do-loop ! ! eddy wave dissipation to limit GW-rms ! - tx1 = sum(abs(dfdz_heat(1:nazd, jk)))/bn2(jk) - ze1=max(dked_min, tx1) - ze2=min(dked_max, ze1) - vueff(jkp) = ze2 + vueff(jkp) + tx1 = sum(abs(dfdz_heat(1:nazd, jk))) / bn2(jk) + ze1 = max(dked_min, tx1) + ze2 = min(dked_max, ze1) + vueff(jkp) = ze2 + vueff(jkp) ! - enddo ! end Vertical do-loop + enddo ! end Vertical do-loop ! ! top-layers constant interface-fluxes and zero-heat ! we allow non-zero momentum fluxes and thermal effects @@ -761,38 +769,38 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! at the source level and below taux = 0 (taux_E=-taux_W by assumption) !======================================================================== - do jk=ksrc, levs + do jk=ksrc, levs taux(jk) = 0.0 tauy(jk) = 0.0 - do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) - pdtdt(jl,jk) = pdtdt(jl,jk) + dfdz_v(iaz,jk) - dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + pdtdt(jl,jk) = pdtdt(jl,jk) + dfdz_v(iaz,jk) + dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) + enddo enddo - enddo - jk = ktop; taux(jk)=0.; tauy(jk)=0. + jk = ktop ; taux(jk) = 0. ; tauy(jk) = 0. do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) enddo - if (idebug_gwrms == 1) then - do jk=kp1, levs - do iaz=1,nazd - wrms(jl,jk) =wrms(jl,jk) + Awrms(iaz,jk) - trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) - tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) - enddo - enddo - endif + if (idebug_gwrms == 1) then + do jk=kp1, levs + do iaz=1,nazd + wrms(jl,jk) = wrms(jl,jk) + Awrms(iaz,jk) + trms(jl,jk) = trms(jl,jk) + Atrms(iaz,jk) + tauabs(jl,jk) = tauabs(jl,jk) + fpu(iaz,jk) + enddo + enddo + endif ! - do jk=ksrc+1,levs - jkp = jk + 1 + do jk=ksrc+1,levs + jkp = jk + 1 zdelp = wrk3(jk)*gw_eff - ze1 = (taux(jkp)-taux(jk))* zdelp - ze2 = (tauy(jkp)-tauy(jk))* zdelp + ze1 = (taux(jkp)-taux(jk)) * zdelp + ze2 = (tauy(jkp)-tauy(jk)) * zdelp if (abs(ze1) >= maxdudt ) then ze1 = sign(maxdudt, ze1) @@ -807,230 +815,235 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! Cx =0 based Cx=/= 0. above ! ! - if (knob_ugwp_doheat == 1) then + if (knob_ugwp_doheat == 1) then ! -!maxdtdt= dked_max * bnfix2 +! maxdtdt= dked_max * bnfix2 ! - pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff - ze2 = pdtdt(jl,jk) - if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) + pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff + ze2 = pdtdt(jl,jk) + if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) - dked(jl,jk) = dked(jl,jk)/bn2(jk) - ze1 = max(dked_min, dked(jl,jk)) - dked(jl,jk) = min(dked_max, ze1) - qmid(jk) = pdtdt(j,jk) - endif - enddo + dked(jl,jk) = dked(jl,jk) / bn2(jk) + ze1 = max(dked_min, dked(jl,jk)) + dked(jl,jk) = min(dked_max, ze1) + qmid(jk) = pdtdt(j,jk) + endif + enddo !---------------------------------------------------------------------------------- ! Update heat = ek_diss/cp and aply 1-2-1 smoother for "dked" => dktur ! here with "u_new = u +dtp*dudt ; vnew = v + v +dtp*dvdt ! can check "stability" in the column and "add" ktur-estimation ! to suppress instability as needed so dked = dked_gw + ktur_ric !---------------------------------------------------------------------------------- - - dktur(1:levs) = dked(jl,1:levs) + + dktur(1:levs) = dked(jl,1:levs) ! - do ist= 1, nstdif - do jk=ksrc,levs-1 - adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) - enddo - dktur(ksrc:levs-1) = adif(ksrc:levs-1) - enddo - dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) - dktur(levs+1) = dktur(levs) + do ist= 1, nstdif + do jk=ksrc,levs-1 + adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) + enddo + dktur(ksrc:levs-1) = adif(ksrc:levs-1) + enddo + dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) + dktur(levs+1) = dktur(levs) - do jk=ksrc,levs+1 - ze1 = .5*( dktur(jk) +dktur(jk-1) ) - kvint(jk) = ze1 - ktint(jk) = ze1*iPr_ktgw - enddo + do jk=ksrc,levs+1 + ze1 = .5*( dktur(jk) +dktur(jk-1) ) + kvint(jk) = ze1 + ktint(jk) = ze1*iPr_ktgw + enddo ! ! Thermal budget qmid = qheat + qcool ! - do jk=ksrc+1,levs + do jk=ksrc+1,levs ze2 = qmid(jk) + dktur(jk)*Akt(jk) + grav*(ktint(jk+1)-ktint(jk))/dz_meti(jk) - qmid(jk) = ze2 - if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) + qmid(jk) = ze2 + if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) pdtdt(jl,jk) = qmid(jk)*rcpd - dked(jl, jk) = dktur(jk) + dked(jl, jk) = dktur(jk) enddo ! ! perform explicit eddy "diffusive" 3-point smoothing of "u-v-t" ! from the surface/launch-gw to the "top" ! ! + do jk=km2,levs ! update by source function X(t+dt) = X(t) + dtp * dXdt ! - uold(km2:levs) = aum(km2:levs)+pdudt(jl,km2:levs)*dtp - vold(km2:levs) = avm(km2:levs)+pdvdt(jl,km2:levs)*dtp - told(km2:levs) = atm(km2:levs)+pdtdt(jl,km2:levs)*dtp + uold(jk) = aum(jk) + pdudt(jl,jk) * dtp + vold(jk) = avm(jk) + pdvdt(jl,jk) * dtp + told(jk) = atm(jk) + pdtdt(jl,jk) * dtp ! ! diagnose turb-profile using "stability-check" relying on the free-atm diffusion ! sc2 = 30m x 30m ! - dktur(km2:levs) = dked_min + dktur(jk) = dked_min + enddo - do jk=km1,levs - uz = uold(jk) - uold(jk-1) - vz = vold(jk) - vold(jk-1) - ze1 = dz_met(jk) - zdelm = 1./ze1 + do jk=km1,levs + uz = uold(jk) - uold(jk-1) + vz = vold(jk) - vold(jk-1) + ze1 = dz_met(jk) + zdelm = 1.0 / ze1 - tvc = told(jk) * (1. +fv*aqm(jk)) - tvm = told(jk-1) * (1. +fv*aqm(jk-1)) - zthm = 2.0 / (tvc+tvm) - shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + tvc = told(jk) * (1. +fv*aqm(jk)) + tvm = told(jk-1) * (1. +fv*aqm(jk-1)) + zthm = 2.0 / (tvc+tvm) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm - bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) + bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) - bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) - zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 - zgrow = exp(zmetk) - ritur = bn2(jk)/shr2 - w1 = 1./(1. + 5*ritur) - ze2 = min( sc2 *zgrow, 4.*ze1*ze1) + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + w1 = 1.0 / (1.0 + 5*ritur) + ze2 = min( sc2 *zgrow, 4.*ze1*ze1) ! ! Smag-type of eddy diffusion K_smag = Sqrt(Deformation - N2/Pr)* L2 *const ! - kamp = sqrt(shr2)* ze2 * w1 * w1 - ktur= min(max(kamp, dked_min), dked_max) - dktur(jk) = ktur + kamp = sqrt(shr2)* ze2 * w1 * w1 + ktur = min(max(kamp, dked_min), dked_max) + dktur(jk) = ktur ! ! update of dked = dked_gw + k_turb_mf -! - dked(jl, jk) = dked(jl, jk) +ktur +! + dked(jl, jk) = dked(jl, jk) +ktur - enddo + enddo ! ! apply eddy effects due to GWs: explicit scheme Kzz*dt/dz2 < 0.5 stability ! - if (knob_ugwp_dokdis == 2) then + if (knob_ugwp_dokdis == 2) then - do jk=ksrc,levs - ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) - kvint(jk) = kvint(jk) + ze1 -! ktint(jk) = ktint(jk) + ze1*iPr_ktgw - enddo - kvint(km1) = kvint(ksrc) - kvint(ktop) = kvint(levs) + do jk=ksrc,levs + ze1 = min(.5*(dktur(jk)+dktur(jk-1)), dturb_max) + kvint(jk) = kvint(jk) + ze1 +! ktint(jk) = ktint(jk) + ze1*iPr_ktgw + enddo + kvint(km1) = kvint(ksrc) + kvint(ktop) = kvint(levs) - dzmetm = 1./dz_met(km1) - Adif(km1:levs) = 0. - Cdif(km1:levs) = 0. + dzmetm = 1./dz_met(km1) + Adif(km1:levs) = 0. + Cdif(km1:levs) = 0. do jk=km1,levs-1 - dzmetp = 1./dz_met(jk+1) - dzmetf = 1./(dz_meti(jk)*rhomid(jk)) + dzmetp = 1.0 / dz_met(jk+1) + dzmetf = 1.0 / (dz_meti(jk)*rhomid(jk)) - ktur = kvint(jk) *rhoint(jk) * dzmetf - kturp =Kvint(jk+1)*rhoint(jk+1) * dzmetf - - Adif(jk) = ktur * dzmetm - Cdif(jk) = kturp * dzmetp - ApC = adif(jk)+cdif(jk) - ACdif(jk) = ApC + ktur = kvint(jk) * rhoint(jk) * dzmetf + kturp = Kvint(jk+1) * rhoint(jk+1) * dzmetf + + Adif(jk) = ktur * dzmetm + Cdif(jk) = kturp * dzmetp + ApC = adif(jk) + cdif(jk) + ACdif(jk) = ApC - w1 = ApC*iPr_max - if (rdtp < w1 ) then - Anstab(jk) = floor(w1*dtp) + 1 - else - Anstab(jk) = 1 - endif - dzmetm = dzmetp - enddo + w1 = ApC*iPr_max + if (rdtp < w1 ) then + Anstab(jk) = floor(w1*dtp) + 1 + else + Anstab(jk) = 1 + endif + dzmetm = dzmetp + enddo - nstab = maxval( Anstab(ksrc:levs-1)) + nstab = maxval( Anstab(ksrc:levs-1)) -! if (nstab .ge. 3) print *, 'nstab ', nstab +! if (nstab .ge. 3) print *, 'nstab ', nstab ! ! k instead Jk ! - dtdif = dtp/real(nstab) - ze1 = 1./dtdif + dtdif = dtp/real(nstab) + ze1 = 1./dtdif - do ist= 1, nstab - do k=ksrc,levs-1 - Bdif = ze1 - ACdif(k) - Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 - unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) - vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) - tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw - enddo + do ist= 1, nstab + do k=ksrc,levs-1 + Bdif = ze1 - ACdif(k) + Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 + unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) + vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) + tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw + enddo - uold(ksrc:levs-1) = unew(ksrc:levs-1)*dtdif ! value du/dtp *dtp = du - vold(ksrc:levs-1) = vnew(ksrc:levs-1)*dtdif - told(ksrc:levs-1) = tnew(ksrc:levs-1)*dtdif + do k=ksrc,levs-1 + uold(k) = unew(k) * dtdif ! value du/dtp *dtp = du + vold(k) = vnew(k) * dtdif + told(k) = tnew(k) * dtdif + enddo ! ! smoothing the boundary points: "k-1" = ksrc-1 and "k+1" = levs ! - uold(levs) = uold(levs-1) - vold(levs) = vold(levs-1) - told(levs) = told(levs-1) - enddo + uold(levs) = uold(levs-1) + vold(levs) = vold(levs-1) + told(levs) = told(levs-1) + enddo ! ! compute "smoothed" tendencies by molecular + GW-eddy diffusions ! - do k=ksrc,levs-1 -! + do k=ksrc,levs-1 +! ! final updates of tendencies and diffusion ! - ze2 = rdtp*(uold(k) - aum(k)) - ze1 = rdtp*(vold(k) - avm(k)) - pdtdt(jl,k)= rdtp*( told(k) - atm(k) ) + ze2 = rdtp * (uold(k) - aum(k)) + ze1 = rdtp * (vold(k) - avm(k)) + pdtdt(jl,k) = rdtp * (told(k) - atm(k)) - if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) - if (abs(ze1) >= maxdudt ) then - ze1 = sign(maxdudt, ze1) - endif - if (abs(ze2) >= maxdudt ) then - ze2 = sign(maxdudt, ze2) - endif + if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif - pdudt(jl, k) = ze2 - pdvdt(jl, k) = ze1 - uz = uold(k+1) - uold(k-1) - vz = vold(k+1) - vold(k-1) - ze2 = 1./(dz_met(k+1)+dz_met(k) ) - mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat - pdtdt(jl,k)= pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity + pdudt(jl, k) = ze2 + pdvdt(jl, k) = ze1 + uz = uold(k+1) - uold(k-1) + vz = vold(k+1) - vold(k-1) + ze2 = 1.0 / (dz_met(k+1)+dz_met(k) ) - enddo + mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat + pdtdt(jl,k) = pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity + + enddo - ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t + ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t - enddo ! J-loop + enddo ! J-loop ! - RETURN + RETURN !================================= diag print after "return" ====================== - if (kdt ==1 .and. mpi_id == master) then + if (kdt ==1 .and. mpi_id == master) then ! - print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' - print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) - print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) -! print *, 'ugwpv1: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min + print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' + print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) + print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) +! print *, 'ugwpv1: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min - print * + print * - endif + endif - if (kdt == 1 .and. mpi_id == master) then - print *, 'vgw done nstab ', nstab + if (kdt == 1 .and. mpi_id == master) then + print *, 'vgw done nstab ', nstab ! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' - print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' - print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' + print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' ! -! print *, ' ugwp -heating rates ' - endif +! print *, ' ugwp -heating rates ' + endif !================================= - return - end subroutine cires_ugwpv1_ngw_solv2 + return + end subroutine cires_ugwpv1_ngw_solv2 end module cires_ugwpv1_solv2 diff --git a/physics/cires_ugwpv1_solv2.F90_mine b/physics/cires_ugwpv1_solv2.F90_mine new file mode 100644 index 000000000..8f417ea1d --- /dev/null +++ b/physics/cires_ugwpv1_solv2.F90_mine @@ -0,0 +1,1049 @@ +module cires_ugwpv1_solv2 + + +contains + + +!--------------------------------------------------- +! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 +! dissipative solver with NonHyd/ROT-effects +! reflected GWs treated as waves with "negligible" flux, +! they are out of given column +!--------------------------------------------------- + + subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & + tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & + xlatd, sinlat, coslat, & + pdudt, pdvdt, pdtdt, dked, zngw) +! +!-------------------------------------------------------------------------------- +! nov 2015 alternative gw-solver for nggps-wam +! nov 2017 nh/rotational gw-modes for nh-fv3gfs +! oct 2019 adding empirical satellite-based +! source function and *F90 CIRES-style of the code +! oct 2020 Diagnostics of "tauabs, wrms, trms" is taken out +! -------------------------------------------------------------------------------- +! + use machine, only : kind_phys + + use cires_ugwpv1_module,only : krad, kvg, kion, ktg, iPr_ktgw, Pr_kdis, Pr_kvkt + + use cires_ugwpv1_module,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms + + use cires_ugwpv1_module,only : psrc => knob_ugwp_palaunch + + use cires_ugwpv1_module,only : maxdudt, maxdtdt, max_eps, dked_min, dked_max + + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & + omega2, rcpd, rcpd2, pi, pi2, fv, & + rad_to_deg, deg_to_rad, & + rdi, gor, grcp, gocp, & + bnv2min, bnv2max, dw2min, velmin, gr2, & + hpscale, rhp, rh4, grav2, rgrav2, mkzmin, mkz2min +! + use ugwp_wmsdis_init, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & + gw_eff, & + nslope, ilaunch, zms, & + zci, zdci, zci4, zci3, zci2, & + zaz_fct, zcosang, zsinang, nwav, nazd, & + zcimin, zcimax, rimin, sc2, sc2u, ric +! + implicit none +! + real(kind=kind_phys), parameter :: zsp_gw = 106.5e3 ! sponge for GWs above the model top + real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 + integer, parameter :: ener_norm =0 + integer, parameter :: ener_lsat=0 + integer, parameter :: nstdif = 1 + integer, parameter :: wave_sponge = 1 + + integer, intent(in) :: levs ! vertical level + integer, intent(in) :: im ! horiz tiles + integer, intent(in) :: mpi_id, master, kdt + + real(kind=kind_phys) ,intent(in) :: dtp ! model time step + real(kind=kind_phys) ,intent(in) :: tau_ngw(im) + + real(kind=kind_phys) ,intent(in) :: vm(im,levs) ! meridional wind + real(kind=kind_phys) ,intent(in) :: um(im,levs) ! zonal wind + real(kind=kind_phys) ,intent(in) :: qm(im,levs) ! spec. humidity + real(kind=kind_phys) ,intent(in) :: tm(im,levs) ! kinetic temperature + + real(kind=kind_phys) ,intent(in) :: prsl(im,levs) ! mid-layer pressure + real(kind=kind_phys) ,intent(in) :: prslk(im,levs) ! mid-layer exner function + real(kind=kind_phys) ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav + real(kind=kind_phys) ,intent(in) :: prsi(im,levs+1) ! interface pressure + real(kind=kind_phys) ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters + real(kind=kind_phys) ,intent(in) :: xlatd(im) ! xlat_d in degrees + real(kind=kind_phys) ,intent(in) :: sinlat(im) + real(kind=kind_phys) ,intent(in) :: coslat(im) +! +! out-gw effects +! + real(kind=kind_phys) ,intent(out) :: pdudt(im,levs) ! zonal momentum tendency + real(kind=kind_phys) ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency + real(kind=kind_phys) ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp and cooling + real(kind=kind_phys) ,intent(out) :: dked(im,levs) ! gw-eddy diffusion + real(kind=kind_phys) ,intent(out) :: zngw(im) ! launch height +! +! +! +! local =========================================================================================== + + real(kind=kind_phys) :: tauabs(im,levs) ! + real(kind=kind_phys) :: wrms(im,levs) ! + real(kind=kind_phys) :: trms(im,levs) ! + + real(kind=kind_phys) :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) + real(kind=kind_phys) :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) +! +! local =========================================================================================== + real(kind=kind_phys) :: taux(levs+1) ! EW component of vertical momentum flux (pa) + real(kind=kind_phys) :: tauy(levs+1) ! NS component of vertical momentum flux (pa) + real(kind=kind_phys) :: fpu(nazd, levs+1) ! az-momentum flux + real(kind=kind_phys) :: ui(nazd, levs+1) ! azimuthal wind + + real(kind=kind_phys) :: fden_bn(levs+1) ! density/brent + real(kind=kind_phys) :: flux (nwav, nazd) , flux_m (nwav, nazd) +! + real(kind=kind_phys) :: bn(levs+1) ! interface BV-frequency + real(kind=kind_phys) :: bn2(levs+1) ! interface BV*BV-frequency + real(kind=kind_phys) :: rhoint(levs+1) ! interface density + real(kind=kind_phys) :: uint(levs+1) ! interface zonal wind + real(kind=kind_phys) :: vint(levs+1) ! meridional wind + real(kind=kind_phys) :: tint(levs+1) ! temp-re + + real(kind=kind_phys) :: irhodz_mid(levs) + real(kind=kind_phys) :: suprf(levs+1) ! RF-super linear dissipation + real(kind=kind_phys) :: cstar(levs+1) ,cstar2(levs+1) + real(kind=kind_phys) :: v_zmet(levs+1) + real(kind=kind_phys) :: vueff(levs+1) + real(kind=kind_phys) :: dfdz_v(nazd, levs), dfdz_heat(nazd, levs) ! axj = -df*rho/dz directional Ax + + real(kind=kind_phys), dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet, dz_met + real(kind=kind_phys), dimension(levs+1) :: aprsi, azmeti, dz_meti + + real(kind=kind_phys), dimension(levs) :: wrk3 + real(kind=kind_phys), dimension(levs) :: uold, vold, told, unew, vnew, tnew + real(kind=kind_phys), dimension(levs) :: rho, rhomid, adif, cdif, acdif + real(kind=kind_phys), dimension(levs) :: Qmid, AKT + real(kind=kind_phys), dimension(levs+1) :: dktur, Ktint, Kvint + real(kind=kind_phys), dimension(levs+1) :: fden_lsat, fden_bnen + + integer, dimension(levs) :: Anstab + + real(kind=kind_phys) :: sig_u2az(nazd), sig_u2az_m(nazd) + real(kind=kind_phys) :: wave_dis(nwav, nazd), wave_disaz(nazd) + real(kind=kind_phys) :: rdci(nwav), rci(nwav) + real(kind=kind_phys) :: wave_act(nwav, nazd) ! active waves at given vert-level + real(kind=kind_phys) :: ul(nazd) ! velocity in azimuthal direction at launch level +! +! scalars +! + real(kind=kind_phys) :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level + real(kind=kind_phys) :: c2f2, cf1, wave_distot + + + real(kind=kind_phys) :: flux_norm ! norm-factor + real(kind=kind_phys) :: taub_src, rho_src, zcool, vmdiff +! + real(kind=kind_phys) :: zthm, dtau, cgz, ucrit_maxdc + real(kind=kind_phys) :: vm_zflx_mode, vc_zflx_mode + real(kind=kind_phys) :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 + real(kind=kind_phys) :: ucrit_max + real(kind=kind_phys) :: pwrms, ptrms + real(kind=kind_phys) :: zu, zcin, zcin2, zcin3, zcin4, zcinc + real(kind=kind_phys) :: zatmp, fluxs, zdep, ze1, ze2 + +! + real(kind=kind_phys) :: zdelp, zdelm, taud_min + real(kind=kind_phys) :: tvc, tvm +! real(kind=kind_phys) :: tvc, tvm, ptc, ptm + real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 + real(kind=kind_phys) :: fmode, expdis, fdis + real(kind=kind_phys) :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit + real(kind=kind_phys) :: v_wdi, v_wdpc + real(kind=kind_phys) :: ugw, vgw, ek1, ek2, rdtp, rdtp2, rhp_wam + + integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz + integer :: ksrc, km2, km1, kp1, ktop +! +! Kturb-part +! + real(kind=kind_phys) :: uz, vz, shr2 , ritur, ktur + + real(kind=kind_phys) :: kamp, zmetk, zgrow + real(kind=kind_phys) :: stab, stab_dt, dtstab + real(kind=kind_phys) :: nslope3 +! + integer :: nstab, ist + real(kind=kind_phys) :: w1, w2, w3, dtdif + + real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp + real(kind=kind_phys) :: rstar, rstar2 + + real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm + real(kind=kind_phys) :: taub_ch, sigu2_ch + real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max + real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr + +!-------------------------------------------------------------------------- +! + nslope3 = nslope + 3.0 + Pr_kdis_eff = gw_eff*pr_kdis + iPr_max = max(1.0, iPr_ktgw) + gipr = grav* Ipr_ktgw +! +! test for input fields +! if (mpi_id == master .and. kdt < -2) then +! print *, im, levs, dtp, kdt, ' vay-solv2-v1' +! print *, minval(tm), maxval(tm), ' min-max-tm ' +! print *, minval(vm), maxval(vm), ' min-max-vm ' +! print *, minval(um), maxval(um), ' min-max-um ' +! print *, minval(qm), maxval(qm), ' min-max-qm ' +! print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' +! print *, minval(prsi), maxval(prsi), ' min-max-Pint ' +! print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' +! print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' +! print *, minval(prslk), maxval(prslk), ' min-max-Exner ' +! print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' +! print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' +! +! endif + + if (idebug_gwrms == 1) then + tauabs = 0.0 ; wrms = 0.0 ; trms = 0.0 + endif + + rci(:) = 1.0 / zci(:) + rdci(:) = 1.0 / zdci(:) + + rdtp = 1.0 / dtp + rdtp2 = 0.5 * rdtp + + ksrc = max(ilaunch, 3) + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + ktop = levs + 1 + + suprf(ktop) = kion(levs) + + do k=1,levs + suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 + pdvdt(:,k) = 0.0 + pdudt(:,k) = 0.0 + pdtdt(:,k) = 0.0 + dked(: ,k) = 0.0 + enddo + +!----------------------------------------------------------- +! column-based j=1,im pjysics with 1D-arrays +!----------------------------------------------------------- + DO j=1, im + jl = j + tx1 = omega2 * sinlat(j) *rv_kxw + cf1 = abs(tx1) + c2f2 = tx1 * tx1 + ucrit_max = max(ucrit, cf1) + ucrit3 = ucrit_max*ucrit_max*ucrit_max +! +! ngw-fluxes at all gridpoints (with tau_min at least) +! + aprsl(1:levs) = prsl(jl,1:levs) +! +! ksrc-define "aprsi(1:levs+1) redefine "ilaunch" +! + do k=1, levs + if (aprsl(k) < psrc ) exit + enddo + ilaunch = max(k-1, 3) + ksrc = max(ilaunch, 3) + + zngw(j) = zmet(j, ksrc) + + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + +!=====ksrc + + do k=1, levs + aum(k) = um(jl,k) + avm(k) = vm(jl,k) + atm(k) = tm(jl,k) + aqm(k) = qm(jl,k) + azmet(k) = zmet(jl,k) + aprsi(k) = prsi(jl,k) + azmeti(k) = zmeti(jl,k) + enddo + aprsi(levs+1) = prsi(jl,levs+1) + azmeti(levs+1) = zmeti(jl,levs+1) + + rho_src = aprsl(ksrc)*rdi/atm(ksrc) + taub_ch = max(tau_ngw(jl), tau_min) + taub_src = taub_ch + + + sigu2 = zms * taub_src / (rho_src*v_kxw) + sig_u2az(1:nazd) = sigu2 +! +! compute diffusion-based arrays km2:levs +! + do jk = km2, levs + dz_meti(jk) = azmeti(jk+1) - azmeti(jk) + dz_met(jk) = azmet(jk) - azmeti(jk-1) + enddo +! --------------------------------------------- +! interface mean flow parameters launch -> levs+1 +! --------------------------------------------- + do jk= km1,levs + tvc = atm(jk) * (1.0 + fv*aqm(jk)) + tvm = atm(jk-1) * (1.0 + fv*aqm(jk-1)) +! ptc = tvc / prslk(jl,jk) ! not used +! ptm = tvm / prslk(jl,jk-1) ! notused +! + zthm = 2.0 / (tvc+tvm) + rhp_wam = zthm*gor +!interface + uint(jk) = 0.5*(aum(jk-1)+aum(jk)) + vint(jk) = 0.5*(avm(jk-1)+avm(jk)) + tint(jk) = 0.5*(tvc+tvm) + rhomid(jk) = aprsl(jk)*rdi/atm(jk) + rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) + zdelp = dz_meti(jk) ! >0 ...... dz-meters + v_zmet(jk) = zdelp + zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] + zdelm = 1.0 / dz_met(jk) ! 1/dz ...... 1/meters +! +! bvf2 = grav2*zdelm*(ptc-ptm) / (ptc + ptm) ! N2=[g/PT]*(dPT/dz) +! + bn2(jk) = grav2cpd*zthm*(1.0+rcpdl*(tvc-tvm)*zdelm) + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + bn(jk) = sqrt(bn2(jk)) + + + wrk3(jk) = 1.0 / (zdelp*rhomid(jk)) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] + irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src +! +! +! diagnostics -Kzz above PBL +! + uz = aum(jk) - aum(jk-1) + vz = avm(jk) - avm(jk-1) + shr2 = max(uz*uz+vz*vz, dw2min) * zdelm *zdelm + + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk) / shr2 + kamp = sqrt(shr2) * sc2 * zgrow + w1 = 1.0 / (1.0 + 5*ritur) + ktur = min(max(kamp * w1 * w1, dked_min), dked_max) + zmetk = azmet(jk)* rhp + vueff(jk) = ktur + kvg(jk) + + akt(jk) = gipr / tvc + enddo + + if (idebug_gwrms == 1) then + do jk= km1,levs + wrk1(jk) = rv_kxw/rhoint(jk) + wrk2(jk) = rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) + enddo + endif + +! +! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) +! + jk = levs + + rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) + tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) + uint(ktop) = aum(jk) + vint(ktop) = avm(jk) + + v_zmet(ktop) = v_zmet(jk) + vueff(ktop) = vueff(jk) + bn2(ktop) = bn2(jk) + bn(ktop) = bn(jk) +! +! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity +! + do jk=km1, levs + akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) + enddo + + + bvi = bn(ksrc); bvi2 = bvi * bvi; + bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi +! +! project winds at ksrc +! + do iaz=1, nazd + ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) + enddo +! + + do jk=ksrc, ktop + cstar(jk) = bn(jk)/zms + cstar2(jk) = cstar(jk)*cstar(jk) + + fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 + + do iaz=1, nazd + zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) + ui(iaz, jk) = zu !- ul(iaz)*0. + enddo + enddo + + rstar = 1.0 / cstar(ksrc) + rstar2 = rstar*rstar +! ----------------------------------------- +! set launch momentum flux spectral density +! ----------------------------------------- + + fpu(1:nazd, km2:ktop) = 0. + + do inc=1,nwav + + zcin = zci(inc)*rstar + +! +! integrate (flux(cin) x dcin ) old tau-flux and normalization +! + flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) +! +! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] +! + fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less + + do iaz=1,nazd + akzw(inc, iaz, ksrc) = bvi*rci(inc) + enddo + + enddo +! +! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) + + flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] + ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 + do jk=ksrc, ktop + fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 + enddo +! + do inc=1, nwav + flux(inc,1) = flux_norm*flux(inc,1) + enddo + + if (ener_norm == 1) then + snorm_ener = 0. + do inc=1,nwav + zcin = zci(inc)*rstar + ze2 = zcin / (1.0 + zcin**nslope3) + snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less + flux(inc,1) = ze2 * zcin + enddo + + ekin_norm = 1.0 / snorm_ener + +! taub_src = sigu2 * rho_src * [v_kxw / zms ] +! sigu2 = taub_src*zms/(rho_src/v_kxw) +! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns + + ze1 = taub_src*zms/bvi * ekin_norm + taub_src = 0. + + do inc=1,nwav + flux(inc,1) = ze1* flux(inc,1) + taub_src = taub_src + flux(inc,1)*zdci(inc) + enddo + ze1 = ekin_norm * v_kxw * rstar2 + do jk=ksrc, ktop + fden_bnen(jk) = rhoint(jk) / bn(jk) * ze1 ! mult on => sigu2(z)*cdf2 => flux_sat + enddo + + endif +! + do iaz=1,nazd + fpu(iaz, ksrc) = taub_src + fpu(iaz, km1) = taub_src + enddo + +! copy flux-1 into other azimuths +! -------------------------------- + + + do iaz=2, nazd + do inc=1,nwav + flux(inc,iaz) = flux(inc,1) + enddo + enddo + +! if (mpi_id == master .and. ener_norm == 1) then +! print * +! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm +! print * +! endif + + if (idebug_gwrms == 1) then + pwrms = 0. + ptrms = 0. + tx1 = real(nazd)/rhoint(ksrc)*rv_kxw + ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 + do inc=1, nwav + v_kzw = bvi*rci(inc) + ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw + pwrms = pwrms + ze1 + ptrms = ptrms + ze1 * ze2 + enddo + wrms(jl, ksrc) = pwrms + trms(jl, ksrc) = ptrms + endif + +! -------------------------------- + wave_act(:,:) = 1.0 +! vertical do-loop + do jk=ksrc, levs + + jkp = jk+1 +! azimuth do-loop + do iaz=1, nazd + + sig_u2az_m(iaz) = sig_u2az(iaz) + + umfp = ui(iaz, jkp) + umfm = ui(iaz, jk) + umfc = .5*(umfm + umfp) +! wave-cin loop + dfdz_v(iaz, jk) = 0.0 + dfdz_heat(iaz, jk) = 0.0 + fpu(iaz, jkp) = 0.0 + sig_u2az(iaz) = 0.0 +! +! wave_dis(iaz, :) = vueff(jk) + do inc=1, nwav + flux_m(inc, iaz) = flux(inc, iaz) + + zcin = zci(inc) ! zcin =/0 by definition + zcinc = rci(inc) + + if (wave_act(inc,iaz) == 1.0) then +!======================================================================= +! discrete mode +! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat +! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) +!======================================================================= + + v_cdp = zcin - umfp + v_cdp2=v_cdp*v_cdp + cdf2 = v_cdp2 - c2f2 + if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then +! +! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max, wave's absorption +! + wave_act(inc,iaz) = 0. + akzw(inc, iaz, jkp) = pi/dz_meti(jk) ! pi2/dzmet + fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) + flux(inc,iaz) = fluxs + + else + + v_wdp = v_kxw * v_cdp + wdop2 = v_wdp * v_wdp + +! +! rotational cut-off +! + kzw2 = (bn2(jkp)-wdop2)/Cdf2 +! +!cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 +! + if ( kzw2 > mkz2min ) then + v_kzw = sqrt(kzw2) + akzw(inc, iaz, jkp) = v_kzw +! +!linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 +! +!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) +! Kds_sat = kxw*Cdf1*rhp2/kzw3 +!krad, kvg, kion, ktg + v_cdp = sqrt( cdf2 ) + v_wdp = v_kxw * v_cdp + v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due for "all" vars + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc + +! + ze1 = v_kzi*v_zmet(jk) + + if (ze1 .ge. 1.e-2) then + expdis = max(exp(-ze1), 0.01) + else + expdis = 1.0 / (1.0 + ze1) + endif + +! + wave_act(inc,iaz) = 1.0 + fmode = flux(inc,iaz) + + flux_2_sig = v_kzw / (v_kxw*rhoint(jkp)) + w1 = v_wdpc / (kzw2*v_kzw*v_zmet(jk)) + else ! kzw2 <= mkz2min large "Lz"-reflection + + expdis = 1.0 + v_kzw = mkzmin + + v_cdp = 0. ! no effects of reflected waves + wave_act(inc,iaz) = 0.0 + akzw(inc, iaz, jkp) = v_kzw + fmode = 0. + w1 = 0. + endif + +! expdis =1.0 + + fdis = fmode*expdis*wave_act(inc,iaz) +!============================================================================== +! +! Saturated Fluxes and Energy: Spectral and Dicrete Modes +! +! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin +! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) +! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 +! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] +! +! old-sat fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) +! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) +! new sat fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) +! +! fluxs = fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) + +! +! +! old spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*sqrt(cdf2) +! new spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*cdf2*rstar2 +! [fden_bn(jkp)] = Pa/dc +! fsat = rstar*(zcin*zcin) * [taub_src / SN * [ rstar3*rho/rho_src *N_src/N] = fden_bn ] + + if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] +! +! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc +! + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) + + if (ener_norm == 1) then + +! spectral saturation limit + + if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) + +! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc + + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) +! + endif +!---------------------------------------------------------------------------- +! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw +! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +!---------------------------------------------------------------------------- + zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa + if (zdep > 0.0 ) then +! subs on sat-limit + ze1 = flux(inc,iaz) + flux(inc,iaz) = fluxs + ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs + ! here we can add extra-dissip for the next layer +!Moorthi the above ze2 is not used it appears! + + else +! assign dis-ve flux + flux(inc,iaz) = fdis + endif + + dtau = flux_m(inc,iaz)-flux(inc,iaz) + if (dtau .lt. 0) then + flux(inc,iaz) = flux_m(inc,iaz) + endif +! +! GW-sponge domain: saturate all "GW"-modes above "zsp_gw" +! + if ( azmeti(jkp) >= zsp_gw) then +! mi_sponge = 0.5 / dz_meti(jk) +! ze2 = v_wdp / v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] +! v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge + + v_wdi = 0.5 * v_wdp / (v_kzw *dz_meti(jk)) + v_wdi*0.25 ! diss-sat GW-sponge + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc +! +! ze1 = v_kzi*v_zmet(jk) +! exp_sponge = exp(-ze1) + exp_sponge = exp(-v_kzi*v_zmet(jk)) +! +! additional sponge +! + flux(inc,iaz) = flux(inc,iaz) *exp_sponge + endif + + endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then + endif ! only for waves w/o CL-absorption wave_act=1 +! +! sum for given (jk, iaz) all active "wave" contributions +! + if (wave_act(inc,iaz) == 1) then + + zcinc = zdci(inc) + vc_zflx_mode = flux(inc,iaz) + vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) + if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) + ze1 = vc_zflx_mode*zcinc + fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at + sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! (heat deposition integration over spectral mode for each azimuth +! later sum over selected azimuths as "non-negative" scalars) +! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! zdelp = wrk3(jk)*cdf1 *zcinc + + zdelp = wrk3(jk) * v_cdp * zcinc * vmdiff + + +! zcool = 1. ! COOL=(-3.5 + Pr)/Pr +! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp +! edis = (c-u)*ax/cp = Kv_dis*N2/cp +! cool = -Kt*N2/R +! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] +! + dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 + dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 + endif !wave_act(inc,iaz) == 1) +! + enddo ! wave-inc-loop + + ze1 = fpu(iaz, jk) + if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 +! +! compute wind and temp-re rms +! + if (idebug_gwrms == 1) then + pwrms = 0. + ptrms = 0. + do inc=1, nwav + if (wave_act(inc,iaz) > 0.) then + v_kzw = akzw(inc, iaz, jk) + ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) + pwrms = pwrms + ze1 + ptrms = ptrms + ze1*wrk2(jk) + endif + enddo + Awrms(iaz, jk) = pwrms + Atrms(iaz, jk) = ptrms + endif + +! -------------- + enddo ! end Azimuth do-loop + +! +! eddy wave dissipation to limit GW-rms +! + tx1 = sum(abs(dfdz_heat(1:nazd, jk))) / bn2(jk) + ze1 = max(dked_min, tx1) + ze2 = min(dked_max, ze1) + vueff(jkp) = ze2 + vueff(jkp) +! + enddo ! end Vertical do-loop +! +! top-layers constant interface-fluxes and zero-heat +! we allow non-zero momentum fluxes and thermal effects +! fpu(1:nazd,levs+1) = fpu(1:nazd, levs) +! dfdz_v(1:nazd, levs) = 0.0 + +! --------------------------------------------------------------------- +! sum contribution for total zonal and meridional fluxes + +! energy dissipation +! --------------------------------------------------- +! +!======================================================================== +! at the source level and below taux = 0 (taux_E=-taux_W by assumption) +!======================================================================== + + do jk=ksrc, levs + taux(jk) = 0.0 + tauy(jk) = 0.0 + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + pdtdt(jl,jk) = pdtdt(jl,jk) + dfdz_v(iaz,jk) + dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) + enddo + enddo + jk = ktop ; taux(jk) = 0. ; tauy(jk) = 0. + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + enddo + + if (idebug_gwrms == 1) then + do jk=kp1, levs + do iaz=1,nazd + wrms(jl,jk) = wrms(jl,jk) + Awrms(iaz,jk) + trms(jl,jk) = trms(jl,jk) + Atrms(iaz,jk) + tauabs(jl,jk) = tauabs(jl,jk) + fpu(iaz,jk) + enddo + enddo + endif +! + + do jk=ksrc+1,levs + jkp = jk + 1 + zdelp = wrk3(jk)*gw_eff + ze1 = (taux(jkp)-taux(jk)) * zdelp + ze2 = (tauy(jkp)-tauy(jk)) * zdelp + + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif + + pdudt(jl,jk) = -ze1 + pdvdt(jl,jk) = -ze2 +! +! Cx =0 based Cx=/= 0. above +! +! + if (knob_ugwp_doheat == 1) then +! +! maxdtdt= dked_max * bnfix2 +! + pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff + ze2 = pdtdt(jl,jk) + if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) + + dked(jl,jk) = dked(jl,jk) / bn2(jk) + ze1 = max(dked_min, dked(jl,jk)) + dked(jl,jk) = min(dked_max, ze1) + qmid(jk) = pdtdt(j,jk) + endif + enddo +!---------------------------------------------------------------------------------- +! Update heat = ek_diss/cp and aply 1-2-1 smoother for "dked" => dktur +! here with "u_new = u +dtp*dudt ; vnew = v + v +dtp*dvdt +! can check "stability" in the column and "add" ktur-estimation +! to suppress instability as needed so dked = dked_gw + ktur_ric +!---------------------------------------------------------------------------------- + + dktur(1:levs) = dked(jl,1:levs) +! + do ist= 1, nstdif + do jk=ksrc,levs-1 + adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) + enddo + dktur(ksrc:levs-1) = adif(ksrc:levs-1) + enddo + dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) + dktur(levs+1) = dktur(levs) + + do jk=ksrc,levs+1 + ze1 = .5*( dktur(jk) +dktur(jk-1) ) + kvint(jk) = ze1 + ktint(jk) = ze1*iPr_ktgw + enddo + +! +! Thermal budget qmid = qheat + qcool +! + do jk=ksrc+1,levs + ze2 = qmid(jk) + dktur(jk)*Akt(jk) + grav*(ktint(jk+1)-ktint(jk))/dz_meti(jk) + qmid(jk) = ze2 + if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) + pdtdt(jl,jk) = qmid(jk)*rcpd + dked(jl, jk) = dktur(jk) + enddo +! +! perform explicit eddy "diffusive" 3-point smoothing of "u-v-t" +! from the surface/launch-gw to the "top" +! +! + do jk=km2,levs +! update by source function X(t+dt) = X(t) + dtp * dXdt +! + uold(jk) = aum(jk) + pdudt(jl,jk) * dtp + vold(jk) = avm(jk) + pdvdt(jl,jk) * dtp + told(jk) = atm(jk) + pdtdt(jl,jk) * dtp +! +! diagnose turb-profile using "stability-check" relying on the free-atm diffusion +! sc2 = 30m x 30m +! + dktur(jk) = dked_min + enddo + + do jk=km1,levs + uz = uold(jk) - uold(jk-1) + vz = vold(jk) - vold(jk-1) + ze1 = dz_met(jk) + zdelm = 1.0 / ze1 + + tvc = told(jk) * (1. +fv*aqm(jk)) + tvm = told(jk-1) * (1. +fv*aqm(jk-1)) + zthm = 2.0 / (tvc+tvm) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + + bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) + + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + w1 = 1.0 / (1.0 + 5*ritur) + ze2 = min( sc2 *zgrow, 4.*ze1*ze1) +! +! Smag-type of eddy diffusion K_smag = Sqrt(Deformation - N2/Pr)* L2 *const +! + kamp = sqrt(shr2)* ze2 * w1 * w1 + ktur = min(max(kamp, dked_min), dked_max) + dktur(jk) = ktur +! +! update of dked = dked_gw + k_turb_mf +! + dked(jl, jk) = dked(jl, jk) +ktur + + enddo + +! +! apply eddy effects due to GWs: explicit scheme Kzz*dt/dz2 < 0.5 stability +! + if (knob_ugwp_dokdis == 2) then + + do jk=ksrc,levs + ze1 = min(.5*(dktur(jk)+dktur(jk-1)), dturb_max) + kvint(jk) = kvint(jk) + ze1 +! ktint(jk) = ktint(jk) + ze1*iPr_ktgw + enddo + kvint(km1) = kvint(ksrc) + kvint(ktop) = kvint(levs) + + dzmetm = 1./dz_met(km1) + Adif(km1:levs) = 0. + Cdif(km1:levs) = 0. + do jk=km1,levs-1 + + dzmetp = 1.0 / dz_met(jk+1) + dzmetf = 1.0 / (dz_meti(jk)*rhomid(jk)) + + + ktur = kvint(jk) * rhoint(jk) * dzmetf + kturp = Kvint(jk+1) * rhoint(jk+1) * dzmetf + + Adif(jk) = ktur * dzmetm + Cdif(jk) = kturp * dzmetp + ApC = adif(jk) + cdif(jk) + ACdif(jk) = ApC + + w1 = ApC*iPr_max + if (rdtp < w1 ) then + Anstab(jk) = floor(w1*dtp) + 1 + else + Anstab(jk) = 1 + endif + dzmetm = dzmetp + enddo + + nstab = maxval( Anstab(ksrc:levs-1)) + +! if (nstab .ge. 3) print *, 'nstab ', nstab +! +! k instead Jk +! + dtdif = dtp/real(nstab) + ze1 = 1./dtdif + + do ist= 1, nstab + do k=ksrc,levs-1 + Bdif = ze1 - ACdif(k) + Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 + unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) + vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) + tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw + enddo + + do k=ksrc,levs-1 + uold(k) = unew(k) * dtdif ! value du/dtp *dtp = du + vold(k) = vnew(k) * dtdif + told(k) = tnew(k) * dtdif + enddo +! +! smoothing the boundary points: "k-1" = ksrc-1 and "k+1" = levs +! + uold(levs) = uold(levs-1) + vold(levs) = vold(levs-1) + told(levs) = told(levs-1) + enddo +! +! compute "smoothed" tendencies by molecular + GW-eddy diffusions +! + do k=ksrc,levs-1 +! +! final updates of tendencies and diffusion +! + ze2 = rdtp * (uold(k) - aum(k)) + ze1 = rdtp * (vold(k) - avm(k)) + pdtdt(jl,k) = rdtp * (told(k) - atm(k)) + + if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif + + pdudt(jl, k) = ze2 + pdvdt(jl, k) = ze1 + uz = uold(k+1) - uold(k-1) + vz = vold(k+1) - vold(k-1) + ze2 = 1.0 / (dz_met(k+1)+dz_met(k) ) + + mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat + pdtdt(jl,k) = pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity + + enddo + + + ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t + + enddo ! J-loop +! + RETURN + +!================================= diag print after "return" ====================== + if (kdt ==1 .and. mpi_id == master) then +! + print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' + print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) + print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) +! print *, 'ugwpv1: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min + + print * + + endif + + if (kdt == 1 .and. mpi_id == master) then + print *, 'vgw done nstab ', nstab +! + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' + print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' +! +! print *, ' ugwp -heating rates ' + endif +!================================= + return + end subroutine cires_ugwpv1_ngw_solv2 + + +end module cires_ugwpv1_solv2 diff --git a/physics/cires_ugwpv1_solv2.F90_orig b/physics/cires_ugwpv1_solv2.F90_orig new file mode 100644 index 000000000..afd94ff5c --- /dev/null +++ b/physics/cires_ugwpv1_solv2.F90_orig @@ -0,0 +1,1036 @@ +module cires_ugwpv1_solv2 + + +contains + + +!--------------------------------------------------- +! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 +! dissipative solver with NonHyd/ROT-effects +! reflected GWs treated as waves with "negligible" flux, +! they are out of given column +!--------------------------------------------------- + + subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & + tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & + xlatd, sinlat, coslat, & + pdudt, pdvdt, pdtdt, dked, zngw) +! +!-------------------------------------------------------------------------------- +! nov 2015 alternative gw-solver for nggps-wam +! nov 2017 nh/rotational gw-modes for nh-fv3gfs +! oct 2019 adding empirical satellite-based +! source function and *F90 CIRES-style of the code +! oct 2020 Diagnostics of "tauabs, wrms, trms" is taken out +! -------------------------------------------------------------------------------- +! + use machine, only : kind_phys + + use cires_ugwpv1_module,only : krad, kvg, kion, ktg, iPr_ktgw, Pr_kdis, Pr_kvkt + + use cires_ugwpv1_module,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms + + use cires_ugwpv1_module,only : psrc => knob_ugwp_palaunch + + use cires_ugwpv1_module,only : maxdudt, maxdtdt, max_eps, dked_min, dked_max + + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & + omega2, rcpd, rcpd2, pi, pi2, fv, & + rad_to_deg, deg_to_rad, & + rdi, gor, grcp, gocp, & + bnv2min, bnv2max, dw2min, velmin, gr2, & + hpscale, rhp, rh4, grav2, rgrav2, mkzmin, mkz2min +! + use ugwp_wmsdis_init, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & + gw_eff, & + nslope, ilaunch, zms, & + zci, zdci, zci4, zci3, zci2, & + zaz_fct, zcosang, zsinang, nwav, nazd, & + zcimin, zcimax, rimin, sc2, sc2u, ric +! + implicit none +! + real(kind=kind_phys), parameter :: zsp_gw = 106.5e3 ! sponge for GWs above the model top + real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 + integer, parameter :: ener_norm =0 + integer, parameter :: ener_lsat=0 + integer, parameter :: nstdif = 1 + integer, parameter :: wave_sponge = 1 + + integer, intent(in) :: levs ! vertical level + integer, intent(in) :: im ! horiz tiles + integer, intent(in) :: mpi_id, master, kdt + + real(kind=kind_phys) ,intent(in) :: dtp ! model time step + real(kind=kind_phys) ,intent(in) :: tau_ngw(im) + + real(kind=kind_phys) ,intent(in) :: vm(im,levs) ! meridional wind + real(kind=kind_phys) ,intent(in) :: um(im,levs) ! zonal wind + real(kind=kind_phys) ,intent(in) :: qm(im,levs) ! spec. humidity + real(kind=kind_phys) ,intent(in) :: tm(im,levs) ! kinetic temperature + + real(kind=kind_phys) ,intent(in) :: prsl(im,levs) ! mid-layer pressure + real(kind=kind_phys) ,intent(in) :: prslk(im,levs) ! mid-layer exner function + real(kind=kind_phys) ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav + real(kind=kind_phys) ,intent(in) :: prsi(im,levs+1) ! interface pressure + real(kind=kind_phys) ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters + real(kind=kind_phys) ,intent(in) :: xlatd(im) ! xlat_d in degrees + real(kind=kind_phys) ,intent(in) :: sinlat(im) + real(kind=kind_phys) ,intent(in) :: coslat(im) +! +! out-gw effects +! + real(kind=kind_phys) ,intent(out) :: pdudt(im,levs) ! zonal momentum tendency + real(kind=kind_phys) ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency + real(kind=kind_phys) ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp and cooling + real(kind=kind_phys) ,intent(out) :: dked(im,levs) ! gw-eddy diffusion + real(kind=kind_phys) ,intent(out) :: zngw(im) ! launch height +! +! +! +! local =========================================================================================== + + real(kind=kind_phys) :: tauabs(im,levs) ! + real(kind=kind_phys) :: wrms(im,levs) ! + real(kind=kind_phys) :: trms(im,levs) ! + + real(kind=kind_phys) :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) + real(kind=kind_phys) :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) +! +! local =========================================================================================== + real(kind=kind_phys) :: taux(levs+1) ! EW component of vertical momentum flux (pa) + real(kind=kind_phys) :: tauy(levs+1) ! NS component of vertical momentum flux (pa) + real(kind=kind_phys) :: fpu(nazd, levs+1) ! az-momentum flux + real(kind=kind_phys) :: ui(nazd, levs+1) ! azimuthal wind + + real(kind=kind_phys) :: fden_bn(levs+1) ! density/brent + real(kind=kind_phys) :: flux (nwav, nazd) , flux_m (nwav, nazd) +! + real(kind=kind_phys) :: bn(levs+1) ! interface BV-frequency + real(kind=kind_phys) :: bn2(levs+1) ! interface BV*BV-frequency + real(kind=kind_phys) :: rhoint(levs+1) ! interface density + real(kind=kind_phys) :: uint(levs+1) ! interface zonal wind + real(kind=kind_phys) :: vint(levs+1) ! meridional wind + real(kind=kind_phys) :: tint(levs+1) ! temp-re + + real(kind=kind_phys) :: irhodz_mid(levs) + real(kind=kind_phys) :: suprf(levs+1) ! RF-super linear dissipation + real(kind=kind_phys) :: cstar(levs+1) ,cstar2(levs+1) + real(kind=kind_phys) :: v_zmet(levs+1) + real(kind=kind_phys) :: vueff(levs+1) + real(kind=kind_phys) :: dfdz_v(nazd, levs), dfdz_heat(nazd, levs) ! axj = -df*rho/dz directional Ax + + real(kind=kind_phys), dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet, dz_met + real(kind=kind_phys), dimension(levs+1) :: aprsi, azmeti, dz_meti + + real(kind=kind_phys), dimension(levs) :: wrk3 + real(kind=kind_phys), dimension(levs) :: uold, vold, told, unew, vnew, tnew + real(kind=kind_phys), dimension(levs) :: rho, rhomid, adif, cdif, acdif + real(kind=kind_phys), dimension(levs) :: Qmid, AKT + real(kind=kind_phys), dimension(levs+1) :: dktur, Ktint, Kvint + real(kind=kind_phys), dimension(levs+1) :: fden_lsat, fden_bnen + + integer, dimension(levs) :: Anstab + + real(kind=kind_phys) :: sig_u2az(nazd), sig_u2az_m(nazd) + real(kind=kind_phys) :: wave_dis(nwav, nazd), wave_disaz(nazd) + real(kind=kind_phys) :: rdci(nwav), rci(nwav) + real(kind=kind_phys) :: wave_act(nwav, nazd) ! active waves at given vert-level + real(kind=kind_phys) :: ul(nazd) ! velocity in azimuthal direction at launch level +! +! scalars +! + real(kind=kind_phys) :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level + real(kind=kind_phys) :: c2f2, cf1, wave_distot + + + real(kind=kind_phys) :: flux_norm ! norm-factor + real(kind=kind_phys) :: taub_src, rho_src, zcool, vmdiff +! + real(kind=kind_phys) :: zthm, dtau, cgz, ucrit_maxdc + real(kind=kind_phys) :: vm_zflx_mode, vc_zflx_mode + real(kind=kind_phys) :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 + real(kind=kind_phys) :: ucrit_max + real(kind=kind_phys) :: pwrms, ptrms + real(kind=kind_phys) :: zu, zcin, zcin2, zcin3, zcin4, zcinc + real(kind=kind_phys) :: zatmp, fluxs, zdep, ze1, ze2 + +! + real(kind=kind_phys) :: zdelp, zdelm, taud_min + real(kind=kind_phys) :: tvc, tvm, ptc, ptm + real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 + real(kind=kind_phys) :: fmode, expdis, fdis + real(kind=kind_phys) :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit + real(kind=kind_phys) :: v_wdi, v_wdpc + real(kind=kind_phys) :: ugw, vgw, ek1, ek2, rdtp, rdtp2, rhp_wam + + integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz + integer :: ksrc, km2, km1, kp1, ktop +! +! Kturb-part +! + real(kind=kind_phys) :: uz, vz, shr2 , ritur, ktur + + real(kind=kind_phys) :: kamp, zmetk, zgrow + real(kind=kind_phys) :: stab, stab_dt, dtstab + real(kind=kind_phys) :: nslope3 +! + integer :: nstab, ist + real(kind=kind_phys) :: w1, w2, w3, dtdif + + real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp + real(kind=kind_phys) :: rstar, rstar2 + + real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm + real(kind=kind_phys) :: taub_ch, sigu2_ch + real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max + real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr + +!-------------------------------------------------------------------------- +! + nslope3 = nslope + 3.0 + Pr_kdis_eff = gw_eff*pr_kdis + iPr_max = max(1.0, iPr_ktgw) + gipr = grav* Ipr_ktgw +! +! test for input fields +! if (mpi_id == master .and. kdt < -2) then +! print *, im, levs, dtp, kdt, ' vay-solv2-v1' +! print *, minval(tm), maxval(tm), ' min-max-tm ' +! print *, minval(vm), maxval(vm), ' min-max-vm ' +! print *, minval(um), maxval(um), ' min-max-um ' +! print *, minval(qm), maxval(qm), ' min-max-qm ' +! print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' +! print *, minval(prsi), maxval(prsi), ' min-max-Pint ' +! print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' +! print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' +! print *, minval(prslk), maxval(prslk), ' min-max-Exner ' +! print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' +! print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' +! +! endif + + if (idebug_gwrms == 1) then + tauabs=0.0; wrms =0.0 ; trms =0.0 + endif + + rci(:) = 1./zci(:) + rdci(:) = 1./zdci(:) + + rdtp = 1./dtp + rdtp2 = 0.5*rdtp + + ksrc= max(ilaunch, 3) + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + ktop= levs+1 + + suprf(ktop) = kion(levs) + + do k=1,levs + suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 + pdvdt(:,k) = 0.0 + pdudt(:,k) = 0.0 + pdtdt(:,k) = 0.0 + dked(: ,k) = 0.0 + enddo + +!----------------------------------------------------------- +! column-based j=1,im pjysics with 1D-arrays +!----------------------------------------------------------- + DO j=1, im + jl =j + tx1 = omega2 * sinlat(j) *rv_kxw + cf1 = abs(tx1) + c2f2 = tx1 * tx1 + ucrit_max = max(ucrit, cf1) + ucrit3 = ucrit_max*ucrit_max*ucrit_max +! +! ngw-fluxes at all gridpoints (with tau_min at least) +! + aprsl(1:levs) = prsl(jl,1:levs) +! +! ksrc-define "aprsi(1:levs+1) redefine "ilaunch" +! + do k=1, levs + if (aprsl(k) .lt. psrc ) exit + enddo + ilaunch = max(k-1, 3) + ksrc= max(ilaunch, 3) + + zngw(j) = zmet(j, ksrc) + + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + +!=====ksrc + + aum(1:levs) = um(jl,1:levs) + avm(1:levs) = vm(jl,1:levs) + atm(1:levs) = tm(jl,1:levs) + aqm(1:levs) = qm(jl,1:levs) + azmet(1:levs) = zmet(jl,1:levs) + aprsi(1:levs+1) = prsi(jl,1:levs+1) + azmeti(1:levs+1) = zmeti(jl,1:levs+1) + + rho_src = aprsl(ksrc)*rdi/atm(ksrc) + taub_ch = max(tau_ngw(jl), tau_min) + taub_src = taub_ch + + + sigu2 = taub_src/rho_src/v_kxw * zms + sig_u2az(1:nazd) = sigu2 +! +! compute diffusion-based arrays km2:levs +! + do jk = km2, levs + dz_meti(jk) = azmeti(jk+1)-azmeti(jk) + dz_met(jk) = azmet(jk)-azmeti(jk-1) + enddo +! --------------------------------------------- +! interface mean flow parameters launch -> levs+1 +! --------------------------------------------- + do jk= km1,levs + tvc = atm(jk)*(1. +fv*aqm(jk)) + tvm = atm(jk-1)*(1. +fv*aqm(jk-1)) + ptc = tvc/ prslk(jl, jk) + ptm = tvm/prslk(jl,jk-1) +! + zthm = 2.0/(tvc+tvm) + rhp_wam = zthm*gor +!interface + uint(jk) = 0.5*(aum(jk-1)+aum(jk)) + vint(jk) = 0.5*(avm(jk-1)+avm(jk)) + tint(jk) = 0.5*(tvc+tvm) + rhomid(jk) = aprsl(jk)*rdi/atm(jk) + rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) + zdelp = dz_meti(jk) ! >0 ...... dz-meters + v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] + zdelm = 1./dz_met(jk) ! 1/dz ...... 1/meters +! +! bvf2 = grav2*zdelm*(ptc-ptm)/(ptc + ptm) ! N2=[g/PT]*(dPT/dz) +! + bn2(jk) = grav2cpd*zthm*(1.0+rcpdl*(tvc-tvm)*zdelm) + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + bn(jk) = sqrt(bn2(jk)) + + + wrk3(jk)= 1./zdelp/rhomid(jk) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] + irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src +! +! +! diagnostics -Kzz above PBL +! + uz = aum(jk) - aum(jk-1) + vz = avm(jk) - avm(jk-1) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + kamp = sqrt(shr2)*sc2 *zgrow + w1 = 1./(1. + 5*ritur) + ktur= min(max(kamp * w1 * w1, dked_min), dked_max) + zmetk = azmet(jk)* rhp + vueff(jk) = ktur + kvg(jk) + + akt(jk) = gipr/tvc + enddo + + if (idebug_gwrms == 1) then + do jk= km1,levs + wrk1(jk) = rv_kxw/rhoint(jk) + wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) + enddo + endif + +! +! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) +! + jk = levs + + rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) + tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) + uint(ktop) = aum(jk) + vint(ktop) = avm(jk) + + v_zmet(ktop) = v_zmet(jk) + vueff(ktop) = vueff(jk) + bn2(ktop) = bn2(jk) + bn(ktop) = bn(jk) +! +! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity +! + do jk=km1, levs + akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) + enddo + + + bvi = bn(ksrc); bvi2 = bvi * bvi; + bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi +! +! project winds at ksrc +! + do iaz=1, nazd + ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) + enddo +! + + do jk=ksrc, ktop + cstar(jk) = bn(jk)/zms + cstar2(jk) = cstar(jk)*cstar(jk) + + fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 + + do iaz=1, nazd + zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) + ui(iaz, jk) = zu !- ul(iaz)*0. + enddo + enddo + + rstar = 1./cstar(ksrc) + rstar2 = rstar*rstar +! ----------------------------------------- +! set launch momentum flux spectral density +! ----------------------------------------- + + fpu(1:nazd, km2:ktop) =0. + + do inc=1,nwav + + zcin = zci(inc)*rstar + +! +! integrate (flux(cin) x dcin ) old tau-flux and normalization +! + flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) +! +! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] +! + fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less + + do iaz=1,nazd + akzw(inc, iaz, ksrc) = bvi*rci(inc) + enddo + + enddo +! +! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) + + flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] + ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 + do jk=ksrc, ktop + fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 + enddo +! + do inc=1, nwav + flux(inc,1) = flux_norm*flux(inc,1) + enddo + + + if (ener_norm == 1) then + snorm_ener = 0. + do inc=1,nwav + zcin = zci(inc)*rstar + + ze2 = zcin /(1.+ zcin**nslope3) + + snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less + flux(inc,1) = ze2 * zcin + enddo + + ekin_norm = 1./snorm_ener + +! taub_src = sigu2 * rho_src * [v_kxw / zms ] +! sigu2 = taub_src*zms/(rho_src/v_kxw) +! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns + + ze1 = taub_src*zms/bvi * ekin_norm + taub_src = 0. + + do inc=1,nwav + flux(inc,1) = ze1* flux(inc,1) + taub_src = taub_src + flux(inc,1)*zdci(inc) + enddo + ze1 = ekin_norm * v_kxw * rstar2 + do jk=ksrc, ktop + fden_bnen(jk) = rhoint(jk) / bn(jk) *ze1 ! mult on => sigu2(z)*cdf2 => flux_sat + enddo + + endif +! + do iaz=1,nazd + fpu(iaz, ksrc) = taub_src + fpu(iaz, km1) = taub_src + enddo + +! copy flux-1 into other azimuths +! -------------------------------- + + + do iaz=2, nazd + do inc=1,nwav + flux(inc,iaz) = flux(inc,1) + enddo + enddo + +! if (mpi_id == master .and. ener_norm == 1) then +! print * +! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm +! print * +! endif + + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + tx1 = real(nazd)/rhoint(ksrc)*rv_kxw + ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 + do inc=1, nwav + v_kzw = bvi*rci(inc) + ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw + pwrms = pwrms + ze1 + ptrms = ptrms + ze1 * ze2 + enddo + wrms(jl, ksrc) = pwrms + trms(jl, ksrc) = ptrms + endif + +! -------------------------------- + wave_act(:,:) = 1.0 +! vertical do-loop + do jk=ksrc, levs + + jkp = jk+1 +! azimuth do-loop + do iaz=1, nazd + + sig_u2az_m(iaz) = sig_u2az(iaz) + + umfp = ui(iaz, jkp) + umfm = ui(iaz, jk) + umfc = .5*(umfm + umfp) +! wave-cin loop + dfdz_v(iaz, jk) = 0.0 + dfdz_heat(iaz, jk) = 0.0 + fpu(iaz, jkp) = 0.0 + sig_u2az(iaz) =0.0 +! +! wave_dis(iaz, :) = vueff(jk) + do inc=1, nwav + flux_m(inc, iaz) = flux(inc, iaz) + + zcin = zci(inc) ! zcin =/0 by definition + zcinc = rci(inc) + + if(wave_act(inc,iaz) == 1.0) then +!======================================================================= +! discrete mode +! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat +! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) +!======================================================================= + + v_cdp = zcin - umfp + v_cdp2=v_cdp*v_cdp + cdf2 = v_cdp2 - c2f2 + if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then +! +! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max, wave's absorption +! + wave_act(inc,iaz) =0. + akzw(inc, iaz, jkp) = pi/dz_meti(jk) ! pi2/dzmet + fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) + flux(inc,iaz) = fluxs + + else + + v_wdp = v_kxw*v_cdp + wdop2 = v_wdp* v_wdp + +! +! rotational cut-off +! + kzw2 = (bn2(jkp)-wdop2)/Cdf2 +! +!cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 +! + if ( kzw2 > mkz2min ) then + v_kzw = sqrt(kzw2) + akzw(inc, iaz, jkp) = v_kzw +! +!linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 +! +!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) +! Kds_sat = kxw*Cdf1*rhp2/kzw3 +!krad, kvg, kion, ktg + v_cdp = sqrt( cdf2 ) + v_wdp = v_kxw * v_cdp + v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due for "all" vars + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc + +! + ze1 = v_kzi*v_zmet(jk) + + if (ze1 .ge. 1.e-2) then + expdis = max(exp(-ze1), 0.01) + else + expdis = 1./(1.+ ze1) + endif + +! + wave_act(inc,iaz) = 1.0 + fmode = flux(inc,iaz) + + flux_2_sig = v_kzw/v_kxw/rhoint(jkp) + w1 = v_wdpc/kzw2/v_kzw/v_zmet(jk) + else ! kzw2 <= mkz2min large "Lz"-reflection + + expdis = 1.0 + v_kzw = mkzmin + + v_cdp = 0. ! no effects of reflected waves + wave_act(inc,iaz) = 0.0 + akzw(inc, iaz, jkp) = v_kzw + fmode = 0. + w1 =0. + endif +! expdis =1.0 + + fdis = fmode*expdis*wave_act(inc,iaz) +!============================================================================== +! +! Saturated Fluxes and Energy: Spectral and Dicrete Modes +! +! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin +! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) +! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 +! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] +! +! old-sat fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) +! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) +! new sat fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) +! +! fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) + +! +! +! old spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*sqrt(cdf2) +! new spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*cdf2*rstar2 +! [fden_bn(jkp)] = Pa/dc +! fsat = rstar*(zcin*zcin) * [taub_src / SN * [ rstar3*rho/rho_src *N_src/N] = fden_bn ] + + if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] +! +! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc +! + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) + + if (ener_norm == 1) then + +! spectral saturation limit + + if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) + +! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc + + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) +! + endif +!---------------------------------------------------------------------------- +! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw +! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +!---------------------------------------------------------------------------- + zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa + if(zdep > 0.0 ) then +! subs on sat-limit + ze1 = flux(inc,iaz) + flux(inc,iaz) = fluxs + ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs + ! here we can add extra-dissip for the next layer + else +! assign dis-ve flux + flux(inc,iaz) = fdis + endif + + dtau = flux_m(inc,iaz)-flux(inc,iaz) + if (dtau .lt. 0) then + flux(inc,iaz) = flux_m(inc,iaz) + endif +! +! GW-sponge domain: saturate all "GW"-modes above "zsp_gw" +! + if ( azmeti(jkp) .ge. zsp_gw) then + mi_sponge = .5/dz_meti(jk) + ze2 = v_wdp /v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] + v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc +! + ze1 = v_kzi*v_zmet(jk) + exp_sponge = exp(-ze1) +! +! additional sponge +! + flux(inc,iaz) = flux(inc,iaz) *exp_sponge + endif + + endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then + endif ! only for waves w/o CL-absorption wave_act=1 +! +! sum for given (jk, iaz) all active "wave" contributions +! + if (wave_act(inc,iaz) == 1) then + + zcinc =zdci(inc) + vc_zflx_mode = flux(inc,iaz) + vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) + if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) + ze1 = vc_zflx_mode*zcinc + fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at + sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! (heat deposition integration over spectral mode for each azimuth +! later sum over selected azimuths as "non-negative" scalars) +! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! zdelp = wrk3(jk)*cdf1 *zcinc + + zdelp = wrk3(jk)* v_cdp *zcinc * vmdiff + + +! zcool = 1. ! COOL=(-3.5 + Pr)/Pr +! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp +! edis = (c-u)*ax/cp = Kv_dis*N2/cp +! cool = -Kt*N2/R +! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] +! + dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 + dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 + endif !wave_act(inc,iaz) == 1) +! + enddo ! wave-inc-loop + + ze1 =fpu(iaz, jk) + if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 +! +! compute wind and temp-re rms +! + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + do inc=1, nwav + if (wave_act(inc,iaz) > 0.) then + v_kzw =akzw(inc, iaz, jk) + ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) + pwrms = pwrms + ze1 + ptrms = ptrms + ze1*wrk2(jk) + endif + enddo + Awrms(iaz, jk) = pwrms + Atrms(iaz, jk) = ptrms + endif + +! -------------- + enddo ! end Azimuth do-loop + +! +! eddy wave dissipation to limit GW-rms +! + tx1 = sum(abs(dfdz_heat(1:nazd, jk)))/bn2(jk) + ze1=max(dked_min, tx1) + ze2=min(dked_max, ze1) + vueff(jkp) = ze2 + vueff(jkp) +! + enddo ! end Vertical do-loop +! +! top-layers constant interface-fluxes and zero-heat +! we allow non-zero momentum fluxes and thermal effects +! fpu(1:nazd,levs+1) = fpu(1:nazd, levs) +! dfdz_v(1:nazd, levs) = 0.0 + +! --------------------------------------------------------------------- +! sum contribution for total zonal and meridional fluxes + +! energy dissipation +! --------------------------------------------------- +! +!======================================================================== +! at the source level and below taux = 0 (taux_E=-taux_W by assumption) +!======================================================================== + + do jk=ksrc, levs + taux(jk) = 0.0 + tauy(jk) = 0.0 + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + pdtdt(jl,jk) = pdtdt(jl,jk) + dfdz_v(iaz,jk) + dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) + enddo + enddo + jk = ktop; taux(jk)=0.; tauy(jk)=0. + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + enddo + + if (idebug_gwrms == 1) then + do jk=kp1, levs + do iaz=1,nazd + wrms(jl,jk) =wrms(jl,jk) + Awrms(iaz,jk) + trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) + tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) + enddo + enddo + endif +! + + do jk=ksrc+1,levs + jkp = jk + 1 + zdelp = wrk3(jk)*gw_eff + ze1 = (taux(jkp)-taux(jk))* zdelp + ze2 = (tauy(jkp)-tauy(jk))* zdelp + + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif + + pdudt(jl,jk) = -ze1 + pdvdt(jl,jk) = -ze2 +! +! Cx =0 based Cx=/= 0. above +! +! + if (knob_ugwp_doheat == 1) then +! +!maxdtdt= dked_max * bnfix2 +! + pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff + ze2 = pdtdt(jl,jk) + if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) + + dked(jl,jk) = dked(jl,jk)/bn2(jk) + ze1 = max(dked_min, dked(jl,jk)) + dked(jl,jk) = min(dked_max, ze1) + qmid(jk) = pdtdt(j,jk) + endif + enddo +!---------------------------------------------------------------------------------- +! Update heat = ek_diss/cp and aply 1-2-1 smoother for "dked" => dktur +! here with "u_new = u +dtp*dudt ; vnew = v + v +dtp*dvdt +! can check "stability" in the column and "add" ktur-estimation +! to suppress instability as needed so dked = dked_gw + ktur_ric +!---------------------------------------------------------------------------------- + + dktur(1:levs) = dked(jl,1:levs) +! + do ist= 1, nstdif + do jk=ksrc,levs-1 + adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) + enddo + dktur(ksrc:levs-1) = adif(ksrc:levs-1) + enddo + dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) + dktur(levs+1) = dktur(levs) + + do jk=ksrc,levs+1 + ze1 = .5*( dktur(jk) +dktur(jk-1) ) + kvint(jk) = ze1 + ktint(jk) = ze1*iPr_ktgw + enddo + +! +! Thermal budget qmid = qheat + qcool +! + do jk=ksrc+1,levs + ze2 = qmid(jk) + dktur(jk)*Akt(jk) + grav*(ktint(jk+1)-ktint(jk))/dz_meti(jk) + qmid(jk) = ze2 + if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) + pdtdt(jl,jk) = qmid(jk)*rcpd + dked(jl, jk) = dktur(jk) + enddo +! +! perform explicit eddy "diffusive" 3-point smoothing of "u-v-t" +! from the surface/launch-gw to the "top" +! +! +! update by source function X(t+dt) = X(t) + dtp * dXdt +! + uold(km2:levs) = aum(km2:levs)+pdudt(jl,km2:levs)*dtp + vold(km2:levs) = avm(km2:levs)+pdvdt(jl,km2:levs)*dtp + told(km2:levs) = atm(km2:levs)+pdtdt(jl,km2:levs)*dtp +! +! diagnose turb-profile using "stability-check" relying on the free-atm diffusion +! sc2 = 30m x 30m +! + dktur(km2:levs) = dked_min + + do jk=km1,levs + uz = uold(jk) - uold(jk-1) + vz = vold(jk) - vold(jk-1) + ze1 = dz_met(jk) + zdelm = 1./ze1 + + tvc = told(jk) * (1. +fv*aqm(jk)) + tvm = told(jk-1) * (1. +fv*aqm(jk-1)) + zthm = 2.0 / (tvc+tvm) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + + bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) + + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + w1 = 1./(1. + 5*ritur) + ze2 = min( sc2 *zgrow, 4.*ze1*ze1) +! +! Smag-type of eddy diffusion K_smag = Sqrt(Deformation - N2/Pr)* L2 *const +! + kamp = sqrt(shr2)* ze2 * w1 * w1 + ktur= min(max(kamp, dked_min), dked_max) + dktur(jk) = ktur +! +! update of dked = dked_gw + k_turb_mf +! + dked(jl, jk) = dked(jl, jk) +ktur + + enddo + +! +! apply eddy effects due to GWs: explicit scheme Kzz*dt/dz2 < 0.5 stability +! + if (knob_ugwp_dokdis == 2) then + + do jk=ksrc,levs + ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) + kvint(jk) = kvint(jk) + ze1 +! ktint(jk) = ktint(jk) + ze1*iPr_ktgw + enddo + kvint(km1) = kvint(ksrc) + kvint(ktop) = kvint(levs) + + dzmetm = 1./dz_met(km1) + Adif(km1:levs) = 0. + Cdif(km1:levs) = 0. + do jk=km1,levs-1 + + dzmetp = 1./dz_met(jk+1) + dzmetf = 1./(dz_meti(jk)*rhomid(jk)) + + + ktur = kvint(jk) *rhoint(jk) * dzmetf + kturp =Kvint(jk+1)*rhoint(jk+1) * dzmetf + + Adif(jk) = ktur * dzmetm + Cdif(jk) = kturp * dzmetp + ApC = adif(jk)+cdif(jk) + ACdif(jk) = ApC + + w1 = ApC*iPr_max + if (rdtp < w1 ) then + Anstab(jk) = floor(w1*dtp) + 1 + else + Anstab(jk) = 1 + endif + dzmetm = dzmetp + enddo + + nstab = maxval( Anstab(ksrc:levs-1)) + +! if (nstab .ge. 3) print *, 'nstab ', nstab +! +! k instead Jk +! + dtdif = dtp/real(nstab) + ze1 = 1./dtdif + + do ist= 1, nstab + do k=ksrc,levs-1 + Bdif = ze1 - ACdif(k) + Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 + unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) + vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) + tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw + enddo + + uold(ksrc:levs-1) = unew(ksrc:levs-1)*dtdif ! value du/dtp *dtp = du + vold(ksrc:levs-1) = vnew(ksrc:levs-1)*dtdif + told(ksrc:levs-1) = tnew(ksrc:levs-1)*dtdif +! +! smoothing the boundary points: "k-1" = ksrc-1 and "k+1" = levs +! + uold(levs) = uold(levs-1) + vold(levs) = vold(levs-1) + told(levs) = told(levs-1) + enddo +! +! compute "smoothed" tendencies by molecular + GW-eddy diffusions +! + do k=ksrc,levs-1 +! +! final updates of tendencies and diffusion +! + ze2 = rdtp*(uold(k) - aum(k)) + ze1 = rdtp*(vold(k) - avm(k)) + pdtdt(jl,k)= rdtp*( told(k) - atm(k) ) + + if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif + + pdudt(jl, k) = ze2 + pdvdt(jl, k) = ze1 + uz = uold(k+1) - uold(k-1) + vz = vold(k+1) - vold(k-1) + ze2 = 1./(dz_met(k+1)+dz_met(k) ) + mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat + pdtdt(jl,k)= pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity + + enddo + + + ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t + + enddo ! J-loop +! + RETURN + +!================================= diag print after "return" ====================== + if (kdt ==1 .and. mpi_id == master) then +! + print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' + print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) + print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) +! print *, 'ugwpv1: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min + + print * + + endif + + if (kdt == 1 .and. mpi_id == master) then + print *, 'vgw done nstab ', nstab +! + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' + print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' +! +! print *, ' ugwp -heating rates ' + endif +!================================= + return + end subroutine cires_ugwpv1_ngw_solv2 + + +end module cires_ugwpv1_solv2 From 5f323e2dc4d2d4881f727b752dcdd47438b4ba45 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 27 Aug 2021 00:05:48 +0000 Subject: [PATCH 04/36] commit double couning of cloud diagnostic arrays in rrtmgp --- physics/GFS_rrtmgp_lw_post.F90 | 72 +++++++++++++------------- physics/GFS_rrtmgp_sw_post.F90 | 92 ++++++++++++++++++---------------- 2 files changed, 84 insertions(+), 80 deletions(-) diff --git a/physics/GFS_rrtmgp_lw_post.F90 b/physics/GFS_rrtmgp_lw_post.F90 index ff0346fe4..2e30fdbd0 100644 --- a/physics/GFS_rrtmgp_lw_post.F90 +++ b/physics/GFS_rrtmgp_lw_post.F90 @@ -1,4 +1,4 @@ -module GFS_rrtmgp_lw_post +module GFS_rrtmgp_lw_post use machine, only: kind_phys use module_radiation_aerosols, only: NSPC1 use module_radlw_parameters, only: topflw_type, sfcflw_type, proflw_type @@ -6,9 +6,9 @@ module GFS_rrtmgp_lw_post use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_fluxes_byband, only: ty_fluxes_byband use mo_heating_rates, only: compute_heating_rate - use radiation_tools, only: check_error_msg + use radiation_tools, only: check_error_msg implicit none - + public GFS_rrtmgp_lw_post_init,GFS_rrtmgp_lw_post_run,GFS_rrtmgp_lw_post_finalize contains @@ -29,16 +29,16 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag fluxlwDOWN_clrsky, raddt, aerodp, cldsa, mtopa, mbota, cld_frac, cldtaulw, fluxr, & sfcdlw, sfculw, sfcflw, tsflw, htrlw, topflw, flxprf_lw, htrlwc, errmsg, errflg) - ! Inputs - integer, intent(in) :: & + ! Inputs + integer, intent(in) :: & nCol, & ! Horizontal loop extent nLev ! Number of vertical layers - logical, intent(in) :: & + logical, intent(in) :: & lslwr, & ! Logical flags for lw radiation calls - do_lw_clrsky_hr, & ! Output clear-sky SW heating-rate? - save_diag ! Output radiation diagnostics? + do_lw_clrsky_hr, & ! Output clear-sky SW heating-rate? + save_diag ! Output radiation diagnostics? real(kind_phys), intent(in) :: & - fhlwr ! Frequency for SW radiation + fhlwr ! Frequency for SW radiation real(kind_phys), dimension(nCol), intent(in) :: & tsfa ! Lowest model layer air temperature for radiation (K) real(kind_phys), dimension(nCol, nLev), intent(in) :: & @@ -52,25 +52,25 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag real(kind_phys), intent(in) :: & raddt ! Radiation time step real(kind_phys), dimension(nCol,NSPC1), intent(in) :: & - aerodp ! Vertical integrated optical depth for various aerosol species + aerodp ! Vertical integrated optical depth for various aerosol species real(kind_phys), dimension(nCol,5), intent(in) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL + cldsa ! Fraction of clouds for low, middle, high, total and BL integer, dimension(nCol,3), intent(in) ::& mbota, & ! vertical indices for low, middle and high cloud tops mtopa ! vertical indices for low, middle and high cloud bases real(kind_phys), dimension(nCol,nLev), intent(in) :: & cld_frac, & ! Total cloud fraction in each layer - cldtaulw ! approx 10.mu band layer cloud optical depth - + cldtaulw ! approx 10.mu band layer cloud optical depth + real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr - + ! Outputs (mandatory) real(kind_phys), dimension(nCol), intent(inout) :: & sfcdlw, & ! Total sky sfc downward lw flux (W/m2) sfculw, & ! Total sky sfc upward lw flux (W/m2) tsflw ! surface air temp during lw calculation (K) type(sfcflw_type), dimension(nCol), intent(inout) :: & - sfcflw ! LW radiation fluxes at sfc + sfcflw ! LW radiation fluxes at sfc real(kind_phys), dimension(nCol,nLev), intent(inout) :: & htrlw ! LW all-sky heating rate type(topflw_type), dimension(nCol), intent(out) :: & @@ -79,7 +79,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag errmsg integer, intent(out) :: & errflg - + ! Outputs (optional) type(proflw_type), dimension(nCol, nLev+1), optional, intent(inout) :: & flxprf_lw ! 2D radiative fluxes, components: @@ -89,7 +89,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag ! dnfx0 - clear sky dnward flux (W/m2) real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & htrlwc ! Longwave clear-sky heating-rate (K/sec) - + ! Local variables integer :: i, j, k, iSFC, iTOA, itop, ibtc logical :: l_fluxeslw2d, top_at_1 @@ -118,7 +118,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag endif ! ####################################################################################### - ! Compute LW heating-rates. + ! Compute LW heating-rates. ! ####################################################################################### ! Clear-sky heating-rate (optional) if (do_lw_clrsky_hr) then @@ -128,7 +128,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag p_lev, & ! IN - Pressure @ layer-interfaces (Pa) htrlwc)) ! OUT - Longwave clear-sky heating rate (K/sec) endif - + ! All-sky heating-rate (mandatory) call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & fluxlwUP_allsky, & ! IN - RRTMGP upward longwave all-sky flux profiles (W/m2) @@ -147,7 +147,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag sfcflw(:)%upfx0 = fluxlwUP_clrsky(:,iSFC) sfcflw(:)%dnfxc = fluxlwDOWN_allsky(:,iSFC) sfcflw(:)%dnfx0 = fluxlwDOWN_clrsky(:,iSFC) - + ! Optional outputs if(l_fluxeslw2d) then flxprf_lw%upfxc = fluxlwUP_allsky @@ -155,7 +155,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag flxprf_lw%upfx0 = fluxlwUP_clrsky flxprf_lw%dnfx0 = fluxlwDOWN_clrsky endif - + ! Save surface air temp for diurnal adjustment at model t-steps tsflw (:) = tsfa(:) @@ -165,8 +165,8 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag ! ####################################################################################### ! Save LW diagnostics - ! - For time averaged output quantities (including total-sky and clear-sky SW and LW - ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base + ! - For time averaged output quantities (including total-sky and clear-sky SW and LW + ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base ! pressure, and cloud top temperature; aerosols AOD, etc.), store computed results in ! corresponding slots of array fluxr with appropriate time weights. ! - Collect the fluxr data for wrtsfc @@ -182,24 +182,24 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag fluxr(i,30) = fluxr(i,30) + fhlwr * fluxlwDOWN_clrsky(i,iSFC) ! clear sky sfc lw dn fluxr(i,33) = fluxr(i,33) + fhlwr * fluxlwUP_clrsky( i,iSFC) ! clear sky sfc lw up enddo - - do i=1,nCol - fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) - fluxr(i,18) = fluxr(i,18) + raddt * cldsa(i,5) - enddo + +! do i=1,nCol +! fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) +! fluxr(i,18) = fluxr(i,18) + raddt * cldsa(i,5) +! enddo ! Save cld frac,toplyr,botlyr and top temp, note that the order of h,m,l cloud is reversed for ! the fluxr output. save interface pressure (pa) of top/bot do j = 1, 3 do i = 1, nCol - tem0d = raddt * cldsa(i,j) - itop = mtopa(i,j) - ibtc = mbota(i,j) - fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d - fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop) - fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc) - fluxr(i,17-j) = fluxr(i,17-j) + tem0d * t_lay(i,itop) - +! tem0d = raddt * cldsa(i,j) +! itop = mtopa(i,j) +! ibtc = mbota(i,j) +! fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d +! fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop) +! fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc) +! fluxr(i,17-j) = fluxr(i,17-j) + tem0d * t_lay(i,itop) + ! Add optical depth and emissivity output tem2 = 0. do k=ibtc,itop diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 index 23a681826..d8514650a 100644 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ b/physics/GFS_rrtmgp_sw_post.F90 @@ -1,14 +1,14 @@ -module GFS_rrtmgp_sw_post +module GFS_rrtmgp_sw_post use machine, only: kind_phys use module_radiation_aerosols, only: NSPC1 use module_radsw_parameters, only: topfsw_type, sfcfsw_type, profsw_type, cmpfsw_type use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_fluxes_byband, only: ty_fluxes_byband use mo_heating_rates, only: compute_heating_rate - use radiation_tools, only: check_error_msg + use radiation_tools, only: check_error_msg use rrtmgp_sw_gas_optics, only: sw_gas_props implicit none - + public GFS_rrtmgp_sw_post_init,GFS_rrtmgp_sw_post_run,GFS_rrtmgp_sw_post_finalize contains @@ -33,23 +33,23 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky nirbmdi, nirdfdi, visbmdi, visdfdi, nirbmui, nirdfui, visbmui, visdfui, sfcnsw, & sfcdsw, htrsw, sfcfsw, topfsw, htrswc, flxprf_sw, scmpsw, errmsg, errflg) - ! Inputs - integer, intent(in) :: & - nCol, & ! Horizontal loop extent + ! Inputs + integer, intent(in) :: & + nCol, & ! Horizontal loop extent nLev, & ! Number of vertical layers nDay ! Number of daylit columns integer, intent(in), dimension(nday) :: & idxday ! Index array for daytime points - logical, intent(in) :: & - lsswr, & ! Call SW radiation? - do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? - save_diag ! Output radiation diagnostics? + logical, intent(in) :: & + lsswr, & ! Call SW radiation? + do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? + save_diag ! Output radiation diagnostics? real(kind_phys), intent(in) :: & fhswr ! Frequency for SW radiation real(kind_phys), dimension(nCol), intent(in) :: & t_lay, & ! Temperature at model layer centers (K) - coszen, & ! Cosine(SZA) - coszdg ! Cosine(SZA), daytime + coszen, & ! Cosine(SZA) + coszdg ! Cosine(SZA), daytime real(kind_phys), dimension(nCol, nLev+1), intent(in) :: & p_lev ! Pressure @ model layer-interfaces (Pa) real(kind_phys), dimension(sw_gas_props%get_nband(),ncol), intent(in) :: & @@ -65,17 +65,17 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky real(kind_phys), intent(in) :: & raddt ! Radiation time step real(kind_phys), dimension(nCol,NSPC1), intent(in) :: & - aerodp ! Vertical integrated optical depth for various aerosol species + aerodp ! Vertical integrated optical depth for various aerosol species real(kind_phys), dimension(nCol,5), intent(in) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL + cldsa ! Fraction of clouds for low, middle, high, total and BL integer, dimension(nCol,3), intent(in) ::& mbota, & ! vertical indices for low, middle and high cloud tops mtopa ! vertical indices for low, middle and high cloud bases real(kind_phys), dimension(nCol,nLev), intent(in) :: & cld_frac, & ! Total cloud fraction in each layer cldtausw ! approx .55mu band layer cloud optical depth - - ! Inputs (optional) + + ! Inputs (optional) type(cmpfsw_type), dimension(nCol), intent(inout), optional :: & scmpsw ! 2D surface fluxes, components: ! uvbfc - total sky downward uv-b flux at (W/m2) @@ -83,10 +83,10 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! nirbm - downward nir direct beam flux (W/m2) ! nirdf - downward nir diffused flux (W/m2) ! visbm - downward uv+vis direct beam flux (W/m2) - ! visdf - downward uv+vis diffused flux (W/m2) - + ! visdf - downward uv+vis diffused flux (W/m2) + real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr - + ! Outputs (mandatory) real(kind_phys), dimension(nCol), intent(inout) :: & nirbmdi, & ! sfc nir beam sw downward flux (W/m2) @@ -96,7 +96,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky nirbmui, & ! sfc nir beam sw upward flux (W/m2) nirdfui, & ! sfc nir diff sw upward flux (W/m2) visbmui, & ! sfc uv+vis beam sw upward flux (W/m2) - visdfui, & ! sfc uv+vis diff sw upward flux (W/m2) + visdfui, & ! sfc uv+vis diff sw upward flux (W/m2) sfcnsw, & ! total sky sfc netsw flx into ground sfcdsw ! real(kind_phys), dimension(nCol,nLev), intent(inout) :: & @@ -119,7 +119,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! dnfx0 - clear sky dnward flux (W/m2) real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & htrswc ! Clear-sky heating rate (K/s) - + ! Local variables integer :: i, j, k, iSFC, iTOA, itop, ibtc real(kind_phys) :: tem0d, tem1, tem2 @@ -135,7 +135,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! Are any optional outputs requested? l_fluxessw2d = present(flxprf_sw) - + ! Are the components of the surface fluxes provided? l_scmpsw = present(scmpsw) @@ -150,7 +150,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky iSFC = 1 iTOA = nLev+1 endif - + ! ####################################################################################### ! Compute SW heating-rates ! ####################################################################################### @@ -194,10 +194,10 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky flxprf_sw(:,:)%upfx0 = fluxswUP_clrsky(:,:) flxprf_sw(:,:)%dnfx0 = fluxswDOWN_clrsky(:,:) endif - + ! Surface down and up spectral component fluxes ! - Save two spectral bands' surface downward and upward fluxes for output. - if (l_scmpsw) then + if (l_scmpsw) then do i=1,nCol nirbmdi(i) = scmpsw(i)%nirbm nirdfdi(i) = scmpsw(i)%nirdf @@ -209,15 +209,17 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(1,i) enddo else - nirbmdi(:) = 0.0 - nirdfdi(:) = 0.0 - visbmdi(:) = 0.0 - visdfdi(:) = 0.0 - nirbmui(:) = 0.0 - nirdfui(:) = 0.0 - visbmui(:) = 0.0 - visdfui(:) = 0.0 - endif + do i=1,nCol + nirbmdi(i) = 0.0 + nirdfdi(i) = 0.0 + visbmdi(i) = 0.0 + visdfdi(i) = 0.0 + nirbmui(i) = 0.0 + nirdfui(i) = 0.0 + visbmui(i) = 0.0 + visdfui(i) = 0.0 + enddo + endif else ! if_nday_block ! ####################################################################################### ! Dark everywhere @@ -225,15 +227,17 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky htrsw(:,:) = 0.0 sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) topfsw = topfsw_type( 0.0, 0.0, 0.0 ) - nirbmdi(:) = 0.0 - nirdfdi(:) = 0.0 - visbmdi(:) = 0.0 - visdfdi(:) = 0.0 - nirbmui(:) = 0.0 - nirdfui(:) = 0.0 - visbmui(:) = 0.0 - visdfui(:) = 0.0 - + do i=1,nCol + nirbmdi(i) = 0.0 + nirdfdi(i) = 0.0 + visbmdi(i) = 0.0 + visdfdi(i) = 0.0 + nirbmui(i) = 0.0 + nirdfui(i) = 0.0 + visbmui(i) = 0.0 + visdfui(i) = 0.0 + enddo + if (do_sw_clrsky_hr) then htrswc(:,:) = 0 endif @@ -279,7 +283,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky fluxr(i,27) = fluxr(i,27) + nirdfdi(i) * tem0d ! nir diff sw dn ! SW clear-sky fluxes fluxr(i,29) = fluxr(i,29) + topfsw(i)%upfx0 * tem0d - fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d + fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d fluxr(i,32) = fluxr(i,32) + sfcfsw(i)%dnfx0 * tem0d endif enddo From 2c6f85a339a818a97d0c1c61b51a73ebf779ffb0 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 16 Sep 2021 11:22:20 +0000 Subject: [PATCH 05/36] removing interstitial land and ice emissivities --- physics/GFS_surface_composites.F90 | 29 ++++++++++++---------- physics/GFS_surface_composites.meta | 37 ++++------------------------- physics/dcyc2.meta | 8 +++---- physics/radiation_surface.f | 2 +- physics/sfc_drv.meta | 6 ++--- physics/sfc_noah_wrfv4.meta | 6 ++--- physics/sfc_sice.meta | 4 ++-- 7 files changed, 34 insertions(+), 58 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 966393d03..4880d67c7 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -34,8 +34,10 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & weasd, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & tsfc_ice, tisfc, tsurf_wat, tsurf_lnd, tsurf_ice, & - gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & - emis_lnd, emis_ice, qss, qss_wat, qss_lnd, qss_ice, & + gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_wat, semis_lnd, semis_ice, & +! gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & + qss, qss_wat, qss_lnd, qss_ice, & +! emis_lnd, emis_ice, qss, qss_wat, qss_lnd, qss_ice, & min_lakeice, min_seaice, kdt, errmsg, errflg) implicit none @@ -58,9 +60,9 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm qss_wat, qss_lnd, qss_ice, ep1d_ice, gflx_ice real(kind=kind_phys), intent(in ) :: tgice integer, dimension(:), intent(inout) :: islmsk, islmsk_cice - real(kind=kind_phys), dimension(:), intent(in ) :: semis_rad +! real(kind=kind_phys), dimension(:), intent(in ) :: semis_rad real(kind=kind_phys), dimension(:), intent(inout) :: semis_wat, semis_lnd, semis_ice, slmsk - real(kind=kind_phys), dimension(:), intent(inout) :: emis_lnd, emis_ice +! real(kind=kind_phys), dimension(:), intent(inout) :: emis_lnd, emis_ice real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice ! real(kind=kind_phys), dimension(:), intent(inout) :: zorlo, zorll, zorli @@ -229,12 +231,12 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm uustar_lnd(i) = uustar(i) weasd_lnd(i) = weasd(i) tsurf_lnd(i) = tsfcl(i) - if (iemsflg == 2 .and. .not. flag_init) then - !-- use land emissivity from the LSM - semis_lnd(i) = emis_lnd(i) - else - semis_lnd(i) = semis_rad(i) - endif +! if (iemsflg == 2 .and. .not. flag_init) then +! !-- use land emissivity from the LSM +! semis_lnd(i) = emis_lnd(i) +! else +! semis_lnd(i) = semis_rad(i) +! endif ! DH* else zorll(i) = huge @@ -249,10 +251,11 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm tsurf_ice(i) = tisfc(i) ep1d_ice(i) = zero gflx_ice(i) = zero - if (iemsflg == 2 .and. (.not.flag_init .or. flag_restart) .and. lsm == lsm_ruc) then +! if (iemsflg == 2 .and. (.not.flag_init .or. flag_restart) .and. lsm == lsm_ruc) then !-- use emis_ice from RUC LSM with snow effect - semis_ice(i) = emis_ice(i) - else +! semis_ice(i) = emis_ice(i) +! else + if (lsm /= lsm_ruc) then semis_ice(i) = 0.95_kind_phys endif ! DH* diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index aea0561a8..beba92ae5 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -492,15 +492,6 @@ kind = kind_phys intent = inout optional = F -[semis_rad] - standard_name = surface_longwave_emissivity - long_name = surface lw emissivity in fraction - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [semis_wat] standard_name = surface_longwave_emissivity_over_water long_name = surface lw emissivity in fraction over water @@ -511,24 +502,6 @@ intent = inout optional = F [semis_lnd] - standard_name = surface_longwave_emissivity_over_land_interstitial - long_name = surface lw emissivity in fraction over land (temporary use as interstitial) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[semis_ice] - standard_name = surface_longwave_emissivity_over_ice_interstitial - long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[emis_lnd] standard_name = surface_longwave_emissivity_over_land long_name = surface lw emissivity in fraction over land units = frac @@ -537,7 +510,7 @@ kind = kind_phys intent = inout optional = F -[emis_ice] +[semis_ice] standard_name = surface_longwave_emissivity_over_ice long_name = surface lw emissivity in fraction over ice units = frac @@ -678,8 +651,8 @@ intent = in optional = F [semis_lnd] - standard_name = surface_longwave_emissivity_over_land_interstitial - long_name = surface lw emissivity in fraction over land (temporary use as interstitial) + standard_name = surface_longwave_emissivity_over_land + long_name = surface lw emissivity in fraction over land units = frac dimensions = (horizontal_loop_extent) type = real @@ -687,8 +660,8 @@ intent = in optional = F [semis_ice] - standard_name = surface_longwave_emissivity_over_ice_interstitial - long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) + standard_name = surface_longwave_emissivity_over_ice + long_name = surface lw emissivity in fraction over ice units = frac dimensions = (horizontal_loop_extent) type = real diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index 70886e986..0b26d0e53 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -170,8 +170,8 @@ intent = in optional = F [sfcemis_lnd] - standard_name = surface_longwave_emissivity_over_land_interstitial - long_name = surface lw emissivity in fraction over land (temporary use as interstitial) + standard_name = surface_longwave_emissivity_over_land + long_name = surface lw emissivity in fraction over land units = frac dimensions = (horizontal_loop_extent) type = real @@ -179,8 +179,8 @@ intent = in optional = F [sfcemis_ice] - standard_name = surface_longwave_emissivity_over_ice_interstitial - long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) + standard_name = surface_longwave_emissivity_over_ice + long_name = surface lw emissivity in fraction over ice units = frac dimensions = (horizontal_loop_extent) type = real diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 750c54dd6..4b4e92722 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -876,7 +876,7 @@ subroutine setemis & sfcemis(i) = emsref(idx) else sfcemis(i) = fracl(i)*emsref(idx) + fraco(i)*emsref(1) & - & + fraci(i)*emsref(7) + & + fraci(i)*emsref(7) endif semisbase(i) = sfcemis(i) diff --git a/physics/sfc_drv.meta b/physics/sfc_drv.meta index 08ec02be7..11a5aa293 100644 --- a/physics/sfc_drv.meta +++ b/physics/sfc_drv.meta @@ -247,8 +247,8 @@ intent = in optional = F [sfcemis] - standard_name = surface_longwave_emissivity_over_land_interstitial - long_name = surface lw emissivity in fraction over land (temporary use as interstitial) + standard_name = surface_longwave_emissivity_over_land + long_name = surface lw emissivity in fraction over land units = frac dimensions = (horizontal_loop_extent) type = real @@ -646,7 +646,7 @@ optional = F [zorl] standard_name = surface_roughness_length_over_land - long_name = surface roughness length over land (temporary use as interstitial) + long_name = surface roughness length over land units = cm dimensions = (horizontal_loop_extent) type = real diff --git a/physics/sfc_noah_wrfv4.meta b/physics/sfc_noah_wrfv4.meta index e0f2538f6..23415695c 100644 --- a/physics/sfc_noah_wrfv4.meta +++ b/physics/sfc_noah_wrfv4.meta @@ -403,7 +403,7 @@ optional = F [z0k] standard_name = surface_roughness_length_over_land - long_name = surface roughness length over land (temporary use as interstitial) + long_name = surface roughness length over land units = m dimensions = (horizontal_loop_extent) type = real @@ -411,8 +411,8 @@ intent = inout optional = F [emissi] - standard_name = surface_longwave_emissivity_over_land_interstitial - long_name = surface lw emissivity in fraction over land (temporary use as interstitial) + standard_name = surface_longwave_emissivity_over_land + long_name = surface lw emissivity in fraction over land units = frac dimensions = (horizontal_loop_extent) type = real diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index 7d45e7f24..de0e41de0 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -150,8 +150,8 @@ intent = in optional = F [sfcemis] - standard_name = surface_longwave_emissivity_over_ice_interstitial - long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) + standard_name = surface_longwave_emissivity_over_ice + long_name = surface lw emissivity in fraction over ice units = frac dimensions = (horizontal_loop_extent) type = real From 12d85af52c95ed36e52d91a5f9549e80a4a8d8cb Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 17 Sep 2021 17:53:38 +0000 Subject: [PATCH 06/36] improing treatment of emissivity and remove related unnecessary interstitial variables --- physics/GFS_radiation_surface.F90 | 12 +++++--- physics/GFS_surface_composites.F90 | 17 ----------- physics/radiation_surface.f | 49 ++++++++++++++++++++++++------ 3 files changed, 46 insertions(+), 32 deletions(-) diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index 11703c23c..65cfe1858 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -80,21 +80,23 @@ subroutine GFS_radiation_surface_run ( & real(kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, vtype, slmsk, & sfc_alb_pert, lndp_prt_list, & - landfrac, lakefrac, & + landfrac, lakefrac, & snowd, sncovr, & sncovr_ice, fice, zorl, & hprime, tsfg, tsfa, tisfc, & coszen, alvsf, alnsf, alvwf, & - alnwf, facsf, facwf, & - semis_lnd, semis_ice, snoalb + alnwf, facsf, facwf, snoalb character(len=3) , dimension(:), intent(in) :: lndp_var_list - real(kind=kind_phys), dimension(:), intent(inout) :: albdvis_lnd, albdnir_lnd, & - albivis_lnd, albinir_lnd real(kind=kind_phys), dimension(:), intent(in) :: albdvis_ice, albdnir_ice, & albivis_ice, albinir_ice + + real(kind=kind_phys), dimension(:), intent(inout) :: albdvis_lnd, albdnir_lnd, & + albivis_lnd, albinir_lnd, & + semis_lnd, semis_ice real(kind=kind_phys), dimension(:), intent(inout) :: semisbase, semis real(kind=kind_phys), dimension(:,:), intent(inout) :: sfcalb real(kind=kind_phys), dimension(:), intent(inout) :: sfc_alb_dif + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 4880d67c7..4a63aa7f5 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -35,9 +35,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm weasd, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & tsfc_ice, tisfc, tsurf_wat, tsurf_lnd, tsurf_ice, & gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_wat, semis_lnd, semis_ice, & -! gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & qss, qss_wat, qss_lnd, qss_ice, & -! emis_lnd, emis_ice, qss, qss_wat, qss_lnd, qss_ice, & min_lakeice, min_seaice, kdt, errmsg, errflg) implicit none @@ -60,9 +58,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm qss_wat, qss_lnd, qss_ice, ep1d_ice, gflx_ice real(kind=kind_phys), intent(in ) :: tgice integer, dimension(:), intent(inout) :: islmsk, islmsk_cice -! real(kind=kind_phys), dimension(:), intent(in ) :: semis_rad real(kind=kind_phys), dimension(:), intent(inout) :: semis_wat, semis_lnd, semis_ice, slmsk -! real(kind=kind_phys), dimension(:), intent(inout) :: emis_lnd, emis_ice real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice ! real(kind=kind_phys), dimension(:), intent(inout) :: zorlo, zorll, zorli @@ -231,12 +227,6 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm uustar_lnd(i) = uustar(i) weasd_lnd(i) = weasd(i) tsurf_lnd(i) = tsfcl(i) -! if (iemsflg == 2 .and. .not. flag_init) then -! !-- use land emissivity from the LSM -! semis_lnd(i) = emis_lnd(i) -! else -! semis_lnd(i) = semis_rad(i) -! endif ! DH* else zorll(i) = huge @@ -251,13 +241,6 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm tsurf_ice(i) = tisfc(i) ep1d_ice(i) = zero gflx_ice(i) = zero -! if (iemsflg == 2 .and. (.not.flag_init .or. flag_restart) .and. lsm == lsm_ruc) then - !-- use emis_ice from RUC LSM with snow effect -! semis_ice(i) = emis_ice(i) -! else - if (lsm /= lsm_ruc) then - semis_ice(i) = 0.95_kind_phys - endif ! DH* else zorli(i) = huge diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 4b4e92722..2d0940faf 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -334,8 +334,7 @@ end subroutine sfc_init subroutine setalb & & ( slmsk,lsm,lsm_noahmp,lsm_ruc,use_cice_alb,snowf, & ! --- inputs: & sncovr,sncovr_ice,snoalb,zorlf,coszf, & - & tsknf,tairf,hprif,frac_grid, lakefrac, & -! & tsknf,tairf,hprif,frac_grid,min_seaice, & + & tsknf,tairf,hprif,frac_grid, lakefrac, & & alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc, & & lsmalbdvis, lsmalbdnir, lsmalbivis, lsmalbinir, & & icealbdvis, icealbdnir, icealbivis, icealbinir, & @@ -416,7 +415,6 @@ subroutine setalb & & icealbdvis, icealbdnir, icealbivis, icealbinir, & & sncovr, sncovr_ice, snoalb, albPpert ! sfc-perts, mgehne real (kind=kind_phys), intent(in) :: pertalb ! sfc-perts, mgehne -! real (kind=kind_phys), intent(in) :: min_seaice real (kind=kind_phys), dimension(:), intent(in) :: & & fracl, fraco, fraci real (kind=kind_phys), dimension(:),intent(inout) :: & @@ -728,7 +726,6 @@ end subroutine setalb subroutine setemis & & ( lsm,lsm_noahmp,lsm_ruc,vtype,frac_grid, & ! --- inputs: & xlon,xlat,slmsk,snowf,sncovr,sncovr_ice, & -! & min_seaice,xlon,xlat,slmsk,snowf,sncovr,sncovr_ice, & & zorlf,tsknf,tairf,hprif, & & semis_lnd,semis_ice,IMAX,fracl,fraco,fraci,icy, & & semisbase, sfcemis & ! --- outputs: @@ -785,13 +782,14 @@ subroutine setemis & integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc logical, intent(in) :: frac_grid real (kind=kind_phys), dimension(:), intent(in) :: vtype -! real (kind=kind_phys), intent(in) :: min_seaice real (kind=kind_phys), dimension(:), intent(in) :: & & xlon,xlat, slmsk, snowf,sncovr, sncovr_ice, & - & zorlf, tsknf, tairf, hprif, semis_lnd, semis_ice + & zorlf, tsknf, tairf, hprif real (kind=kind_phys), dimension(:), intent(in) :: & & fracl, fraco, fraci + real (kind=kind_phys), dimension(:), intent(inout) :: & + & semis_lnd, semis_ice logical, dimension(:), intent(in) :: & & icy @@ -829,6 +827,7 @@ subroutine setemis & lab_do_IMAX : do i = 1, IMAX + semis_ice(i) = emsref(7) if (fracl(i) < epsln) then ! no land if ( abs(fraco(i)-f_one) < epsln ) then ! open water point sfcemis(i) = emsref(1) @@ -875,10 +874,11 @@ subroutine setemis & if (abs(fracl(i)-f_one) < epsln) then sfcemis(i) = emsref(idx) else - sfcemis(i) = fracl(i)*emsref(idx) + fraco(i)*emsref(1) & + sfcemis(i) = fracl(i)*emsref(idx) + fraco(i)*emsref(1) & & + fraci(i)*emsref(7) endif semisbase(i) = sfcemis(i) + semis_lnd(i) = emsref(idx) endif ! end if_slmsk_block @@ -887,16 +887,39 @@ subroutine setemis & fsno = sncovr(i) sfcemis(i) = sfcemis(i)*(f_one - fsno) + emsref(8)*fsno + if (fracl(i) > f_zero) then + if (fracl(i) <= fsno) then + semis_lnd(i) = emsref(8) + else + tmp1 = (fracl(i)-fsno) / fracl(i) + semis_lnd(i) = semis_lnd(i) * tmp1 + (f_one-tmp1)*fsno + endif + endif + if (fraci(i) > f_zero) then + semis_ice(i) = emsref(8) + endif else ! compute snow cover from snow depth - if ( snowf(i) > f_zero ) then + if (abs(fraco(i)-f_one) > epsln .and. & + & snowf(i) > f_zero) then asnow = 0.02*snowf(i) argh = min(0.50, max(.025, 0.01*zorlf(i))) hrgh = min(f_one, max(0.20, 1.0577-1.1538e-3*hprif(i) ) ) fsno = asnow / (argh + asnow) * hrgh - if (abs(fraco(i)-f_one) < epsln) fsno = f_zero ! no snow over open water sfcemis(i) = sfcemis(i)*(f_one - fsno) + emsref(8)*fsno + + if (fracl(i) > f_zero) then + if (fracl(i) <= fsno) then + semis_lnd(i) = emsref(8) + else + tmp1 = (fracl(i)-fsno) / fracl(i) + semis_lnd(i) = semis_lnd(i)*tmp1 + (f_one-tmp1)*fsno + endif + endif + if (fraci(i) > f_zero) then + semis_ice(i) = emsref(8) + endif endif endif ! end if_ialbflg @@ -918,8 +941,14 @@ subroutine setemis & argh = min(0.50, max(.025,0.01*zorlf(i))) hrgh = min(f_one,max(0.20,1.0577-1.1538e-3*hprif(i))) fsno = asnow / (argh + asnow) * hrgh - sfcemis_ice = sfcemis_ice*(f_one-fsno)+emsref(8)*fsno + if (fraci(i) > fsno) then + tmp1 = (fraci(i) - fsno) / fraci(i) + sfcemis_ice = sfcemis_ice*tmp1+emsref(8)*(f_one-tmp1) + else + sfcemis_ice = emsref(8) + endif endif + semis_ice(i) = sfcemis_ice elseif (lsm == lsm_ruc) then sfcemis_ice = semis_ice(i) ! output from lsm (with snow effect) endif ! lsm check From 2dd3ce46a10c4852d854a1b529147c8402aec854 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 21 Sep 2021 18:56:13 +0000 Subject: [PATCH 07/36] reverting some changes to main version --- physics/GFS_rrtmgp_lw_post.F90 | 99 ++- physics/GFS_rrtmgp_sw_post.F90 | 109 ++- physics/cires_ugwpv1_solv2.F90 | 1033 +++++++++++++------------- physics/cires_ugwpv1_solv2.F90_mine | 1049 --------------------------- physics/cires_ugwpv1_solv2.F90_orig | 1036 -------------------------- 5 files changed, 609 insertions(+), 2717 deletions(-) delete mode 100644 physics/cires_ugwpv1_solv2.F90_mine delete mode 100644 physics/cires_ugwpv1_solv2.F90_orig diff --git a/physics/GFS_rrtmgp_lw_post.F90 b/physics/GFS_rrtmgp_lw_post.F90 index 4bb940547..ff0346fe4 100644 --- a/physics/GFS_rrtmgp_lw_post.F90 +++ b/physics/GFS_rrtmgp_lw_post.F90 @@ -1,4 +1,4 @@ -module GFS_rrtmgp_lw_post +module GFS_rrtmgp_lw_post use machine, only: kind_phys use module_radiation_aerosols, only: NSPC1 use module_radlw_parameters, only: topflw_type, sfcflw_type, proflw_type @@ -6,9 +6,9 @@ module GFS_rrtmgp_lw_post use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_fluxes_byband, only: ty_fluxes_byband use mo_heating_rates, only: compute_heating_rate - use radiation_tools, only: check_error_msg + use radiation_tools, only: check_error_msg implicit none - + public GFS_rrtmgp_lw_post_init,GFS_rrtmgp_lw_post_run,GFS_rrtmgp_lw_post_finalize contains @@ -29,16 +29,16 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag fluxlwDOWN_clrsky, raddt, aerodp, cldsa, mtopa, mbota, cld_frac, cldtaulw, fluxr, & sfcdlw, sfculw, sfcflw, tsflw, htrlw, topflw, flxprf_lw, htrlwc, errmsg, errflg) - ! Inputs - integer, intent(in) :: & + ! Inputs + integer, intent(in) :: & nCol, & ! Horizontal loop extent nLev ! Number of vertical layers - logical, intent(in) :: & + logical, intent(in) :: & lslwr, & ! Logical flags for lw radiation calls - do_lw_clrsky_hr, & ! Output clear-sky SW heating-rate? - save_diag ! Output radiation diagnostics? + do_lw_clrsky_hr, & ! Output clear-sky SW heating-rate? + save_diag ! Output radiation diagnostics? real(kind_phys), intent(in) :: & - fhlwr ! Frequency for SW radiation + fhlwr ! Frequency for SW radiation real(kind_phys), dimension(nCol), intent(in) :: & tsfa ! Lowest model layer air temperature for radiation (K) real(kind_phys), dimension(nCol, nLev), intent(in) :: & @@ -52,25 +52,25 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag real(kind_phys), intent(in) :: & raddt ! Radiation time step real(kind_phys), dimension(nCol,NSPC1), intent(in) :: & - aerodp ! Vertical integrated optical depth for various aerosol species + aerodp ! Vertical integrated optical depth for various aerosol species real(kind_phys), dimension(nCol,5), intent(in) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL + cldsa ! Fraction of clouds for low, middle, high, total and BL integer, dimension(nCol,3), intent(in) ::& mbota, & ! vertical indices for low, middle and high cloud tops mtopa ! vertical indices for low, middle and high cloud bases real(kind_phys), dimension(nCol,nLev), intent(in) :: & cld_frac, & ! Total cloud fraction in each layer - cldtaulw ! approx 10.mu band layer cloud optical depth - + cldtaulw ! approx 10.mu band layer cloud optical depth + real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr - + ! Outputs (mandatory) real(kind_phys), dimension(nCol), intent(inout) :: & sfcdlw, & ! Total sky sfc downward lw flux (W/m2) sfculw, & ! Total sky sfc upward lw flux (W/m2) tsflw ! surface air temp during lw calculation (K) type(sfcflw_type), dimension(nCol), intent(inout) :: & - sfcflw ! LW radiation fluxes at sfc + sfcflw ! LW radiation fluxes at sfc real(kind_phys), dimension(nCol,nLev), intent(inout) :: & htrlw ! LW all-sky heating rate type(topflw_type), dimension(nCol), intent(out) :: & @@ -79,7 +79,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag errmsg integer, intent(out) :: & errflg - + ! Outputs (optional) type(proflw_type), dimension(nCol, nLev+1), optional, intent(inout) :: & flxprf_lw ! 2D radiative fluxes, components: @@ -89,7 +89,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag ! dnfx0 - clear sky dnward flux (W/m2) real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & htrlwc ! Longwave clear-sky heating-rate (K/sec) - + ! Local variables integer :: i, j, k, iSFC, iTOA, itop, ibtc logical :: l_fluxeslw2d, top_at_1 @@ -118,7 +118,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag endif ! ####################################################################################### - ! Compute LW heating-rates. + ! Compute LW heating-rates. ! ####################################################################################### ! Clear-sky heating-rate (optional) if (do_lw_clrsky_hr) then @@ -128,7 +128,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag p_lev, & ! IN - Pressure @ layer-interfaces (Pa) htrlwc)) ! OUT - Longwave clear-sky heating rate (K/sec) endif - + ! All-sky heating-rate (mandatory) call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & fluxlwUP_allsky, & ! IN - RRTMGP upward longwave all-sky flux profiles (W/m2) @@ -140,24 +140,14 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag ! Save LW outputs. ! ####################################################################################### ! Copy fluxes from RRTGMP types into model radiation types. - - do i=1,nCol ! Mandatory outputs - topflw(i)%upfxc = fluxlwUP_allsky(i,iTOA) - topflw(i)%upfx0 = fluxlwUP_clrsky(i,iTOA) - sfcflw(i)%upfxc = fluxlwUP_allsky(i,iSFC) - sfcflw(i)%upfx0 = fluxlwUP_clrsky(i,iSFC) - sfcflw(i)%dnfxc = fluxlwDOWN_allsky(i,iSFC) - sfcflw(i)%dnfx0 = fluxlwDOWN_clrsky(i,iSFC) - - ! Save surface air temp for diurnal adjustment at model t-steps - tsflw (i) = tsfa(i) - - ! Radiation fluxes for other physics processes - sfcdlw(i) = sfcflw(i)%dnfxc - sfculw(i) = sfcflw(i)%upfxc - enddo - + topflw(:)%upfxc = fluxlwUP_allsky(:,iTOA) + topflw(:)%upfx0 = fluxlwUP_clrsky(:,iTOA) + sfcflw(:)%upfxc = fluxlwUP_allsky(:,iSFC) + sfcflw(:)%upfx0 = fluxlwUP_clrsky(:,iSFC) + sfcflw(:)%dnfxc = fluxlwDOWN_allsky(:,iSFC) + sfcflw(:)%dnfx0 = fluxlwDOWN_clrsky(:,iSFC) + ! Optional outputs if(l_fluxeslw2d) then flxprf_lw%upfxc = fluxlwUP_allsky @@ -165,11 +155,18 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag flxprf_lw%upfx0 = fluxlwUP_clrsky flxprf_lw%dnfx0 = fluxlwDOWN_clrsky endif + + ! Save surface air temp for diurnal adjustment at model t-steps + tsflw (:) = tsfa(:) + + ! Radiation fluxes for other physics processes + sfcdlw(:) = sfcflw(:)%dnfxc + sfculw(:) = sfcflw(:)%upfxc ! ####################################################################################### ! Save LW diagnostics - ! - For time averaged output quantities (including total-sky and clear-sky SW and LW - ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base + ! - For time averaged output quantities (including total-sky and clear-sky SW and LW + ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base ! pressure, and cloud top temperature; aerosols AOD, etc.), store computed results in ! corresponding slots of array fluxr with appropriate time weights. ! - Collect the fluxr data for wrtsfc @@ -185,24 +182,24 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag fluxr(i,30) = fluxr(i,30) + fhlwr * fluxlwDOWN_clrsky(i,iSFC) ! clear sky sfc lw dn fluxr(i,33) = fluxr(i,33) + fhlwr * fluxlwUP_clrsky( i,iSFC) ! clear sky sfc lw up enddo - -! do i=1,nCol -! fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) -! fluxr(i,18) = fluxr(i,18) + raddt * cldsa(i,5) -! enddo + + do i=1,nCol + fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) + fluxr(i,18) = fluxr(i,18) + raddt * cldsa(i,5) + enddo ! Save cld frac,toplyr,botlyr and top temp, note that the order of h,m,l cloud is reversed for ! the fluxr output. save interface pressure (pa) of top/bot do j = 1, 3 do i = 1, nCol -! tem0d = raddt * cldsa(i,j) -! itop = mtopa(i,j) -! ibtc = mbota(i,j) -! fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d -! fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop) -! fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc) -! fluxr(i,17-j) = fluxr(i,17-j) + tem0d * t_lay(i,itop) - + tem0d = raddt * cldsa(i,j) + itop = mtopa(i,j) + ibtc = mbota(i,j) + fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d + fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop) + fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc) + fluxr(i,17-j) = fluxr(i,17-j) + tem0d * t_lay(i,itop) + ! Add optical depth and emissivity output tem2 = 0. do k=ibtc,itop diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 index 38dbe17d5..23a681826 100644 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ b/physics/GFS_rrtmgp_sw_post.F90 @@ -1,14 +1,14 @@ -module GFS_rrtmgp_sw_post +module GFS_rrtmgp_sw_post use machine, only: kind_phys use module_radiation_aerosols, only: NSPC1 use module_radsw_parameters, only: topfsw_type, sfcfsw_type, profsw_type, cmpfsw_type use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_fluxes_byband, only: ty_fluxes_byband use mo_heating_rates, only: compute_heating_rate - use radiation_tools, only: check_error_msg + use radiation_tools, only: check_error_msg use rrtmgp_sw_gas_optics, only: sw_gas_props implicit none - + public GFS_rrtmgp_sw_post_init,GFS_rrtmgp_sw_post_run,GFS_rrtmgp_sw_post_finalize contains @@ -33,23 +33,23 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky nirbmdi, nirdfdi, visbmdi, visdfdi, nirbmui, nirdfui, visbmui, visdfui, sfcnsw, & sfcdsw, htrsw, sfcfsw, topfsw, htrswc, flxprf_sw, scmpsw, errmsg, errflg) - ! Inputs - integer, intent(in) :: & - nCol, & ! Horizontal loop extent + ! Inputs + integer, intent(in) :: & + nCol, & ! Horizontal loop extent nLev, & ! Number of vertical layers nDay ! Number of daylit columns integer, intent(in), dimension(nday) :: & idxday ! Index array for daytime points - logical, intent(in) :: & - lsswr, & ! Call SW radiation? - do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? - save_diag ! Output radiation diagnostics? + logical, intent(in) :: & + lsswr, & ! Call SW radiation? + do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? + save_diag ! Output radiation diagnostics? real(kind_phys), intent(in) :: & fhswr ! Frequency for SW radiation real(kind_phys), dimension(nCol), intent(in) :: & t_lay, & ! Temperature at model layer centers (K) - coszen, & ! Cosine(SZA) - coszdg ! Cosine(SZA), daytime + coszen, & ! Cosine(SZA) + coszdg ! Cosine(SZA), daytime real(kind_phys), dimension(nCol, nLev+1), intent(in) :: & p_lev ! Pressure @ model layer-interfaces (Pa) real(kind_phys), dimension(sw_gas_props%get_nband(),ncol), intent(in) :: & @@ -65,17 +65,17 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky real(kind_phys), intent(in) :: & raddt ! Radiation time step real(kind_phys), dimension(nCol,NSPC1), intent(in) :: & - aerodp ! Vertical integrated optical depth for various aerosol species + aerodp ! Vertical integrated optical depth for various aerosol species real(kind_phys), dimension(nCol,5), intent(in) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL + cldsa ! Fraction of clouds for low, middle, high, total and BL integer, dimension(nCol,3), intent(in) ::& mbota, & ! vertical indices for low, middle and high cloud tops mtopa ! vertical indices for low, middle and high cloud bases real(kind_phys), dimension(nCol,nLev), intent(in) :: & cld_frac, & ! Total cloud fraction in each layer cldtausw ! approx .55mu band layer cloud optical depth - - ! Inputs (optional) + + ! Inputs (optional) type(cmpfsw_type), dimension(nCol), intent(inout), optional :: & scmpsw ! 2D surface fluxes, components: ! uvbfc - total sky downward uv-b flux at (W/m2) @@ -83,10 +83,10 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! nirbm - downward nir direct beam flux (W/m2) ! nirdf - downward nir diffused flux (W/m2) ! visbm - downward uv+vis direct beam flux (W/m2) - ! visdf - downward uv+vis diffused flux (W/m2) - + ! visdf - downward uv+vis diffused flux (W/m2) + real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr - + ! Outputs (mandatory) real(kind_phys), dimension(nCol), intent(inout) :: & nirbmdi, & ! sfc nir beam sw downward flux (W/m2) @@ -96,7 +96,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky nirbmui, & ! sfc nir beam sw upward flux (W/m2) nirdfui, & ! sfc nir diff sw upward flux (W/m2) visbmui, & ! sfc uv+vis beam sw upward flux (W/m2) - visdfui, & ! sfc uv+vis diff sw upward flux (W/m2) + visdfui, & ! sfc uv+vis diff sw upward flux (W/m2) sfcnsw, & ! total sky sfc netsw flx into ground sfcdsw ! real(kind_phys), dimension(nCol,nLev), intent(inout) :: & @@ -119,7 +119,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! dnfx0 - clear sky dnward flux (W/m2) real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & htrswc ! Clear-sky heating rate (K/s) - + ! Local variables integer :: i, j, k, iSFC, iTOA, itop, ibtc real(kind_phys) :: tem0d, tem1, tem2 @@ -135,7 +135,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! Are any optional outputs requested? l_fluxessw2d = present(flxprf_sw) - + ! Are the components of the surface fluxes provided? l_scmpsw = present(scmpsw) @@ -150,7 +150,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky iSFC = 1 iTOA = nLev+1 endif - + ! ####################################################################################### ! Compute SW heating-rates ! ####################################################################################### @@ -178,17 +178,14 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! Save SW outputs ! ####################################################################################### ! Copy fluxes from RRTGMP types into model radiation types. - ! Mandatory outputs - do i=1,nCol - topfsw(i)%upfxc = fluxswUP_allsky(i,iTOA) - topfsw(i)%upfx0 = fluxswUP_clrsky(i,iTOA) - topfsw(i)%dnfxc = fluxswDOWN_allsky(i,iTOA) - sfcfsw(i)%upfxc = fluxswUP_allsky(i,iSFC) - sfcfsw(i)%upfx0 = fluxswUP_clrsky(i,iSFC) - sfcfsw(i)%dnfxc = fluxswDOWN_allsky(i,iSFC) - sfcfsw(i)%dnfx0 = fluxswDOWN_clrsky(i,iSFC) - enddo + topfsw(:)%upfxc = fluxswUP_allsky(:,iTOA) + topfsw(:)%upfx0 = fluxswUP_clrsky(:,iTOA) + topfsw(:)%dnfxc = fluxswDOWN_allsky(:,iTOA) + sfcfsw(:)%upfxc = fluxswUP_allsky(:,iSFC) + sfcfsw(:)%upfx0 = fluxswUP_clrsky(:,iSFC) + sfcfsw(:)%dnfxc = fluxswDOWN_allsky(:,iSFC) + sfcfsw(:)%dnfx0 = fluxswDOWN_clrsky(:,iSFC) ! Optional output if(l_fluxessw2D) then @@ -197,10 +194,10 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky flxprf_sw(:,:)%upfx0 = fluxswUP_clrsky(:,:) flxprf_sw(:,:)%dnfx0 = fluxswDOWN_clrsky(:,:) endif - + ! Surface down and up spectral component fluxes ! - Save two spectral bands' surface downward and upward fluxes for output. - if (l_scmpsw) then + if (l_scmpsw) then do i=1,nCol nirbmdi(i) = scmpsw(i)%nirbm nirdfdi(i) = scmpsw(i)%nirdf @@ -212,17 +209,15 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(1,i) enddo else - do i=1,nCol - nirbmdi(i) = 0.0 - nirdfdi(i) = 0.0 - visbmdi(i) = 0.0 - visdfdi(i) = 0.0 - nirbmui(i) = 0.0 - nirdfui(i) = 0.0 - visbmui(i) = 0.0 - visdfui(i) = 0.0 - enddo - endif + nirbmdi(:) = 0.0 + nirdfdi(:) = 0.0 + visbmdi(:) = 0.0 + visdfdi(:) = 0.0 + nirbmui(:) = 0.0 + nirdfui(:) = 0.0 + visbmui(:) = 0.0 + visdfui(:) = 0.0 + endif else ! if_nday_block ! ####################################################################################### ! Dark everywhere @@ -230,17 +225,15 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky htrsw(:,:) = 0.0 sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) topfsw = topfsw_type( 0.0, 0.0, 0.0 ) - do i=1,nCol - nirbmdi(i) = 0.0 - nirdfdi(i) = 0.0 - visbmdi(i) = 0.0 - visdfdi(i) = 0.0 - nirbmui(i) = 0.0 - nirdfui(i) = 0.0 - visbmui(i) = 0.0 - visdfui(i) = 0.0 - enddo - + nirbmdi(:) = 0.0 + nirdfdi(:) = 0.0 + visbmdi(:) = 0.0 + visdfdi(:) = 0.0 + nirbmui(:) = 0.0 + nirdfui(:) = 0.0 + visbmui(:) = 0.0 + visdfui(:) = 0.0 + if (do_sw_clrsky_hr) then htrswc(:,:) = 0 endif @@ -286,7 +279,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky fluxr(i,27) = fluxr(i,27) + nirdfdi(i) * tem0d ! nir diff sw dn ! SW clear-sky fluxes fluxr(i,29) = fluxr(i,29) + topfsw(i)%upfx0 * tem0d - fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d + fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d fluxr(i,32) = fluxr(i,32) + sfcfsw(i)%dnfx0 * tem0d endif enddo diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/cires_ugwpv1_solv2.F90 index 8f417ea1d..afd94ff5c 100644 --- a/physics/cires_ugwpv1_solv2.F90 +++ b/physics/cires_ugwpv1_solv2.F90 @@ -14,7 +14,7 @@ module cires_ugwpv1_solv2 subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & xlatd, sinlat, coslat, & - pdudt, pdvdt, pdtdt, dked, zngw) + pdudt, pdvdt, pdtdt, dked, zngw) ! !-------------------------------------------------------------------------------- ! nov 2015 alternative gw-solver for nggps-wam @@ -24,7 +24,7 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! oct 2020 Diagnostics of "tauabs, wrms, trms" is taken out ! -------------------------------------------------------------------------------- ! - use machine, only : kind_phys + use machine, only : kind_phys use cires_ugwpv1_module,only : krad, kvg, kion, ktg, iPr_ktgw, Pr_kdis, Pr_kvkt @@ -157,8 +157,7 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! real(kind=kind_phys) :: zdelp, zdelm, taud_min - real(kind=kind_phys) :: tvc, tvm -! real(kind=kind_phys) :: tvc, tvm, ptc, ptm + real(kind=kind_phys) :: tvc, tvm, ptc, ptm real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 real(kind=kind_phys) :: fmode, expdis, fdis real(kind=kind_phys) :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit @@ -182,85 +181,85 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp real(kind=kind_phys) :: rstar, rstar2 - real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm - real(kind=kind_phys) :: taub_ch, sigu2_ch - real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max - real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr + real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm + real(kind=kind_phys) :: taub_ch, sigu2_ch + real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max + real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr !-------------------------------------------------------------------------- ! nslope3 = nslope + 3.0 - Pr_kdis_eff = gw_eff*pr_kdis - iPr_max = max(1.0, iPr_ktgw) - gipr = grav* Ipr_ktgw + Pr_kdis_eff = gw_eff*pr_kdis + iPr_max = max(1.0, iPr_ktgw) + gipr = grav* Ipr_ktgw ! ! test for input fields -! if (mpi_id == master .and. kdt < -2) then -! print *, im, levs, dtp, kdt, ' vay-solv2-v1' -! print *, minval(tm), maxval(tm), ' min-max-tm ' -! print *, minval(vm), maxval(vm), ' min-max-vm ' -! print *, minval(um), maxval(um), ' min-max-um ' -! print *, minval(qm), maxval(qm), ' min-max-qm ' -! print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' -! print *, minval(prsi), maxval(prsi), ' min-max-Pint ' -! print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' -! print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' -! print *, minval(prslk), maxval(prslk), ' min-max-Exner ' -! print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' -! print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' -! -! endif - - if (idebug_gwrms == 1) then - tauabs = 0.0 ; wrms = 0.0 ; trms = 0.0 - endif +! if (mpi_id == master .and. kdt < -2) then +! print *, im, levs, dtp, kdt, ' vay-solv2-v1' +! print *, minval(tm), maxval(tm), ' min-max-tm ' +! print *, minval(vm), maxval(vm), ' min-max-vm ' +! print *, minval(um), maxval(um), ' min-max-um ' +! print *, minval(qm), maxval(qm), ' min-max-qm ' +! print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' +! print *, minval(prsi), maxval(prsi), ' min-max-Pint ' +! print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' +! print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' +! print *, minval(prslk), maxval(prslk), ' min-max-Exner ' +! print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' +! print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' +! +! endif - rci(:) = 1.0 / zci(:) - rdci(:) = 1.0 / zdci(:) + if (idebug_gwrms == 1) then + tauabs=0.0; wrms =0.0 ; trms =0.0 + endif - rdtp = 1.0 / dtp - rdtp2 = 0.5 * rdtp + rci(:) = 1./zci(:) + rdci(:) = 1./zdci(:) - ksrc = max(ilaunch, 3) - km2 = ksrc - 2 - km1 = ksrc - 1 - kp1 = ksrc + 1 - ktop = levs + 1 + rdtp = 1./dtp + rdtp2 = 0.5*rdtp - suprf(ktop) = kion(levs) + ksrc= max(ilaunch, 3) + km2 = ksrc - 2 + km1 = ksrc - 1 + kp1 = ksrc + 1 + ktop= levs+1 - do k=1,levs - suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 - pdvdt(:,k) = 0.0 - pdudt(:,k) = 0.0 - pdtdt(:,k) = 0.0 - dked(: ,k) = 0.0 - enddo + suprf(ktop) = kion(levs) + + do k=1,levs + suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 + pdvdt(:,k) = 0.0 + pdudt(:,k) = 0.0 + pdtdt(:,k) = 0.0 + dked(: ,k) = 0.0 + enddo !----------------------------------------------------------- ! column-based j=1,im pjysics with 1D-arrays !----------------------------------------------------------- - DO j=1, im - jl = j - tx1 = omega2 * sinlat(j) *rv_kxw - cf1 = abs(tx1) - c2f2 = tx1 * tx1 - ucrit_max = max(ucrit, cf1) - ucrit3 = ucrit_max*ucrit_max*ucrit_max + DO j=1, im + jl =j + tx1 = omega2 * sinlat(j) *rv_kxw + cf1 = abs(tx1) + c2f2 = tx1 * tx1 + ucrit_max = max(ucrit, cf1) + ucrit3 = ucrit_max*ucrit_max*ucrit_max ! ! ngw-fluxes at all gridpoints (with tau_min at least) -! - aprsl(1:levs) = prsl(jl,1:levs) +! + aprsl(1:levs) = prsl(jl,1:levs) ! ! ksrc-define "aprsi(1:levs+1) redefine "ilaunch" ! do k=1, levs - if (aprsl(k) < psrc ) exit - enddo - ilaunch = max(k-1, 3) - ksrc = max(ilaunch, 3) + if (aprsl(k) .lt. psrc ) exit + enddo + ilaunch = max(k-1, 3) + ksrc= max(ilaunch, 3) - zngw(j) = zmet(j, ksrc) + zngw(j) = zmet(j, ksrc) km2 = ksrc - 2 km1 = ksrc - 1 @@ -268,340 +267,338 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & !=====ksrc - do k=1, levs - aum(k) = um(jl,k) - avm(k) = vm(jl,k) - atm(k) = tm(jl,k) - aqm(k) = qm(jl,k) - azmet(k) = zmet(jl,k) - aprsi(k) = prsi(jl,k) - azmeti(k) = zmeti(jl,k) - enddo - aprsi(levs+1) = prsi(jl,levs+1) - azmeti(levs+1) = zmeti(jl,levs+1) + aum(1:levs) = um(jl,1:levs) + avm(1:levs) = vm(jl,1:levs) + atm(1:levs) = tm(jl,1:levs) + aqm(1:levs) = qm(jl,1:levs) + azmet(1:levs) = zmet(jl,1:levs) + aprsi(1:levs+1) = prsi(jl,1:levs+1) + azmeti(1:levs+1) = zmeti(jl,1:levs+1) - rho_src = aprsl(ksrc)*rdi/atm(ksrc) - taub_ch = max(tau_ngw(jl), tau_min) - taub_src = taub_ch + rho_src = aprsl(ksrc)*rdi/atm(ksrc) + taub_ch = max(tau_ngw(jl), tau_min) + taub_src = taub_ch - sigu2 = zms * taub_src / (rho_src*v_kxw) - sig_u2az(1:nazd) = sigu2 + sigu2 = taub_src/rho_src/v_kxw * zms + sig_u2az(1:nazd) = sigu2 ! ! compute diffusion-based arrays km2:levs ! - do jk = km2, levs - dz_meti(jk) = azmeti(jk+1) - azmeti(jk) - dz_met(jk) = azmet(jk) - azmeti(jk-1) - enddo + do jk = km2, levs + dz_meti(jk) = azmeti(jk+1)-azmeti(jk) + dz_met(jk) = azmet(jk)-azmeti(jk-1) + enddo ! --------------------------------------------- ! interface mean flow parameters launch -> levs+1 ! --------------------------------------------- - do jk= km1,levs - tvc = atm(jk) * (1.0 + fv*aqm(jk)) - tvm = atm(jk-1) * (1.0 + fv*aqm(jk-1)) -! ptc = tvc / prslk(jl,jk) ! not used -! ptm = tvm / prslk(jl,jk-1) ! notused -! - zthm = 2.0 / (tvc+tvm) - rhp_wam = zthm*gor + do jk= km1,levs + tvc = atm(jk)*(1. +fv*aqm(jk)) + tvm = atm(jk-1)*(1. +fv*aqm(jk-1)) + ptc = tvc/ prslk(jl, jk) + ptm = tvm/prslk(jl,jk-1) +! + zthm = 2.0/(tvc+tvm) + rhp_wam = zthm*gor !interface - uint(jk) = 0.5*(aum(jk-1)+aum(jk)) - vint(jk) = 0.5*(avm(jk-1)+avm(jk)) - tint(jk) = 0.5*(tvc+tvm) - rhomid(jk) = aprsl(jk)*rdi/atm(jk) - rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) - zdelp = dz_meti(jk) ! >0 ...... dz-meters - v_zmet(jk) = zdelp + zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] - zdelm = 1.0 / dz_met(jk) ! 1/dz ...... 1/meters + uint(jk) = 0.5*(aum(jk-1)+aum(jk)) + vint(jk) = 0.5*(avm(jk-1)+avm(jk)) + tint(jk) = 0.5*(tvc+tvm) + rhomid(jk) = aprsl(jk)*rdi/atm(jk) + rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) + zdelp = dz_meti(jk) ! >0 ...... dz-meters + v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] + zdelm = 1./dz_met(jk) ! 1/dz ...... 1/meters ! -! bvf2 = grav2*zdelm*(ptc-ptm) / (ptc + ptm) ! N2=[g/PT]*(dPT/dz) +! bvf2 = grav2*zdelm*(ptc-ptm)/(ptc + ptm) ! N2=[g/PT]*(dPT/dz) ! - bn2(jk) = grav2cpd*zthm*(1.0+rcpdl*(tvc-tvm)*zdelm) - bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) - bn(jk) = sqrt(bn2(jk)) + bn2(jk) = grav2cpd*zthm*(1.0+rcpdl*(tvc-tvm)*zdelm) + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + bn(jk) = sqrt(bn2(jk)) - wrk3(jk) = 1.0 / (zdelp*rhomid(jk)) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] - irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src + wrk3(jk)= 1./zdelp/rhomid(jk) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] + irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src ! ! ! diagnostics -Kzz above PBL ! - uz = aum(jk) - aum(jk-1) - vz = avm(jk) - avm(jk-1) - shr2 = max(uz*uz+vz*vz, dw2min) * zdelm *zdelm + uz = aum(jk) - aum(jk-1) + vz = avm(jk) - avm(jk-1) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm - zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 - zgrow = exp(zmetk) - ritur = bn2(jk) / shr2 - kamp = sqrt(shr2) * sc2 * zgrow - w1 = 1.0 / (1.0 + 5*ritur) - ktur = min(max(kamp * w1 * w1, dked_min), dked_max) - zmetk = azmet(jk)* rhp - vueff(jk) = ktur + kvg(jk) + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + kamp = sqrt(shr2)*sc2 *zgrow + w1 = 1./(1. + 5*ritur) + ktur= min(max(kamp * w1 * w1, dked_min), dked_max) + zmetk = azmet(jk)* rhp + vueff(jk) = ktur + kvg(jk) - akt(jk) = gipr / tvc - enddo + akt(jk) = gipr/tvc + enddo if (idebug_gwrms == 1) then - do jk= km1,levs - wrk1(jk) = rv_kxw/rhoint(jk) - wrk2(jk) = rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) + do jk= km1,levs + wrk1(jk) = rv_kxw/rhoint(jk) + wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) enddo endif ! ! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) ! - jk = levs + jk = levs - rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) - tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) - uint(ktop) = aum(jk) - vint(ktop) = avm(jk) + rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) + tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) + uint(ktop) = aum(jk) + vint(ktop) = avm(jk) - v_zmet(ktop) = v_zmet(jk) - vueff(ktop) = vueff(jk) - bn2(ktop) = bn2(jk) - bn(ktop) = bn(jk) + v_zmet(ktop) = v_zmet(jk) + vueff(ktop) = vueff(jk) + bn2(ktop) = bn2(jk) + bn(ktop) = bn(jk) ! ! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity ! - do jk=km1, levs - akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) - enddo + do jk=km1, levs + akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) + enddo - bvi = bn(ksrc); bvi2 = bvi * bvi; - bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi + bvi = bn(ksrc); bvi2 = bvi * bvi; + bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi ! ! project winds at ksrc ! do iaz=1, nazd - ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) + ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) enddo ! - do jk=ksrc, ktop - cstar(jk) = bn(jk)/zms - cstar2(jk) = cstar(jk)*cstar(jk) - - fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 + do jk=ksrc, ktop + cstar(jk) = bn(jk)/zms + cstar2(jk) = cstar(jk)*cstar(jk) - do iaz=1, nazd - zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) - ui(iaz, jk) = zu !- ul(iaz)*0. + fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 + + do iaz=1, nazd + zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) + ui(iaz, jk) = zu !- ul(iaz)*0. + enddo enddo - enddo - rstar = 1.0 / cstar(ksrc) - rstar2 = rstar*rstar + rstar = 1./cstar(ksrc) + rstar2 = rstar*rstar ! ----------------------------------------- ! set launch momentum flux spectral density ! ----------------------------------------- - fpu(1:nazd, km2:ktop) = 0. + fpu(1:nazd, km2:ktop) =0. - do inc=1,nwav + do inc=1,nwav - zcin = zci(inc)*rstar + zcin = zci(inc)*rstar ! ! integrate (flux(cin) x dcin ) old tau-flux and normalization ! - flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) + flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) ! -! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] +! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] ! - fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less - - do iaz=1,nazd - akzw(inc, iaz, ksrc) = bvi*rci(inc) - enddo + fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less + + do iaz=1,nazd + akzw(inc, iaz, ksrc) = bvi*rci(inc) + enddo - enddo + enddo ! ! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) - flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] - ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 - do jk=ksrc, ktop - fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 - enddo + flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] + ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 + do jk=ksrc, ktop + fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 + enddo ! - do inc=1, nwav - flux(inc,1) = flux_norm*flux(inc,1) - enddo + do inc=1, nwav + flux(inc,1) = flux_norm*flux(inc,1) + enddo - if (ener_norm == 1) then - snorm_ener = 0. - do inc=1,nwav - zcin = zci(inc)*rstar - ze2 = zcin / (1.0 + zcin**nslope3) - snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less - flux(inc,1) = ze2 * zcin - enddo - ekin_norm = 1.0 / snorm_ener + if (ener_norm == 1) then + snorm_ener = 0. + do inc=1,nwav + zcin = zci(inc)*rstar + + ze2 = zcin /(1.+ zcin**nslope3) + + snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less + flux(inc,1) = ze2 * zcin + enddo + ekin_norm = 1./snorm_ener + ! taub_src = sigu2 * rho_src * [v_kxw / zms ] ! sigu2 = taub_src*zms/(rho_src/v_kxw) ! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns - ze1 = taub_src*zms/bvi * ekin_norm + ze1 = taub_src*zms/bvi * ekin_norm taub_src = 0. - - do inc=1,nwav - flux(inc,1) = ze1* flux(inc,1) - taub_src = taub_src + flux(inc,1)*zdci(inc) - enddo - ze1 = ekin_norm * v_kxw * rstar2 - do jk=ksrc, ktop - fden_bnen(jk) = rhoint(jk) / bn(jk) * ze1 ! mult on => sigu2(z)*cdf2 => flux_sat - enddo - - endif + + do inc=1,nwav + flux(inc,1) = ze1* flux(inc,1) + taub_src = taub_src + flux(inc,1)*zdci(inc) + enddo + ze1 = ekin_norm * v_kxw * rstar2 + do jk=ksrc, ktop + fden_bnen(jk) = rhoint(jk) / bn(jk) *ze1 ! mult on => sigu2(z)*cdf2 => flux_sat + enddo + + endif ! - do iaz=1,nazd - fpu(iaz, ksrc) = taub_src - fpu(iaz, km1) = taub_src - enddo + do iaz=1,nazd + fpu(iaz, ksrc) = taub_src + fpu(iaz, km1) = taub_src + enddo ! copy flux-1 into other azimuths ! -------------------------------- - do iaz=2, nazd - do inc=1,nwav - flux(inc,iaz) = flux(inc,1) - enddo + do iaz=2, nazd + do inc=1,nwav + flux(inc,iaz) = flux(inc,1) enddo + enddo -! if (mpi_id == master .and. ener_norm == 1) then -! print * -! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm -! print * -! endif - - if (idebug_gwrms == 1) then - pwrms = 0. - ptrms = 0. - tx1 = real(nazd)/rhoint(ksrc)*rv_kxw - ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 - do inc=1, nwav - v_kzw = bvi*rci(inc) - ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw - pwrms = pwrms + ze1 - ptrms = ptrms + ze1 * ze2 - enddo - wrms(jl, ksrc) = pwrms - trms(jl, ksrc) = ptrms - endif +! if (mpi_id == master .and. ener_norm == 1) then +! print * +! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm +! print * +! endif + + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + tx1 = real(nazd)/rhoint(ksrc)*rv_kxw + ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 + do inc=1, nwav + v_kzw = bvi*rci(inc) + ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw + pwrms = pwrms + ze1 + ptrms = ptrms + ze1 * ze2 + enddo + wrms(jl, ksrc) = pwrms + trms(jl, ksrc) = ptrms + endif ! -------------------------------- - wave_act(:,:) = 1.0 + wave_act(:,:) = 1.0 ! vertical do-loop - do jk=ksrc, levs + do jk=ksrc, levs - jkp = jk+1 + jkp = jk+1 ! azimuth do-loop - do iaz=1, nazd + do iaz=1, nazd - sig_u2az_m(iaz) = sig_u2az(iaz) + sig_u2az_m(iaz) = sig_u2az(iaz) - umfp = ui(iaz, jkp) - umfm = ui(iaz, jk) - umfc = .5*(umfm + umfp) + umfp = ui(iaz, jkp) + umfm = ui(iaz, jk) + umfc = .5*(umfm + umfp) ! wave-cin loop - dfdz_v(iaz, jk) = 0.0 - dfdz_heat(iaz, jk) = 0.0 - fpu(iaz, jkp) = 0.0 - sig_u2az(iaz) = 0.0 + dfdz_v(iaz, jk) = 0.0 + dfdz_heat(iaz, jk) = 0.0 + fpu(iaz, jkp) = 0.0 + sig_u2az(iaz) =0.0 ! ! wave_dis(iaz, :) = vueff(jk) - do inc=1, nwav - flux_m(inc, iaz) = flux(inc, iaz) + do inc=1, nwav + flux_m(inc, iaz) = flux(inc, iaz) - zcin = zci(inc) ! zcin =/0 by definition - zcinc = rci(inc) + zcin = zci(inc) ! zcin =/0 by definition + zcinc = rci(inc) - if (wave_act(inc,iaz) == 1.0) then + if(wave_act(inc,iaz) == 1.0) then !======================================================================= ! discrete mode ! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat ! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) !======================================================================= - v_cdp = zcin - umfp - v_cdp2=v_cdp*v_cdp - cdf2 = v_cdp2 - c2f2 - if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then + v_cdp = zcin - umfp + v_cdp2=v_cdp*v_cdp + cdf2 = v_cdp2 - c2f2 + if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then ! ! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max, wave's absorption ! - wave_act(inc,iaz) = 0. - akzw(inc, iaz, jkp) = pi/dz_meti(jk) ! pi2/dzmet - fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) - flux(inc,iaz) = fluxs + wave_act(inc,iaz) =0. + akzw(inc, iaz, jkp) = pi/dz_meti(jk) ! pi2/dzmet + fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) + flux(inc,iaz) = fluxs - else + else - v_wdp = v_kxw * v_cdp - wdop2 = v_wdp * v_wdp + v_wdp = v_kxw*v_cdp + wdop2 = v_wdp* v_wdp ! ! rotational cut-off ! - kzw2 = (bn2(jkp)-wdop2)/Cdf2 + kzw2 = (bn2(jkp)-wdop2)/Cdf2 ! !cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 ! - if ( kzw2 > mkz2min ) then - v_kzw = sqrt(kzw2) - akzw(inc, iaz, jkp) = v_kzw + if ( kzw2 > mkz2min ) then + v_kzw = sqrt(kzw2) + akzw(inc, iaz, jkp) = v_kzw ! !linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 ! !kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) ! Kds_sat = kxw*Cdf1*rhp2/kzw3 !krad, kvg, kion, ktg - v_cdp = sqrt( cdf2 ) - v_wdp = v_kxw * v_cdp - v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due for "all" vars - v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) - v_kzi = v_kzw*v_wdi/v_wdpc + v_cdp = sqrt( cdf2 ) + v_wdp = v_kxw * v_cdp + v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due for "all" vars + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc ! - ze1 = v_kzi*v_zmet(jk) + ze1 = v_kzi*v_zmet(jk) - if (ze1 .ge. 1.e-2) then - expdis = max(exp(-ze1), 0.01) - else - expdis = 1.0 / (1.0 + ze1) - endif + if (ze1 .ge. 1.e-2) then + expdis = max(exp(-ze1), 0.01) + else + expdis = 1./(1.+ ze1) + endif ! - wave_act(inc,iaz) = 1.0 - fmode = flux(inc,iaz) - - flux_2_sig = v_kzw / (v_kxw*rhoint(jkp)) - w1 = v_wdpc / (kzw2*v_kzw*v_zmet(jk)) - else ! kzw2 <= mkz2min large "Lz"-reflection + wave_act(inc,iaz) = 1.0 + fmode = flux(inc,iaz) - expdis = 1.0 - v_kzw = mkzmin + flux_2_sig = v_kzw/v_kxw/rhoint(jkp) + w1 = v_wdpc/kzw2/v_kzw/v_zmet(jk) + else ! kzw2 <= mkz2min large "Lz"-reflection - v_cdp = 0. ! no effects of reflected waves - wave_act(inc,iaz) = 0.0 - akzw(inc, iaz, jkp) = v_kzw - fmode = 0. - w1 = 0. - endif + expdis = 1.0 + v_kzw = mkzmin -! expdis =1.0 + v_cdp = 0. ! no effects of reflected waves + wave_act(inc,iaz) = 0.0 + akzw(inc, iaz, jkp) = v_kzw + fmode = 0. + w1 =0. + endif +! expdis =1.0 - fdis = fmode*expdis*wave_act(inc,iaz) + fdis = fmode*expdis*wave_act(inc,iaz) !============================================================================== ! ! Saturated Fluxes and Energy: Spectral and Dicrete Modes @@ -615,7 +612,7 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) ! new sat fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) ! -! fluxs = fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) +! fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) ! ! @@ -624,136 +621,131 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! [fden_bn(jkp)] = Pa/dc ! fsat = rstar*(zcin*zcin) * [taub_src / SN * [ rstar3*rho/rho_src *N_src/N] = fden_bn ] - if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] + if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] ! ! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc ! - if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) - if (ener_norm == 1) then + if (ener_norm == 1) then ! spectral saturation limit - - if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) + + if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) ! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc - if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) + if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) ! - endif + endif !---------------------------------------------------------------------------- ! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw -! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat -! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat +! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat !---------------------------------------------------------------------------- - zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa - if (zdep > 0.0 ) then + zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa + if(zdep > 0.0 ) then ! subs on sat-limit - ze1 = flux(inc,iaz) - flux(inc,iaz) = fluxs - ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs - ! here we can add extra-dissip for the next layer -!Moorthi the above ze2 is not used it appears! - - else + ze1 = flux(inc,iaz) + flux(inc,iaz) = fluxs + ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs + ! here we can add extra-dissip for the next layer + else ! assign dis-ve flux - flux(inc,iaz) = fdis - endif + flux(inc,iaz) = fdis + endif - dtau = flux_m(inc,iaz)-flux(inc,iaz) - if (dtau .lt. 0) then - flux(inc,iaz) = flux_m(inc,iaz) - endif + dtau = flux_m(inc,iaz)-flux(inc,iaz) + if (dtau .lt. 0) then + flux(inc,iaz) = flux_m(inc,iaz) + endif ! ! GW-sponge domain: saturate all "GW"-modes above "zsp_gw" ! - if ( azmeti(jkp) >= zsp_gw) then -! mi_sponge = 0.5 / dz_meti(jk) -! ze2 = v_wdp / v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] -! v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge - - v_wdi = 0.5 * v_wdp / (v_kzw *dz_meti(jk)) + v_wdi*0.25 ! diss-sat GW-sponge - v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) - v_kzi = v_kzw*v_wdi/v_wdpc + if ( azmeti(jkp) .ge. zsp_gw) then + mi_sponge = .5/dz_meti(jk) + ze2 = v_wdp /v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] + v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge + v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) + v_kzi = v_kzw*v_wdi/v_wdpc ! -! ze1 = v_kzi*v_zmet(jk) -! exp_sponge = exp(-ze1) - exp_sponge = exp(-v_kzi*v_zmet(jk)) + ze1 = v_kzi*v_zmet(jk) + exp_sponge = exp(-ze1) ! ! additional sponge ! - flux(inc,iaz) = flux(inc,iaz) *exp_sponge - endif + flux(inc,iaz) = flux(inc,iaz) *exp_sponge + endif - endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then - endif ! only for waves w/o CL-absorption wave_act=1 + endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then + endif ! only for waves w/o CL-absorption wave_act=1 ! ! sum for given (jk, iaz) all active "wave" contributions ! - if (wave_act(inc,iaz) == 1) then + if (wave_act(inc,iaz) == 1) then - zcinc = zdci(inc) - vc_zflx_mode = flux(inc,iaz) - vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) - if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) - ze1 = vc_zflx_mode*zcinc - fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at - sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz + zcinc =zdci(inc) + vc_zflx_mode = flux(inc,iaz) + vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) + if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) + ze1 = vc_zflx_mode*zcinc + fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at + sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! (heat deposition integration over spectral mode for each azimuth ! later sum over selected azimuths as "non-negative" scalars) ! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! zdelp = wrk3(jk)*cdf1 *zcinc +! zdelp = wrk3(jk)*cdf1 *zcinc - zdelp = wrk3(jk) * v_cdp * zcinc * vmdiff + zdelp = wrk3(jk)* v_cdp *zcinc * vmdiff -! zcool = 1. ! COOL=(-3.5 + Pr)/Pr -! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp -! edis = (c-u)*ax/cp = Kv_dis*N2/cp -! cool = -Kt*N2/R +! zcool = 1. ! COOL=(-3.5 + Pr)/Pr +! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp +! edis = (c-u)*ax/cp = Kv_dis*N2/cp +! cool = -Kt*N2/R ! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] ! - dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 - dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 - endif !wave_act(inc,iaz) == 1) + dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 + dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 + endif !wave_act(inc,iaz) == 1) ! - enddo ! wave-inc-loop + enddo ! wave-inc-loop - ze1 = fpu(iaz, jk) - if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 + ze1 =fpu(iaz, jk) + if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 ! ! compute wind and temp-re rms ! - if (idebug_gwrms == 1) then - pwrms = 0. - ptrms = 0. - do inc=1, nwav - if (wave_act(inc,iaz) > 0.) then - v_kzw = akzw(inc, iaz, jk) - ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) - pwrms = pwrms + ze1 - ptrms = ptrms + ze1*wrk2(jk) - endif - enddo - Awrms(iaz, jk) = pwrms - Atrms(iaz, jk) = ptrms - endif + if (idebug_gwrms == 1) then + pwrms =0. + ptrms =0. + do inc=1, nwav + if (wave_act(inc,iaz) > 0.) then + v_kzw =akzw(inc, iaz, jk) + ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) + pwrms = pwrms + ze1 + ptrms = ptrms + ze1*wrk2(jk) + endif + enddo + Awrms(iaz, jk) = pwrms + Atrms(iaz, jk) = ptrms + endif ! -------------- - enddo ! end Azimuth do-loop + enddo ! end Azimuth do-loop ! ! eddy wave dissipation to limit GW-rms ! - tx1 = sum(abs(dfdz_heat(1:nazd, jk))) / bn2(jk) - ze1 = max(dked_min, tx1) - ze2 = min(dked_max, ze1) - vueff(jkp) = ze2 + vueff(jkp) + tx1 = sum(abs(dfdz_heat(1:nazd, jk)))/bn2(jk) + ze1=max(dked_min, tx1) + ze2=min(dked_max, ze1) + vueff(jkp) = ze2 + vueff(jkp) ! - enddo ! end Vertical do-loop + enddo ! end Vertical do-loop ! ! top-layers constant interface-fluxes and zero-heat ! we allow non-zero momentum fluxes and thermal effects @@ -769,38 +761,38 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! at the source level and below taux = 0 (taux_E=-taux_W by assumption) !======================================================================== - do jk=ksrc, levs + do jk=ksrc, levs taux(jk) = 0.0 tauy(jk) = 0.0 - do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) - pdtdt(jl,jk) = pdtdt(jl,jk) + dfdz_v(iaz,jk) - dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) - enddo + do iaz=1,nazd + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + pdtdt(jl,jk) = pdtdt(jl,jk) + dfdz_v(iaz,jk) + dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) enddo - jk = ktop ; taux(jk) = 0. ; tauy(jk) = 0. + enddo + jk = ktop; taux(jk)=0.; tauy(jk)=0. do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) + taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) + tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) enddo - if (idebug_gwrms == 1) then - do jk=kp1, levs - do iaz=1,nazd - wrms(jl,jk) = wrms(jl,jk) + Awrms(iaz,jk) - trms(jl,jk) = trms(jl,jk) + Atrms(iaz,jk) - tauabs(jl,jk) = tauabs(jl,jk) + fpu(iaz,jk) - enddo - enddo - endif + if (idebug_gwrms == 1) then + do jk=kp1, levs + do iaz=1,nazd + wrms(jl,jk) =wrms(jl,jk) + Awrms(iaz,jk) + trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) + tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) + enddo + enddo + endif ! - do jk=ksrc+1,levs - jkp = jk + 1 + do jk=ksrc+1,levs + jkp = jk + 1 zdelp = wrk3(jk)*gw_eff - ze1 = (taux(jkp)-taux(jk)) * zdelp - ze2 = (tauy(jkp)-tauy(jk)) * zdelp + ze1 = (taux(jkp)-taux(jk))* zdelp + ze2 = (tauy(jkp)-tauy(jk))* zdelp if (abs(ze1) >= maxdudt ) then ze1 = sign(maxdudt, ze1) @@ -815,235 +807,230 @@ subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & ! Cx =0 based Cx=/= 0. above ! ! - if (knob_ugwp_doheat == 1) then + if (knob_ugwp_doheat == 1) then ! -! maxdtdt= dked_max * bnfix2 +!maxdtdt= dked_max * bnfix2 ! - pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff - ze2 = pdtdt(jl,jk) - if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) + pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff + ze2 = pdtdt(jl,jk) + if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) - dked(jl,jk) = dked(jl,jk) / bn2(jk) - ze1 = max(dked_min, dked(jl,jk)) - dked(jl,jk) = min(dked_max, ze1) - qmid(jk) = pdtdt(j,jk) - endif - enddo + dked(jl,jk) = dked(jl,jk)/bn2(jk) + ze1 = max(dked_min, dked(jl,jk)) + dked(jl,jk) = min(dked_max, ze1) + qmid(jk) = pdtdt(j,jk) + endif + enddo !---------------------------------------------------------------------------------- ! Update heat = ek_diss/cp and aply 1-2-1 smoother for "dked" => dktur ! here with "u_new = u +dtp*dudt ; vnew = v + v +dtp*dvdt ! can check "stability" in the column and "add" ktur-estimation ! to suppress instability as needed so dked = dked_gw + ktur_ric !---------------------------------------------------------------------------------- - - dktur(1:levs) = dked(jl,1:levs) + + dktur(1:levs) = dked(jl,1:levs) ! - do ist= 1, nstdif - do jk=ksrc,levs-1 - adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) - enddo - dktur(ksrc:levs-1) = adif(ksrc:levs-1) - enddo - dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) - dktur(levs+1) = dktur(levs) + do ist= 1, nstdif + do jk=ksrc,levs-1 + adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) + enddo + dktur(ksrc:levs-1) = adif(ksrc:levs-1) + enddo + dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) + dktur(levs+1) = dktur(levs) - do jk=ksrc,levs+1 - ze1 = .5*( dktur(jk) +dktur(jk-1) ) - kvint(jk) = ze1 - ktint(jk) = ze1*iPr_ktgw - enddo + do jk=ksrc,levs+1 + ze1 = .5*( dktur(jk) +dktur(jk-1) ) + kvint(jk) = ze1 + ktint(jk) = ze1*iPr_ktgw + enddo ! ! Thermal budget qmid = qheat + qcool ! - do jk=ksrc+1,levs + do jk=ksrc+1,levs ze2 = qmid(jk) + dktur(jk)*Akt(jk) + grav*(ktint(jk+1)-ktint(jk))/dz_meti(jk) - qmid(jk) = ze2 - if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) + qmid(jk) = ze2 + if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) pdtdt(jl,jk) = qmid(jk)*rcpd - dked(jl, jk) = dktur(jk) + dked(jl, jk) = dktur(jk) enddo ! ! perform explicit eddy "diffusive" 3-point smoothing of "u-v-t" ! from the surface/launch-gw to the "top" ! ! - do jk=km2,levs ! update by source function X(t+dt) = X(t) + dtp * dXdt ! - uold(jk) = aum(jk) + pdudt(jl,jk) * dtp - vold(jk) = avm(jk) + pdvdt(jl,jk) * dtp - told(jk) = atm(jk) + pdtdt(jl,jk) * dtp + uold(km2:levs) = aum(km2:levs)+pdudt(jl,km2:levs)*dtp + vold(km2:levs) = avm(km2:levs)+pdvdt(jl,km2:levs)*dtp + told(km2:levs) = atm(km2:levs)+pdtdt(jl,km2:levs)*dtp ! ! diagnose turb-profile using "stability-check" relying on the free-atm diffusion ! sc2 = 30m x 30m ! - dktur(jk) = dked_min - enddo + dktur(km2:levs) = dked_min - do jk=km1,levs - uz = uold(jk) - uold(jk-1) - vz = vold(jk) - vold(jk-1) - ze1 = dz_met(jk) - zdelm = 1.0 / ze1 + do jk=km1,levs + uz = uold(jk) - uold(jk-1) + vz = vold(jk) - vold(jk-1) + ze1 = dz_met(jk) + zdelm = 1./ze1 - tvc = told(jk) * (1. +fv*aqm(jk)) - tvm = told(jk-1) * (1. +fv*aqm(jk-1)) - zthm = 2.0 / (tvc+tvm) - shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm + tvc = told(jk) * (1. +fv*aqm(jk)) + tvm = told(jk-1) * (1. +fv*aqm(jk-1)) + zthm = 2.0 / (tvc+tvm) + shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm - bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) + bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) - bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) - zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 - zgrow = exp(zmetk) - ritur = bn2(jk)/shr2 - w1 = 1.0 / (1.0 + 5*ritur) - ze2 = min( sc2 *zgrow, 4.*ze1*ze1) + bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) + zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 + zgrow = exp(zmetk) + ritur = bn2(jk)/shr2 + w1 = 1./(1. + 5*ritur) + ze2 = min( sc2 *zgrow, 4.*ze1*ze1) ! ! Smag-type of eddy diffusion K_smag = Sqrt(Deformation - N2/Pr)* L2 *const ! - kamp = sqrt(shr2)* ze2 * w1 * w1 - ktur = min(max(kamp, dked_min), dked_max) - dktur(jk) = ktur + kamp = sqrt(shr2)* ze2 * w1 * w1 + ktur= min(max(kamp, dked_min), dked_max) + dktur(jk) = ktur ! ! update of dked = dked_gw + k_turb_mf -! - dked(jl, jk) = dked(jl, jk) +ktur +! + dked(jl, jk) = dked(jl, jk) +ktur - enddo + enddo ! ! apply eddy effects due to GWs: explicit scheme Kzz*dt/dz2 < 0.5 stability ! - if (knob_ugwp_dokdis == 2) then + if (knob_ugwp_dokdis == 2) then - do jk=ksrc,levs - ze1 = min(.5*(dktur(jk)+dktur(jk-1)), dturb_max) - kvint(jk) = kvint(jk) + ze1 -! ktint(jk) = ktint(jk) + ze1*iPr_ktgw - enddo - kvint(km1) = kvint(ksrc) - kvint(ktop) = kvint(levs) + do jk=ksrc,levs + ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) + kvint(jk) = kvint(jk) + ze1 +! ktint(jk) = ktint(jk) + ze1*iPr_ktgw + enddo + kvint(km1) = kvint(ksrc) + kvint(ktop) = kvint(levs) - dzmetm = 1./dz_met(km1) - Adif(km1:levs) = 0. - Cdif(km1:levs) = 0. + dzmetm = 1./dz_met(km1) + Adif(km1:levs) = 0. + Cdif(km1:levs) = 0. do jk=km1,levs-1 - dzmetp = 1.0 / dz_met(jk+1) - dzmetf = 1.0 / (dz_meti(jk)*rhomid(jk)) + dzmetp = 1./dz_met(jk+1) + dzmetf = 1./(dz_meti(jk)*rhomid(jk)) - ktur = kvint(jk) * rhoint(jk) * dzmetf - kturp = Kvint(jk+1) * rhoint(jk+1) * dzmetf - - Adif(jk) = ktur * dzmetm - Cdif(jk) = kturp * dzmetp - ApC = adif(jk) + cdif(jk) - ACdif(jk) = ApC + ktur = kvint(jk) *rhoint(jk) * dzmetf + kturp =Kvint(jk+1)*rhoint(jk+1) * dzmetf + + Adif(jk) = ktur * dzmetm + Cdif(jk) = kturp * dzmetp + ApC = adif(jk)+cdif(jk) + ACdif(jk) = ApC - w1 = ApC*iPr_max - if (rdtp < w1 ) then - Anstab(jk) = floor(w1*dtp) + 1 - else - Anstab(jk) = 1 - endif - dzmetm = dzmetp - enddo + w1 = ApC*iPr_max + if (rdtp < w1 ) then + Anstab(jk) = floor(w1*dtp) + 1 + else + Anstab(jk) = 1 + endif + dzmetm = dzmetp + enddo - nstab = maxval( Anstab(ksrc:levs-1)) + nstab = maxval( Anstab(ksrc:levs-1)) -! if (nstab .ge. 3) print *, 'nstab ', nstab +! if (nstab .ge. 3) print *, 'nstab ', nstab ! ! k instead Jk ! - dtdif = dtp/real(nstab) - ze1 = 1./dtdif + dtdif = dtp/real(nstab) + ze1 = 1./dtdif - do ist= 1, nstab - do k=ksrc,levs-1 - Bdif = ze1 - ACdif(k) - Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 - unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) - vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) - tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw - enddo + do ist= 1, nstab + do k=ksrc,levs-1 + Bdif = ze1 - ACdif(k) + Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 + unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) + vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) + tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw + enddo - do k=ksrc,levs-1 - uold(k) = unew(k) * dtdif ! value du/dtp *dtp = du - vold(k) = vnew(k) * dtdif - told(k) = tnew(k) * dtdif - enddo + uold(ksrc:levs-1) = unew(ksrc:levs-1)*dtdif ! value du/dtp *dtp = du + vold(ksrc:levs-1) = vnew(ksrc:levs-1)*dtdif + told(ksrc:levs-1) = tnew(ksrc:levs-1)*dtdif ! ! smoothing the boundary points: "k-1" = ksrc-1 and "k+1" = levs ! - uold(levs) = uold(levs-1) - vold(levs) = vold(levs-1) - told(levs) = told(levs-1) - enddo + uold(levs) = uold(levs-1) + vold(levs) = vold(levs-1) + told(levs) = told(levs-1) + enddo ! ! compute "smoothed" tendencies by molecular + GW-eddy diffusions ! - do k=ksrc,levs-1 -! + do k=ksrc,levs-1 +! ! final updates of tendencies and diffusion ! - ze2 = rdtp * (uold(k) - aum(k)) - ze1 = rdtp * (vold(k) - avm(k)) - pdtdt(jl,k) = rdtp * (told(k) - atm(k)) - - if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) - if (abs(ze1) >= maxdudt ) then - ze1 = sign(maxdudt, ze1) - endif - if (abs(ze2) >= maxdudt ) then - ze2 = sign(maxdudt, ze2) - endif + ze2 = rdtp*(uold(k) - aum(k)) + ze1 = rdtp*(vold(k) - avm(k)) + pdtdt(jl,k)= rdtp*( told(k) - atm(k) ) - pdudt(jl, k) = ze2 - pdvdt(jl, k) = ze1 - uz = uold(k+1) - uold(k-1) - vz = vold(k+1) - vold(k-1) - ze2 = 1.0 / (dz_met(k+1)+dz_met(k) ) + if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) + if (abs(ze1) >= maxdudt ) then + ze1 = sign(maxdudt, ze1) + endif + if (abs(ze2) >= maxdudt ) then + ze2 = sign(maxdudt, ze2) + endif - mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat - pdtdt(jl,k) = pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity + pdudt(jl, k) = ze2 + pdvdt(jl, k) = ze1 + uz = uold(k+1) - uold(k-1) + vz = vold(k+1) - vold(k-1) + ze2 = 1./(dz_met(k+1)+dz_met(k) ) + mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat + pdtdt(jl,k)= pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity - enddo + enddo - ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t + ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t - enddo ! J-loop + enddo ! J-loop ! - RETURN + RETURN !================================= diag print after "return" ====================== - if (kdt ==1 .and. mpi_id == master) then + if (kdt ==1 .and. mpi_id == master) then ! - print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' - print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) - print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) -! print *, 'ugwpv1: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min + print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' + print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) + print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) +! print *, 'ugwpv1: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min - print * + print * - endif + endif - if (kdt == 1 .and. mpi_id == master) then - print *, 'vgw done nstab ', nstab + if (kdt == 1 .and. mpi_id == master) then + print *, 'vgw done nstab ', nstab ! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' - print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' - print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' + print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' + print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' + print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' + print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' ! -! print *, ' ugwp -heating rates ' - endif +! print *, ' ugwp -heating rates ' + endif !================================= - return - end subroutine cires_ugwpv1_ngw_solv2 + return + end subroutine cires_ugwpv1_ngw_solv2 end module cires_ugwpv1_solv2 diff --git a/physics/cires_ugwpv1_solv2.F90_mine b/physics/cires_ugwpv1_solv2.F90_mine deleted file mode 100644 index 8f417ea1d..000000000 --- a/physics/cires_ugwpv1_solv2.F90_mine +++ /dev/null @@ -1,1049 +0,0 @@ -module cires_ugwpv1_solv2 - - -contains - - -!--------------------------------------------------- -! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 -! dissipative solver with NonHyd/ROT-effects -! reflected GWs treated as waves with "negligible" flux, -! they are out of given column -!--------------------------------------------------- - - subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & - tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & - xlatd, sinlat, coslat, & - pdudt, pdvdt, pdtdt, dked, zngw) -! -!-------------------------------------------------------------------------------- -! nov 2015 alternative gw-solver for nggps-wam -! nov 2017 nh/rotational gw-modes for nh-fv3gfs -! oct 2019 adding empirical satellite-based -! source function and *F90 CIRES-style of the code -! oct 2020 Diagnostics of "tauabs, wrms, trms" is taken out -! -------------------------------------------------------------------------------- -! - use machine, only : kind_phys - - use cires_ugwpv1_module,only : krad, kvg, kion, ktg, iPr_ktgw, Pr_kdis, Pr_kvkt - - use cires_ugwpv1_module,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms - - use cires_ugwpv1_module,only : psrc => knob_ugwp_palaunch - - use cires_ugwpv1_module,only : maxdudt, maxdtdt, max_eps, dked_min, dked_max - - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & - omega2, rcpd, rcpd2, pi, pi2, fv, & - rad_to_deg, deg_to_rad, & - rdi, gor, grcp, gocp, & - bnv2min, bnv2max, dw2min, velmin, gr2, & - hpscale, rhp, rh4, grav2, rgrav2, mkzmin, mkz2min -! - use ugwp_wmsdis_init, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & - gw_eff, & - nslope, ilaunch, zms, & - zci, zdci, zci4, zci3, zci2, & - zaz_fct, zcosang, zsinang, nwav, nazd, & - zcimin, zcimax, rimin, sc2, sc2u, ric -! - implicit none -! - real(kind=kind_phys), parameter :: zsp_gw = 106.5e3 ! sponge for GWs above the model top - real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 - integer, parameter :: ener_norm =0 - integer, parameter :: ener_lsat=0 - integer, parameter :: nstdif = 1 - integer, parameter :: wave_sponge = 1 - - integer, intent(in) :: levs ! vertical level - integer, intent(in) :: im ! horiz tiles - integer, intent(in) :: mpi_id, master, kdt - - real(kind=kind_phys) ,intent(in) :: dtp ! model time step - real(kind=kind_phys) ,intent(in) :: tau_ngw(im) - - real(kind=kind_phys) ,intent(in) :: vm(im,levs) ! meridional wind - real(kind=kind_phys) ,intent(in) :: um(im,levs) ! zonal wind - real(kind=kind_phys) ,intent(in) :: qm(im,levs) ! spec. humidity - real(kind=kind_phys) ,intent(in) :: tm(im,levs) ! kinetic temperature - - real(kind=kind_phys) ,intent(in) :: prsl(im,levs) ! mid-layer pressure - real(kind=kind_phys) ,intent(in) :: prslk(im,levs) ! mid-layer exner function - real(kind=kind_phys) ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav - real(kind=kind_phys) ,intent(in) :: prsi(im,levs+1) ! interface pressure - real(kind=kind_phys) ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters - real(kind=kind_phys) ,intent(in) :: xlatd(im) ! xlat_d in degrees - real(kind=kind_phys) ,intent(in) :: sinlat(im) - real(kind=kind_phys) ,intent(in) :: coslat(im) -! -! out-gw effects -! - real(kind=kind_phys) ,intent(out) :: pdudt(im,levs) ! zonal momentum tendency - real(kind=kind_phys) ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency - real(kind=kind_phys) ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp and cooling - real(kind=kind_phys) ,intent(out) :: dked(im,levs) ! gw-eddy diffusion - real(kind=kind_phys) ,intent(out) :: zngw(im) ! launch height -! -! -! -! local =========================================================================================== - - real(kind=kind_phys) :: tauabs(im,levs) ! - real(kind=kind_phys) :: wrms(im,levs) ! - real(kind=kind_phys) :: trms(im,levs) ! - - real(kind=kind_phys) :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) - real(kind=kind_phys) :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) -! -! local =========================================================================================== - real(kind=kind_phys) :: taux(levs+1) ! EW component of vertical momentum flux (pa) - real(kind=kind_phys) :: tauy(levs+1) ! NS component of vertical momentum flux (pa) - real(kind=kind_phys) :: fpu(nazd, levs+1) ! az-momentum flux - real(kind=kind_phys) :: ui(nazd, levs+1) ! azimuthal wind - - real(kind=kind_phys) :: fden_bn(levs+1) ! density/brent - real(kind=kind_phys) :: flux (nwav, nazd) , flux_m (nwav, nazd) -! - real(kind=kind_phys) :: bn(levs+1) ! interface BV-frequency - real(kind=kind_phys) :: bn2(levs+1) ! interface BV*BV-frequency - real(kind=kind_phys) :: rhoint(levs+1) ! interface density - real(kind=kind_phys) :: uint(levs+1) ! interface zonal wind - real(kind=kind_phys) :: vint(levs+1) ! meridional wind - real(kind=kind_phys) :: tint(levs+1) ! temp-re - - real(kind=kind_phys) :: irhodz_mid(levs) - real(kind=kind_phys) :: suprf(levs+1) ! RF-super linear dissipation - real(kind=kind_phys) :: cstar(levs+1) ,cstar2(levs+1) - real(kind=kind_phys) :: v_zmet(levs+1) - real(kind=kind_phys) :: vueff(levs+1) - real(kind=kind_phys) :: dfdz_v(nazd, levs), dfdz_heat(nazd, levs) ! axj = -df*rho/dz directional Ax - - real(kind=kind_phys), dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet, dz_met - real(kind=kind_phys), dimension(levs+1) :: aprsi, azmeti, dz_meti - - real(kind=kind_phys), dimension(levs) :: wrk3 - real(kind=kind_phys), dimension(levs) :: uold, vold, told, unew, vnew, tnew - real(kind=kind_phys), dimension(levs) :: rho, rhomid, adif, cdif, acdif - real(kind=kind_phys), dimension(levs) :: Qmid, AKT - real(kind=kind_phys), dimension(levs+1) :: dktur, Ktint, Kvint - real(kind=kind_phys), dimension(levs+1) :: fden_lsat, fden_bnen - - integer, dimension(levs) :: Anstab - - real(kind=kind_phys) :: sig_u2az(nazd), sig_u2az_m(nazd) - real(kind=kind_phys) :: wave_dis(nwav, nazd), wave_disaz(nazd) - real(kind=kind_phys) :: rdci(nwav), rci(nwav) - real(kind=kind_phys) :: wave_act(nwav, nazd) ! active waves at given vert-level - real(kind=kind_phys) :: ul(nazd) ! velocity in azimuthal direction at launch level -! -! scalars -! - real(kind=kind_phys) :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level - real(kind=kind_phys) :: c2f2, cf1, wave_distot - - - real(kind=kind_phys) :: flux_norm ! norm-factor - real(kind=kind_phys) :: taub_src, rho_src, zcool, vmdiff -! - real(kind=kind_phys) :: zthm, dtau, cgz, ucrit_maxdc - real(kind=kind_phys) :: vm_zflx_mode, vc_zflx_mode - real(kind=kind_phys) :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 - real(kind=kind_phys) :: ucrit_max - real(kind=kind_phys) :: pwrms, ptrms - real(kind=kind_phys) :: zu, zcin, zcin2, zcin3, zcin4, zcinc - real(kind=kind_phys) :: zatmp, fluxs, zdep, ze1, ze2 - -! - real(kind=kind_phys) :: zdelp, zdelm, taud_min - real(kind=kind_phys) :: tvc, tvm -! real(kind=kind_phys) :: tvc, tvm, ptc, ptm - real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 - real(kind=kind_phys) :: fmode, expdis, fdis - real(kind=kind_phys) :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit - real(kind=kind_phys) :: v_wdi, v_wdpc - real(kind=kind_phys) :: ugw, vgw, ek1, ek2, rdtp, rdtp2, rhp_wam - - integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz - integer :: ksrc, km2, km1, kp1, ktop -! -! Kturb-part -! - real(kind=kind_phys) :: uz, vz, shr2 , ritur, ktur - - real(kind=kind_phys) :: kamp, zmetk, zgrow - real(kind=kind_phys) :: stab, stab_dt, dtstab - real(kind=kind_phys) :: nslope3 -! - integer :: nstab, ist - real(kind=kind_phys) :: w1, w2, w3, dtdif - - real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp - real(kind=kind_phys) :: rstar, rstar2 - - real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm - real(kind=kind_phys) :: taub_ch, sigu2_ch - real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max - real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr - -!-------------------------------------------------------------------------- -! - nslope3 = nslope + 3.0 - Pr_kdis_eff = gw_eff*pr_kdis - iPr_max = max(1.0, iPr_ktgw) - gipr = grav* Ipr_ktgw -! -! test for input fields -! if (mpi_id == master .and. kdt < -2) then -! print *, im, levs, dtp, kdt, ' vay-solv2-v1' -! print *, minval(tm), maxval(tm), ' min-max-tm ' -! print *, minval(vm), maxval(vm), ' min-max-vm ' -! print *, minval(um), maxval(um), ' min-max-um ' -! print *, minval(qm), maxval(qm), ' min-max-qm ' -! print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' -! print *, minval(prsi), maxval(prsi), ' min-max-Pint ' -! print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' -! print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' -! print *, minval(prslk), maxval(prslk), ' min-max-Exner ' -! print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' -! print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' -! -! endif - - if (idebug_gwrms == 1) then - tauabs = 0.0 ; wrms = 0.0 ; trms = 0.0 - endif - - rci(:) = 1.0 / zci(:) - rdci(:) = 1.0 / zdci(:) - - rdtp = 1.0 / dtp - rdtp2 = 0.5 * rdtp - - ksrc = max(ilaunch, 3) - km2 = ksrc - 2 - km1 = ksrc - 1 - kp1 = ksrc + 1 - ktop = levs + 1 - - suprf(ktop) = kion(levs) - - do k=1,levs - suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 - pdvdt(:,k) = 0.0 - pdudt(:,k) = 0.0 - pdtdt(:,k) = 0.0 - dked(: ,k) = 0.0 - enddo - -!----------------------------------------------------------- -! column-based j=1,im pjysics with 1D-arrays -!----------------------------------------------------------- - DO j=1, im - jl = j - tx1 = omega2 * sinlat(j) *rv_kxw - cf1 = abs(tx1) - c2f2 = tx1 * tx1 - ucrit_max = max(ucrit, cf1) - ucrit3 = ucrit_max*ucrit_max*ucrit_max -! -! ngw-fluxes at all gridpoints (with tau_min at least) -! - aprsl(1:levs) = prsl(jl,1:levs) -! -! ksrc-define "aprsi(1:levs+1) redefine "ilaunch" -! - do k=1, levs - if (aprsl(k) < psrc ) exit - enddo - ilaunch = max(k-1, 3) - ksrc = max(ilaunch, 3) - - zngw(j) = zmet(j, ksrc) - - km2 = ksrc - 2 - km1 = ksrc - 1 - kp1 = ksrc + 1 - -!=====ksrc - - do k=1, levs - aum(k) = um(jl,k) - avm(k) = vm(jl,k) - atm(k) = tm(jl,k) - aqm(k) = qm(jl,k) - azmet(k) = zmet(jl,k) - aprsi(k) = prsi(jl,k) - azmeti(k) = zmeti(jl,k) - enddo - aprsi(levs+1) = prsi(jl,levs+1) - azmeti(levs+1) = zmeti(jl,levs+1) - - rho_src = aprsl(ksrc)*rdi/atm(ksrc) - taub_ch = max(tau_ngw(jl), tau_min) - taub_src = taub_ch - - - sigu2 = zms * taub_src / (rho_src*v_kxw) - sig_u2az(1:nazd) = sigu2 -! -! compute diffusion-based arrays km2:levs -! - do jk = km2, levs - dz_meti(jk) = azmeti(jk+1) - azmeti(jk) - dz_met(jk) = azmet(jk) - azmeti(jk-1) - enddo -! --------------------------------------------- -! interface mean flow parameters launch -> levs+1 -! --------------------------------------------- - do jk= km1,levs - tvc = atm(jk) * (1.0 + fv*aqm(jk)) - tvm = atm(jk-1) * (1.0 + fv*aqm(jk-1)) -! ptc = tvc / prslk(jl,jk) ! not used -! ptm = tvm / prslk(jl,jk-1) ! notused -! - zthm = 2.0 / (tvc+tvm) - rhp_wam = zthm*gor -!interface - uint(jk) = 0.5*(aum(jk-1)+aum(jk)) - vint(jk) = 0.5*(avm(jk-1)+avm(jk)) - tint(jk) = 0.5*(tvc+tvm) - rhomid(jk) = aprsl(jk)*rdi/atm(jk) - rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) - zdelp = dz_meti(jk) ! >0 ...... dz-meters - v_zmet(jk) = zdelp + zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] - zdelm = 1.0 / dz_met(jk) ! 1/dz ...... 1/meters -! -! bvf2 = grav2*zdelm*(ptc-ptm) / (ptc + ptm) ! N2=[g/PT]*(dPT/dz) -! - bn2(jk) = grav2cpd*zthm*(1.0+rcpdl*(tvc-tvm)*zdelm) - bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) - bn(jk) = sqrt(bn2(jk)) - - - wrk3(jk) = 1.0 / (zdelp*rhomid(jk)) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] - irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src -! -! -! diagnostics -Kzz above PBL -! - uz = aum(jk) - aum(jk-1) - vz = avm(jk) - avm(jk-1) - shr2 = max(uz*uz+vz*vz, dw2min) * zdelm *zdelm - - zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 - zgrow = exp(zmetk) - ritur = bn2(jk) / shr2 - kamp = sqrt(shr2) * sc2 * zgrow - w1 = 1.0 / (1.0 + 5*ritur) - ktur = min(max(kamp * w1 * w1, dked_min), dked_max) - zmetk = azmet(jk)* rhp - vueff(jk) = ktur + kvg(jk) - - akt(jk) = gipr / tvc - enddo - - if (idebug_gwrms == 1) then - do jk= km1,levs - wrk1(jk) = rv_kxw/rhoint(jk) - wrk2(jk) = rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) - enddo - endif - -! -! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) -! - jk = levs - - rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) - tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) - uint(ktop) = aum(jk) - vint(ktop) = avm(jk) - - v_zmet(ktop) = v_zmet(jk) - vueff(ktop) = vueff(jk) - bn2(ktop) = bn2(jk) - bn(ktop) = bn(jk) -! -! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity -! - do jk=km1, levs - akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) - enddo - - - bvi = bn(ksrc); bvi2 = bvi * bvi; - bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi -! -! project winds at ksrc -! - do iaz=1, nazd - ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) - enddo -! - - do jk=ksrc, ktop - cstar(jk) = bn(jk)/zms - cstar2(jk) = cstar(jk)*cstar(jk) - - fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 - - do iaz=1, nazd - zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) - ui(iaz, jk) = zu !- ul(iaz)*0. - enddo - enddo - - rstar = 1.0 / cstar(ksrc) - rstar2 = rstar*rstar -! ----------------------------------------- -! set launch momentum flux spectral density -! ----------------------------------------- - - fpu(1:nazd, km2:ktop) = 0. - - do inc=1,nwav - - zcin = zci(inc)*rstar - -! -! integrate (flux(cin) x dcin ) old tau-flux and normalization -! - flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) -! -! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] -! - fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less - - do iaz=1,nazd - akzw(inc, iaz, ksrc) = bvi*rci(inc) - enddo - - enddo -! -! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) - - flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] - ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 - do jk=ksrc, ktop - fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 - enddo -! - do inc=1, nwav - flux(inc,1) = flux_norm*flux(inc,1) - enddo - - if (ener_norm == 1) then - snorm_ener = 0. - do inc=1,nwav - zcin = zci(inc)*rstar - ze2 = zcin / (1.0 + zcin**nslope3) - snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less - flux(inc,1) = ze2 * zcin - enddo - - ekin_norm = 1.0 / snorm_ener - -! taub_src = sigu2 * rho_src * [v_kxw / zms ] -! sigu2 = taub_src*zms/(rho_src/v_kxw) -! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns - - ze1 = taub_src*zms/bvi * ekin_norm - taub_src = 0. - - do inc=1,nwav - flux(inc,1) = ze1* flux(inc,1) - taub_src = taub_src + flux(inc,1)*zdci(inc) - enddo - ze1 = ekin_norm * v_kxw * rstar2 - do jk=ksrc, ktop - fden_bnen(jk) = rhoint(jk) / bn(jk) * ze1 ! mult on => sigu2(z)*cdf2 => flux_sat - enddo - - endif -! - do iaz=1,nazd - fpu(iaz, ksrc) = taub_src - fpu(iaz, km1) = taub_src - enddo - -! copy flux-1 into other azimuths -! -------------------------------- - - - do iaz=2, nazd - do inc=1,nwav - flux(inc,iaz) = flux(inc,1) - enddo - enddo - -! if (mpi_id == master .and. ener_norm == 1) then -! print * -! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm -! print * -! endif - - if (idebug_gwrms == 1) then - pwrms = 0. - ptrms = 0. - tx1 = real(nazd)/rhoint(ksrc)*rv_kxw - ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 - do inc=1, nwav - v_kzw = bvi*rci(inc) - ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw - pwrms = pwrms + ze1 - ptrms = ptrms + ze1 * ze2 - enddo - wrms(jl, ksrc) = pwrms - trms(jl, ksrc) = ptrms - endif - -! -------------------------------- - wave_act(:,:) = 1.0 -! vertical do-loop - do jk=ksrc, levs - - jkp = jk+1 -! azimuth do-loop - do iaz=1, nazd - - sig_u2az_m(iaz) = sig_u2az(iaz) - - umfp = ui(iaz, jkp) - umfm = ui(iaz, jk) - umfc = .5*(umfm + umfp) -! wave-cin loop - dfdz_v(iaz, jk) = 0.0 - dfdz_heat(iaz, jk) = 0.0 - fpu(iaz, jkp) = 0.0 - sig_u2az(iaz) = 0.0 -! -! wave_dis(iaz, :) = vueff(jk) - do inc=1, nwav - flux_m(inc, iaz) = flux(inc, iaz) - - zcin = zci(inc) ! zcin =/0 by definition - zcinc = rci(inc) - - if (wave_act(inc,iaz) == 1.0) then -!======================================================================= -! discrete mode -! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat -! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) -!======================================================================= - - v_cdp = zcin - umfp - v_cdp2=v_cdp*v_cdp - cdf2 = v_cdp2 - c2f2 - if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then -! -! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max, wave's absorption -! - wave_act(inc,iaz) = 0. - akzw(inc, iaz, jkp) = pi/dz_meti(jk) ! pi2/dzmet - fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) - flux(inc,iaz) = fluxs - - else - - v_wdp = v_kxw * v_cdp - wdop2 = v_wdp * v_wdp - -! -! rotational cut-off -! - kzw2 = (bn2(jkp)-wdop2)/Cdf2 -! -!cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 -! - if ( kzw2 > mkz2min ) then - v_kzw = sqrt(kzw2) - akzw(inc, iaz, jkp) = v_kzw -! -!linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 -! -!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) -! Kds_sat = kxw*Cdf1*rhp2/kzw3 -!krad, kvg, kion, ktg - v_cdp = sqrt( cdf2 ) - v_wdp = v_kxw * v_cdp - v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due for "all" vars - v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) - v_kzi = v_kzw*v_wdi/v_wdpc - -! - ze1 = v_kzi*v_zmet(jk) - - if (ze1 .ge. 1.e-2) then - expdis = max(exp(-ze1), 0.01) - else - expdis = 1.0 / (1.0 + ze1) - endif - -! - wave_act(inc,iaz) = 1.0 - fmode = flux(inc,iaz) - - flux_2_sig = v_kzw / (v_kxw*rhoint(jkp)) - w1 = v_wdpc / (kzw2*v_kzw*v_zmet(jk)) - else ! kzw2 <= mkz2min large "Lz"-reflection - - expdis = 1.0 - v_kzw = mkzmin - - v_cdp = 0. ! no effects of reflected waves - wave_act(inc,iaz) = 0.0 - akzw(inc, iaz, jkp) = v_kzw - fmode = 0. - w1 = 0. - endif - -! expdis =1.0 - - fdis = fmode*expdis*wave_act(inc,iaz) -!============================================================================== -! -! Saturated Fluxes and Energy: Spectral and Dicrete Modes -! -! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin -! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) -! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 -! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] -! -! old-sat fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) -! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) -! new sat fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) -! -! fluxs = fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) - -! -! -! old spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*sqrt(cdf2) -! new spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*cdf2*rstar2 -! [fden_bn(jkp)] = Pa/dc -! fsat = rstar*(zcin*zcin) * [taub_src / SN * [ rstar3*rho/rho_src *N_src/N] = fden_bn ] - - if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] -! -! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc -! - if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) - - if (ener_norm == 1) then - -! spectral saturation limit - - if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) - -! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc - - if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) -! - endif -!---------------------------------------------------------------------------- -! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw -! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat -! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat -!---------------------------------------------------------------------------- - zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa - if (zdep > 0.0 ) then -! subs on sat-limit - ze1 = flux(inc,iaz) - flux(inc,iaz) = fluxs - ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs - ! here we can add extra-dissip for the next layer -!Moorthi the above ze2 is not used it appears! - - else -! assign dis-ve flux - flux(inc,iaz) = fdis - endif - - dtau = flux_m(inc,iaz)-flux(inc,iaz) - if (dtau .lt. 0) then - flux(inc,iaz) = flux_m(inc,iaz) - endif -! -! GW-sponge domain: saturate all "GW"-modes above "zsp_gw" -! - if ( azmeti(jkp) >= zsp_gw) then -! mi_sponge = 0.5 / dz_meti(jk) -! ze2 = v_wdp / v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] -! v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge - - v_wdi = 0.5 * v_wdp / (v_kzw *dz_meti(jk)) + v_wdi*0.25 ! diss-sat GW-sponge - v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) - v_kzi = v_kzw*v_wdi/v_wdpc -! -! ze1 = v_kzi*v_zmet(jk) -! exp_sponge = exp(-ze1) - exp_sponge = exp(-v_kzi*v_zmet(jk)) -! -! additional sponge -! - flux(inc,iaz) = flux(inc,iaz) *exp_sponge - endif - - endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then - endif ! only for waves w/o CL-absorption wave_act=1 -! -! sum for given (jk, iaz) all active "wave" contributions -! - if (wave_act(inc,iaz) == 1) then - - zcinc = zdci(inc) - vc_zflx_mode = flux(inc,iaz) - vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) - if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) - ze1 = vc_zflx_mode*zcinc - fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at - sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! (heat deposition integration over spectral mode for each azimuth -! later sum over selected azimuths as "non-negative" scalars) -! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! zdelp = wrk3(jk)*cdf1 *zcinc - - zdelp = wrk3(jk) * v_cdp * zcinc * vmdiff - - -! zcool = 1. ! COOL=(-3.5 + Pr)/Pr -! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp -! edis = (c-u)*ax/cp = Kv_dis*N2/cp -! cool = -Kt*N2/R -! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] -! - dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 - dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 - endif !wave_act(inc,iaz) == 1) -! - enddo ! wave-inc-loop - - ze1 = fpu(iaz, jk) - if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 -! -! compute wind and temp-re rms -! - if (idebug_gwrms == 1) then - pwrms = 0. - ptrms = 0. - do inc=1, nwav - if (wave_act(inc,iaz) > 0.) then - v_kzw = akzw(inc, iaz, jk) - ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) - pwrms = pwrms + ze1 - ptrms = ptrms + ze1*wrk2(jk) - endif - enddo - Awrms(iaz, jk) = pwrms - Atrms(iaz, jk) = ptrms - endif - -! -------------- - enddo ! end Azimuth do-loop - -! -! eddy wave dissipation to limit GW-rms -! - tx1 = sum(abs(dfdz_heat(1:nazd, jk))) / bn2(jk) - ze1 = max(dked_min, tx1) - ze2 = min(dked_max, ze1) - vueff(jkp) = ze2 + vueff(jkp) -! - enddo ! end Vertical do-loop -! -! top-layers constant interface-fluxes and zero-heat -! we allow non-zero momentum fluxes and thermal effects -! fpu(1:nazd,levs+1) = fpu(1:nazd, levs) -! dfdz_v(1:nazd, levs) = 0.0 - -! --------------------------------------------------------------------- -! sum contribution for total zonal and meridional fluxes + -! energy dissipation -! --------------------------------------------------- -! -!======================================================================== -! at the source level and below taux = 0 (taux_E=-taux_W by assumption) -!======================================================================== - - do jk=ksrc, levs - taux(jk) = 0.0 - tauy(jk) = 0.0 - do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) - pdtdt(jl,jk) = pdtdt(jl,jk) + dfdz_v(iaz,jk) - dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) - enddo - enddo - jk = ktop ; taux(jk) = 0. ; tauy(jk) = 0. - do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) - enddo - - if (idebug_gwrms == 1) then - do jk=kp1, levs - do iaz=1,nazd - wrms(jl,jk) = wrms(jl,jk) + Awrms(iaz,jk) - trms(jl,jk) = trms(jl,jk) + Atrms(iaz,jk) - tauabs(jl,jk) = tauabs(jl,jk) + fpu(iaz,jk) - enddo - enddo - endif -! - - do jk=ksrc+1,levs - jkp = jk + 1 - zdelp = wrk3(jk)*gw_eff - ze1 = (taux(jkp)-taux(jk)) * zdelp - ze2 = (tauy(jkp)-tauy(jk)) * zdelp - - if (abs(ze1) >= maxdudt ) then - ze1 = sign(maxdudt, ze1) - endif - if (abs(ze2) >= maxdudt ) then - ze2 = sign(maxdudt, ze2) - endif - - pdudt(jl,jk) = -ze1 - pdvdt(jl,jk) = -ze2 -! -! Cx =0 based Cx=/= 0. above -! -! - if (knob_ugwp_doheat == 1) then -! -! maxdtdt= dked_max * bnfix2 -! - pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff - ze2 = pdtdt(jl,jk) - if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) - - dked(jl,jk) = dked(jl,jk) / bn2(jk) - ze1 = max(dked_min, dked(jl,jk)) - dked(jl,jk) = min(dked_max, ze1) - qmid(jk) = pdtdt(j,jk) - endif - enddo -!---------------------------------------------------------------------------------- -! Update heat = ek_diss/cp and aply 1-2-1 smoother for "dked" => dktur -! here with "u_new = u +dtp*dudt ; vnew = v + v +dtp*dvdt -! can check "stability" in the column and "add" ktur-estimation -! to suppress instability as needed so dked = dked_gw + ktur_ric -!---------------------------------------------------------------------------------- - - dktur(1:levs) = dked(jl,1:levs) -! - do ist= 1, nstdif - do jk=ksrc,levs-1 - adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) - enddo - dktur(ksrc:levs-1) = adif(ksrc:levs-1) - enddo - dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) - dktur(levs+1) = dktur(levs) - - do jk=ksrc,levs+1 - ze1 = .5*( dktur(jk) +dktur(jk-1) ) - kvint(jk) = ze1 - ktint(jk) = ze1*iPr_ktgw - enddo - -! -! Thermal budget qmid = qheat + qcool -! - do jk=ksrc+1,levs - ze2 = qmid(jk) + dktur(jk)*Akt(jk) + grav*(ktint(jk+1)-ktint(jk))/dz_meti(jk) - qmid(jk) = ze2 - if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) - pdtdt(jl,jk) = qmid(jk)*rcpd - dked(jl, jk) = dktur(jk) - enddo -! -! perform explicit eddy "diffusive" 3-point smoothing of "u-v-t" -! from the surface/launch-gw to the "top" -! -! - do jk=km2,levs -! update by source function X(t+dt) = X(t) + dtp * dXdt -! - uold(jk) = aum(jk) + pdudt(jl,jk) * dtp - vold(jk) = avm(jk) + pdvdt(jl,jk) * dtp - told(jk) = atm(jk) + pdtdt(jl,jk) * dtp -! -! diagnose turb-profile using "stability-check" relying on the free-atm diffusion -! sc2 = 30m x 30m -! - dktur(jk) = dked_min - enddo - - do jk=km1,levs - uz = uold(jk) - uold(jk-1) - vz = vold(jk) - vold(jk-1) - ze1 = dz_met(jk) - zdelm = 1.0 / ze1 - - tvc = told(jk) * (1. +fv*aqm(jk)) - tvm = told(jk-1) * (1. +fv*aqm(jk-1)) - zthm = 2.0 / (tvc+tvm) - shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm - - bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) - - bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) - zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 - zgrow = exp(zmetk) - ritur = bn2(jk)/shr2 - w1 = 1.0 / (1.0 + 5*ritur) - ze2 = min( sc2 *zgrow, 4.*ze1*ze1) -! -! Smag-type of eddy diffusion K_smag = Sqrt(Deformation - N2/Pr)* L2 *const -! - kamp = sqrt(shr2)* ze2 * w1 * w1 - ktur = min(max(kamp, dked_min), dked_max) - dktur(jk) = ktur -! -! update of dked = dked_gw + k_turb_mf -! - dked(jl, jk) = dked(jl, jk) +ktur - - enddo - -! -! apply eddy effects due to GWs: explicit scheme Kzz*dt/dz2 < 0.5 stability -! - if (knob_ugwp_dokdis == 2) then - - do jk=ksrc,levs - ze1 = min(.5*(dktur(jk)+dktur(jk-1)), dturb_max) - kvint(jk) = kvint(jk) + ze1 -! ktint(jk) = ktint(jk) + ze1*iPr_ktgw - enddo - kvint(km1) = kvint(ksrc) - kvint(ktop) = kvint(levs) - - dzmetm = 1./dz_met(km1) - Adif(km1:levs) = 0. - Cdif(km1:levs) = 0. - do jk=km1,levs-1 - - dzmetp = 1.0 / dz_met(jk+1) - dzmetf = 1.0 / (dz_meti(jk)*rhomid(jk)) - - - ktur = kvint(jk) * rhoint(jk) * dzmetf - kturp = Kvint(jk+1) * rhoint(jk+1) * dzmetf - - Adif(jk) = ktur * dzmetm - Cdif(jk) = kturp * dzmetp - ApC = adif(jk) + cdif(jk) - ACdif(jk) = ApC - - w1 = ApC*iPr_max - if (rdtp < w1 ) then - Anstab(jk) = floor(w1*dtp) + 1 - else - Anstab(jk) = 1 - endif - dzmetm = dzmetp - enddo - - nstab = maxval( Anstab(ksrc:levs-1)) - -! if (nstab .ge. 3) print *, 'nstab ', nstab -! -! k instead Jk -! - dtdif = dtp/real(nstab) - ze1 = 1./dtdif - - do ist= 1, nstab - do k=ksrc,levs-1 - Bdif = ze1 - ACdif(k) - Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 - unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) - vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) - tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw - enddo - - do k=ksrc,levs-1 - uold(k) = unew(k) * dtdif ! value du/dtp *dtp = du - vold(k) = vnew(k) * dtdif - told(k) = tnew(k) * dtdif - enddo -! -! smoothing the boundary points: "k-1" = ksrc-1 and "k+1" = levs -! - uold(levs) = uold(levs-1) - vold(levs) = vold(levs-1) - told(levs) = told(levs-1) - enddo -! -! compute "smoothed" tendencies by molecular + GW-eddy diffusions -! - do k=ksrc,levs-1 -! -! final updates of tendencies and diffusion -! - ze2 = rdtp * (uold(k) - aum(k)) - ze1 = rdtp * (vold(k) - avm(k)) - pdtdt(jl,k) = rdtp * (told(k) - atm(k)) - - if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) - if (abs(ze1) >= maxdudt ) then - ze1 = sign(maxdudt, ze1) - endif - if (abs(ze2) >= maxdudt ) then - ze2 = sign(maxdudt, ze2) - endif - - pdudt(jl, k) = ze2 - pdvdt(jl, k) = ze1 - uz = uold(k+1) - uold(k-1) - vz = vold(k+1) - vold(k-1) - ze2 = 1.0 / (dz_met(k+1)+dz_met(k) ) - - mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat - pdtdt(jl,k) = pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity - - enddo - - - ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t - - enddo ! J-loop -! - RETURN - -!================================= diag print after "return" ====================== - if (kdt ==1 .and. mpi_id == master) then -! - print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' - print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) - print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) -! print *, 'ugwpv1: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min - - print * - - endif - - if (kdt == 1 .and. mpi_id == master) then - print *, 'vgw done nstab ', nstab -! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' - print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' - print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' -! -! print *, ' ugwp -heating rates ' - endif -!================================= - return - end subroutine cires_ugwpv1_ngw_solv2 - - -end module cires_ugwpv1_solv2 diff --git a/physics/cires_ugwpv1_solv2.F90_orig b/physics/cires_ugwpv1_solv2.F90_orig deleted file mode 100644 index afd94ff5c..000000000 --- a/physics/cires_ugwpv1_solv2.F90_orig +++ /dev/null @@ -1,1036 +0,0 @@ -module cires_ugwpv1_solv2 - - -contains - - -!--------------------------------------------------- -! Broad spectrum FVS-1993, mkz^nSlope with nSlope = 0, 1,2 -! dissipative solver with NonHyd/ROT-effects -! reflected GWs treated as waves with "negligible" flux, -! they are out of given column -!--------------------------------------------------- - - subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & - tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & - xlatd, sinlat, coslat, & - pdudt, pdvdt, pdtdt, dked, zngw) -! -!-------------------------------------------------------------------------------- -! nov 2015 alternative gw-solver for nggps-wam -! nov 2017 nh/rotational gw-modes for nh-fv3gfs -! oct 2019 adding empirical satellite-based -! source function and *F90 CIRES-style of the code -! oct 2020 Diagnostics of "tauabs, wrms, trms" is taken out -! -------------------------------------------------------------------------------- -! - use machine, only : kind_phys - - use cires_ugwpv1_module,only : krad, kvg, kion, ktg, iPr_ktgw, Pr_kdis, Pr_kvkt - - use cires_ugwpv1_module,only : knob_ugwp_doheat, knob_ugwp_dokdis, idebug_gwrms - - use cires_ugwpv1_module,only : psrc => knob_ugwp_palaunch - - use cires_ugwpv1_module,only : maxdudt, maxdtdt, max_eps, dked_min, dked_max - - use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & - omega2, rcpd, rcpd2, pi, pi2, fv, & - rad_to_deg, deg_to_rad, & - rdi, gor, grcp, gocp, & - bnv2min, bnv2max, dw2min, velmin, gr2, & - hpscale, rhp, rh4, grav2, rgrav2, mkzmin, mkz2min -! - use ugwp_wmsdis_init, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & - gw_eff, & - nslope, ilaunch, zms, & - zci, zdci, zci4, zci3, zci2, & - zaz_fct, zcosang, zsinang, nwav, nazd, & - zcimin, zcimax, rimin, sc2, sc2u, ric -! - implicit none -! - real(kind=kind_phys), parameter :: zsp_gw = 106.5e3 ! sponge for GWs above the model top - real(kind=kind_phys), parameter :: linsat2 = 1.0, dturb_max = 100.0 - integer, parameter :: ener_norm =0 - integer, parameter :: ener_lsat=0 - integer, parameter :: nstdif = 1 - integer, parameter :: wave_sponge = 1 - - integer, intent(in) :: levs ! vertical level - integer, intent(in) :: im ! horiz tiles - integer, intent(in) :: mpi_id, master, kdt - - real(kind=kind_phys) ,intent(in) :: dtp ! model time step - real(kind=kind_phys) ,intent(in) :: tau_ngw(im) - - real(kind=kind_phys) ,intent(in) :: vm(im,levs) ! meridional wind - real(kind=kind_phys) ,intent(in) :: um(im,levs) ! zonal wind - real(kind=kind_phys) ,intent(in) :: qm(im,levs) ! spec. humidity - real(kind=kind_phys) ,intent(in) :: tm(im,levs) ! kinetic temperature - - real(kind=kind_phys) ,intent(in) :: prsl(im,levs) ! mid-layer pressure - real(kind=kind_phys) ,intent(in) :: prslk(im,levs) ! mid-layer exner function - real(kind=kind_phys) ,intent(in) :: zmet(im,levs) ! meters now !!!!! phil =philg/grav - real(kind=kind_phys) ,intent(in) :: prsi(im,levs+1) ! interface pressure - real(kind=kind_phys) ,intent(in) :: zmeti(im,levs+1) ! interface geopi/meters - real(kind=kind_phys) ,intent(in) :: xlatd(im) ! xlat_d in degrees - real(kind=kind_phys) ,intent(in) :: sinlat(im) - real(kind=kind_phys) ,intent(in) :: coslat(im) -! -! out-gw effects -! - real(kind=kind_phys) ,intent(out) :: pdudt(im,levs) ! zonal momentum tendency - real(kind=kind_phys) ,intent(out) :: pdvdt(im,levs) ! meridional momentum tendency - real(kind=kind_phys) ,intent(out) :: pdtdt(im,levs) ! gw-heating (u*ax+v*ay)/cp and cooling - real(kind=kind_phys) ,intent(out) :: dked(im,levs) ! gw-eddy diffusion - real(kind=kind_phys) ,intent(out) :: zngw(im) ! launch height -! -! -! -! local =========================================================================================== - - real(kind=kind_phys) :: tauabs(im,levs) ! - real(kind=kind_phys) :: wrms(im,levs) ! - real(kind=kind_phys) :: trms(im,levs) ! - - real(kind=kind_phys) :: zwrms(nwav,nazd), wrk1(levs), wrk2(levs) - real(kind=kind_phys) :: atrms(nazd, levs),awrms(nazd, levs), akzw(nwav,nazd, levs+1) -! -! local =========================================================================================== - real(kind=kind_phys) :: taux(levs+1) ! EW component of vertical momentum flux (pa) - real(kind=kind_phys) :: tauy(levs+1) ! NS component of vertical momentum flux (pa) - real(kind=kind_phys) :: fpu(nazd, levs+1) ! az-momentum flux - real(kind=kind_phys) :: ui(nazd, levs+1) ! azimuthal wind - - real(kind=kind_phys) :: fden_bn(levs+1) ! density/brent - real(kind=kind_phys) :: flux (nwav, nazd) , flux_m (nwav, nazd) -! - real(kind=kind_phys) :: bn(levs+1) ! interface BV-frequency - real(kind=kind_phys) :: bn2(levs+1) ! interface BV*BV-frequency - real(kind=kind_phys) :: rhoint(levs+1) ! interface density - real(kind=kind_phys) :: uint(levs+1) ! interface zonal wind - real(kind=kind_phys) :: vint(levs+1) ! meridional wind - real(kind=kind_phys) :: tint(levs+1) ! temp-re - - real(kind=kind_phys) :: irhodz_mid(levs) - real(kind=kind_phys) :: suprf(levs+1) ! RF-super linear dissipation - real(kind=kind_phys) :: cstar(levs+1) ,cstar2(levs+1) - real(kind=kind_phys) :: v_zmet(levs+1) - real(kind=kind_phys) :: vueff(levs+1) - real(kind=kind_phys) :: dfdz_v(nazd, levs), dfdz_heat(nazd, levs) ! axj = -df*rho/dz directional Ax - - real(kind=kind_phys), dimension(levs) :: atm , aum, avm, aqm, aprsl, azmet, dz_met - real(kind=kind_phys), dimension(levs+1) :: aprsi, azmeti, dz_meti - - real(kind=kind_phys), dimension(levs) :: wrk3 - real(kind=kind_phys), dimension(levs) :: uold, vold, told, unew, vnew, tnew - real(kind=kind_phys), dimension(levs) :: rho, rhomid, adif, cdif, acdif - real(kind=kind_phys), dimension(levs) :: Qmid, AKT - real(kind=kind_phys), dimension(levs+1) :: dktur, Ktint, Kvint - real(kind=kind_phys), dimension(levs+1) :: fden_lsat, fden_bnen - - integer, dimension(levs) :: Anstab - - real(kind=kind_phys) :: sig_u2az(nazd), sig_u2az_m(nazd) - real(kind=kind_phys) :: wave_dis(nwav, nazd), wave_disaz(nazd) - real(kind=kind_phys) :: rdci(nwav), rci(nwav) - real(kind=kind_phys) :: wave_act(nwav, nazd) ! active waves at given vert-level - real(kind=kind_phys) :: ul(nazd) ! velocity in azimuthal direction at launch level -! -! scalars -! - real(kind=kind_phys) :: bvi, bvi2, bvi3, bvi4, rcms ! BV at launch level - real(kind=kind_phys) :: c2f2, cf1, wave_distot - - - real(kind=kind_phys) :: flux_norm ! norm-factor - real(kind=kind_phys) :: taub_src, rho_src, zcool, vmdiff -! - real(kind=kind_phys) :: zthm, dtau, cgz, ucrit_maxdc - real(kind=kind_phys) :: vm_zflx_mode, vc_zflx_mode - real(kind=kind_phys) :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2,v_cdp2 - real(kind=kind_phys) :: ucrit_max - real(kind=kind_phys) :: pwrms, ptrms - real(kind=kind_phys) :: zu, zcin, zcin2, zcin3, zcin4, zcinc - real(kind=kind_phys) :: zatmp, fluxs, zdep, ze1, ze2 - -! - real(kind=kind_phys) :: zdelp, zdelm, taud_min - real(kind=kind_phys) :: tvc, tvm, ptc, ptm - real(kind=kind_phys) :: umfp, umfm, umfc, ucrit3 - real(kind=kind_phys) :: fmode, expdis, fdis - real(kind=kind_phys) :: v_kzi, v_kzw, v_cdp, v_wdp, tx1, fcorsat, dzcrit - real(kind=kind_phys) :: v_wdi, v_wdpc - real(kind=kind_phys) :: ugw, vgw, ek1, ek2, rdtp, rdtp2, rhp_wam - - integer :: j, jj, k, kk, inc, jk, jkp, jl, iaz - integer :: ksrc, km2, km1, kp1, ktop -! -! Kturb-part -! - real(kind=kind_phys) :: uz, vz, shr2 , ritur, ktur - - real(kind=kind_phys) :: kamp, zmetk, zgrow - real(kind=kind_phys) :: stab, stab_dt, dtstab - real(kind=kind_phys) :: nslope3 -! - integer :: nstab, ist - real(kind=kind_phys) :: w1, w2, w3, dtdif - - real(kind=kind_phys) :: dzmetm, dzmetp, dzmetf, bdif, bt_dif, apc, kturp - real(kind=kind_phys) :: rstar, rstar2 - - real(kind=kind_phys) :: snorm_ener, sigu2, flux_2_sig, ekin_norm - real(kind=kind_phys) :: taub_ch, sigu2_ch - real(kind=kind_phys) :: Pr_kdis_eff, mf_diss_heat, iPr_max - real(kind=kind_phys) :: exp_sponge, mi_sponge, gipr - -!-------------------------------------------------------------------------- -! - nslope3 = nslope + 3.0 - Pr_kdis_eff = gw_eff*pr_kdis - iPr_max = max(1.0, iPr_ktgw) - gipr = grav* Ipr_ktgw -! -! test for input fields -! if (mpi_id == master .and. kdt < -2) then -! print *, im, levs, dtp, kdt, ' vay-solv2-v1' -! print *, minval(tm), maxval(tm), ' min-max-tm ' -! print *, minval(vm), maxval(vm), ' min-max-vm ' -! print *, minval(um), maxval(um), ' min-max-um ' -! print *, minval(qm), maxval(qm), ' min-max-qm ' -! print *, minval(prsl), maxval(prsl), ' min-max-Pmid ' -! print *, minval(prsi), maxval(prsi), ' min-max-Pint ' -! print *, minval(zmet), maxval(zmet), ' min-max-Zmid ' -! print *, minval(zmeti), maxval(zmeti), ' min-max-Zint ' -! print *, minval(prslk), maxval(prslk), ' min-max-Exner ' -! print *, minval(tau_ngw), maxval(tau_ngw), ' min-max-taungw ' -! print *, tau_min, ' tau_min ', tamp_mpa, ' tamp_mpa ' -! -! endif - - if (idebug_gwrms == 1) then - tauabs=0.0; wrms =0.0 ; trms =0.0 - endif - - rci(:) = 1./zci(:) - rdci(:) = 1./zdci(:) - - rdtp = 1./dtp - rdtp2 = 0.5*rdtp - - ksrc= max(ilaunch, 3) - km2 = ksrc - 2 - km1 = ksrc - 1 - kp1 = ksrc + 1 - ktop= levs+1 - - suprf(ktop) = kion(levs) - - do k=1,levs - suprf(k) = kion(k) ! approximate 1-st order damping with Fast super-RF of FV3 - pdvdt(:,k) = 0.0 - pdudt(:,k) = 0.0 - pdtdt(:,k) = 0.0 - dked(: ,k) = 0.0 - enddo - -!----------------------------------------------------------- -! column-based j=1,im pjysics with 1D-arrays -!----------------------------------------------------------- - DO j=1, im - jl =j - tx1 = omega2 * sinlat(j) *rv_kxw - cf1 = abs(tx1) - c2f2 = tx1 * tx1 - ucrit_max = max(ucrit, cf1) - ucrit3 = ucrit_max*ucrit_max*ucrit_max -! -! ngw-fluxes at all gridpoints (with tau_min at least) -! - aprsl(1:levs) = prsl(jl,1:levs) -! -! ksrc-define "aprsi(1:levs+1) redefine "ilaunch" -! - do k=1, levs - if (aprsl(k) .lt. psrc ) exit - enddo - ilaunch = max(k-1, 3) - ksrc= max(ilaunch, 3) - - zngw(j) = zmet(j, ksrc) - - km2 = ksrc - 2 - km1 = ksrc - 1 - kp1 = ksrc + 1 - -!=====ksrc - - aum(1:levs) = um(jl,1:levs) - avm(1:levs) = vm(jl,1:levs) - atm(1:levs) = tm(jl,1:levs) - aqm(1:levs) = qm(jl,1:levs) - azmet(1:levs) = zmet(jl,1:levs) - aprsi(1:levs+1) = prsi(jl,1:levs+1) - azmeti(1:levs+1) = zmeti(jl,1:levs+1) - - rho_src = aprsl(ksrc)*rdi/atm(ksrc) - taub_ch = max(tau_ngw(jl), tau_min) - taub_src = taub_ch - - - sigu2 = taub_src/rho_src/v_kxw * zms - sig_u2az(1:nazd) = sigu2 -! -! compute diffusion-based arrays km2:levs -! - do jk = km2, levs - dz_meti(jk) = azmeti(jk+1)-azmeti(jk) - dz_met(jk) = azmet(jk)-azmeti(jk-1) - enddo -! --------------------------------------------- -! interface mean flow parameters launch -> levs+1 -! --------------------------------------------- - do jk= km1,levs - tvc = atm(jk)*(1. +fv*aqm(jk)) - tvm = atm(jk-1)*(1. +fv*aqm(jk-1)) - ptc = tvc/ prslk(jl, jk) - ptm = tvm/prslk(jl,jk-1) -! - zthm = 2.0/(tvc+tvm) - rhp_wam = zthm*gor -!interface - uint(jk) = 0.5*(aum(jk-1)+aum(jk)) - vint(jk) = 0.5*(avm(jk-1)+avm(jk)) - tint(jk) = 0.5*(tvc+tvm) - rhomid(jk) = aprsl(jk)*rdi/atm(jk) - rhoint(jk) = aprsi(jk)*rdi*zthm ! rho = p/(RTv) - zdelp = dz_meti(jk) ! >0 ...... dz-meters - v_zmet(jk) = 2.*zdelp ! 2*kzi*[Z_int(k+1)-Z_int(k)] - zdelm = 1./dz_met(jk) ! 1/dz ...... 1/meters -! -! bvf2 = grav2*zdelm*(ptc-ptm)/(ptc + ptm) ! N2=[g/PT]*(dPT/dz) -! - bn2(jk) = grav2cpd*zthm*(1.0+rcpdl*(tvc-tvm)*zdelm) - bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) - bn(jk) = sqrt(bn2(jk)) - - - wrk3(jk)= 1./zdelp/rhomid(jk) ! 1/rho_mid(k)/[Z_int(k+1)-Z_int(k)] - irhodz_mid(jk) = rdtp*zdelp*rhomid(jk)/rho_src -! -! -! diagnostics -Kzz above PBL -! - uz = aum(jk) - aum(jk-1) - vz = avm(jk) - avm(jk-1) - shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm - - zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 - zgrow = exp(zmetk) - ritur = bn2(jk)/shr2 - kamp = sqrt(shr2)*sc2 *zgrow - w1 = 1./(1. + 5*ritur) - ktur= min(max(kamp * w1 * w1, dked_min), dked_max) - zmetk = azmet(jk)* rhp - vueff(jk) = ktur + kvg(jk) - - akt(jk) = gipr/tvc - enddo - - if (idebug_gwrms == 1) then - do jk= km1,levs - wrk1(jk) = rv_kxw/rhoint(jk) - wrk2(jk)= rgrav2*zthm*zthm*bn2(jk) ! dimension [K*K]*(c2/m2) - enddo - endif - -! -! extrapolating values for ktop = levs+1 (lev-interface for prsi(levs+1) =/= 0) -! - jk = levs - - rhoint(ktop) = 0.5*aprsi(levs)*rdi/atm(jk) - tint(ktop) = atm(jk)*(1. +fv*aqm(jk)) - uint(ktop) = aum(jk) - vint(ktop) = avm(jk) - - v_zmet(ktop) = v_zmet(jk) - vueff(ktop) = vueff(jk) - bn2(ktop) = bn2(jk) - bn(ktop) = bn(jk) -! -! akt_mid *KT = -g*(1/H + 1/T*dT/dz)*KT ... grav/tvc for eddy heat conductivity -! - do jk=km1, levs - akt(jk) = -akt(jk)*(gor + (tint(jk+1)-tint(jk))/dz_meti(jk) ) - enddo - - - bvi = bn(ksrc); bvi2 = bvi * bvi; - bvi3 = bvi2*bvi; bvi4 = bvi2 * bvi2; rcms = zms/bvi -! -! project winds at ksrc -! - do iaz=1, nazd - ul(iaz) = zcosang(iaz) *uint(ksrc) + zsinang(iaz) *vint(ksrc) - enddo -! - - do jk=ksrc, ktop - cstar(jk) = bn(jk)/zms - cstar2(jk) = cstar(jk)*cstar(jk) - - fden_lsat(jk) = rhoint(jk)/bn(jk)*v_kxw*Linsat2 - - do iaz=1, nazd - zu = zcosang(iaz)*uint(jk) + zsinang(iaz)*vint(jk) - ui(iaz, jk) = zu !- ul(iaz)*0. - enddo - enddo - - rstar = 1./cstar(ksrc) - rstar2 = rstar*rstar -! ----------------------------------------- -! set launch momentum flux spectral density -! ----------------------------------------- - - fpu(1:nazd, km2:ktop) =0. - - do inc=1,nwav - - zcin = zci(inc)*rstar - -! -! integrate (flux(cin) x dcin ) old tau-flux and normalization -! - flux(inc,1) = rstar*(zcin*zcin)/(1.+ zcin**nslope3) -! -! fsat = rstar*(zcin*zcin) * taub_src / SN * [rho/rho_src *N_src/N] -! - fpu(1,ksrc) = fpu(1,ksrc) + flux(inc,1)*zdci(inc) ! dc/cstar = dim-less - - do iaz=1,nazd - akzw(inc, iaz, ksrc) = bvi*rci(inc) - enddo - - enddo -! -! adjust rho/bn vertical factors for saturated fluxes (E(m) ~m^-3) - - flux_norm = taub_src / fpu(1, ksrc) ! [Pa * dc/cstar *dim_less] - ze1 = flux_norm * bvi/rhoint(ksrc) *rstar *rstar2 - do jk=ksrc, ktop - fden_bn(jk) = ze1* rhoint(jk) / bn(jk) ! [Pa]/[m/s] * rstar2 - enddo -! - do inc=1, nwav - flux(inc,1) = flux_norm*flux(inc,1) - enddo - - - if (ener_norm == 1) then - snorm_ener = 0. - do inc=1,nwav - zcin = zci(inc)*rstar - - ze2 = zcin /(1.+ zcin**nslope3) - - snorm_ener = snorm_ener + ze2*zdci(inc)*rstar !dim-less - flux(inc,1) = ze2 * zcin - enddo - - ekin_norm = 1./snorm_ener - -! taub_src = sigu2 * rho_src * [v_kxw / zms ] -! sigu2 = taub_src*zms/(rho_src/v_kxw) -! ze1 = sigu2*ks*dens/Ns = taub*zms/Ns - - ze1 = taub_src*zms/bvi * ekin_norm - taub_src = 0. - - do inc=1,nwav - flux(inc,1) = ze1* flux(inc,1) - taub_src = taub_src + flux(inc,1)*zdci(inc) - enddo - ze1 = ekin_norm * v_kxw * rstar2 - do jk=ksrc, ktop - fden_bnen(jk) = rhoint(jk) / bn(jk) *ze1 ! mult on => sigu2(z)*cdf2 => flux_sat - enddo - - endif -! - do iaz=1,nazd - fpu(iaz, ksrc) = taub_src - fpu(iaz, km1) = taub_src - enddo - -! copy flux-1 into other azimuths -! -------------------------------- - - - do iaz=2, nazd - do inc=1,nwav - flux(inc,iaz) = flux(inc,1) - enddo - enddo - -! if (mpi_id == master .and. ener_norm == 1) then -! print * -! print *, 'vay_norm: ', taub_src, taub_ch, sigu2, flux_norm, ekin_norm -! print * -! endif - - if (idebug_gwrms == 1) then - pwrms =0. - ptrms =0. - tx1 = real(nazd)/rhoint(ksrc)*rv_kxw - ze2 = wrk2(ksrc) ! (bvi*atm(ksrc)*rgrav)**2 - do inc=1, nwav - v_kzw = bvi*rci(inc) - ze1 = flux(inc,1)*zdci(inc)*tx1*v_kzw - pwrms = pwrms + ze1 - ptrms = ptrms + ze1 * ze2 - enddo - wrms(jl, ksrc) = pwrms - trms(jl, ksrc) = ptrms - endif - -! -------------------------------- - wave_act(:,:) = 1.0 -! vertical do-loop - do jk=ksrc, levs - - jkp = jk+1 -! azimuth do-loop - do iaz=1, nazd - - sig_u2az_m(iaz) = sig_u2az(iaz) - - umfp = ui(iaz, jkp) - umfm = ui(iaz, jk) - umfc = .5*(umfm + umfp) -! wave-cin loop - dfdz_v(iaz, jk) = 0.0 - dfdz_heat(iaz, jk) = 0.0 - fpu(iaz, jkp) = 0.0 - sig_u2az(iaz) =0.0 -! -! wave_dis(iaz, :) = vueff(jk) - do inc=1, nwav - flux_m(inc, iaz) = flux(inc, iaz) - - zcin = zci(inc) ! zcin =/0 by definition - zcinc = rci(inc) - - if(wave_act(inc,iaz) == 1.0) then -!======================================================================= -! discrete mode -! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat -! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) -!======================================================================= - - v_cdp = zcin - umfp - v_cdp2=v_cdp*v_cdp - cdf2 = v_cdp2 - c2f2 - if (v_cdp .le. ucrit_max .or. cdf2 .le. 0.0) then -! -! between layer [k-1,k or jk-jkp] (Chi - Uk) -> ucrit_max, wave's absorption -! - wave_act(inc,iaz) =0. - akzw(inc, iaz, jkp) = pi/dz_meti(jk) ! pi2/dzmet - fluxs = 0.0 !max(0., rhobnk(jkp)*ucrit3)*rdci(inc) - flux(inc,iaz) = fluxs - - else - - v_wdp = v_kxw*v_cdp - wdop2 = v_wdp* v_wdp - -! -! rotational cut-off -! - kzw2 = (bn2(jkp)-wdop2)/Cdf2 -! -!cires_ugwp_initialize.F90: real, parameter :: mkzmin = pi2/80.0e3 -! - if ( kzw2 > mkz2min ) then - v_kzw = sqrt(kzw2) - akzw(inc, iaz, jkp) = v_kzw -! -!linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 -! -!kzw2 = (bn2(k)-wdop2)/Cdf2 - rhp4 - v_kx2w ! full lin DS-NGW (N2-wd2)*k2=(m2+k2+[1/2H]^2)*(wd2-f2) -! Kds_sat = kxw*Cdf1*rhp2/kzw3 -!krad, kvg, kion, ktg - v_cdp = sqrt( cdf2 ) - v_wdp = v_kxw * v_cdp - v_wdi = kzw2*vueff(jk) + kion(jk) ! supRF-diss due for "all" vars - v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) - v_kzi = v_kzw*v_wdi/v_wdpc - -! - ze1 = v_kzi*v_zmet(jk) - - if (ze1 .ge. 1.e-2) then - expdis = max(exp(-ze1), 0.01) - else - expdis = 1./(1.+ ze1) - endif - -! - wave_act(inc,iaz) = 1.0 - fmode = flux(inc,iaz) - - flux_2_sig = v_kzw/v_kxw/rhoint(jkp) - w1 = v_wdpc/kzw2/v_kzw/v_zmet(jk) - else ! kzw2 <= mkz2min large "Lz"-reflection - - expdis = 1.0 - v_kzw = mkzmin - - v_cdp = 0. ! no effects of reflected waves - wave_act(inc,iaz) = 0.0 - akzw(inc, iaz, jkp) = v_kzw - fmode = 0. - w1 =0. - endif -! expdis =1.0 - - fdis = fmode*expdis*wave_act(inc,iaz) -!============================================================================== -! -! Saturated Fluxes and Energy: Spectral and Dicrete Modes -! -! S2003 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz))**2/zcin -! WM2001 fluxs= fden_bn(jk)*(zcin-ui(jk,iaz)) -! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 -! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] -! -! old-sat fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) -! fluxs= fden_bn(jkp)*cdf2*zcinc*wave_act(inc,iaz) -! new sat fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) -! -! fluxs= fden_bn(jkp)*sqrt(cdf2)*wave_act(inc,iaz) - -! -! -! old spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*sqrt(cdf2) -! new spectral sat-limit with "mapping to source-level" sp_tau(cd) = fden_bn(jkp)*cdf2*rstar2 -! [fden_bn(jkp)] = Pa/dc -! fsat = rstar*(zcin*zcin) * [taub_src / SN * [ rstar3*rho/rho_src *N_src/N] = fden_bn ] - - if (ener_norm == 0) fluxs= fden_bn(jkp)*cdf2*wave_act(inc,iaz) ! dim-n: Pa/[m/s] -! -! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc -! - if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) - - if (ener_norm == 1) then - -! spectral saturation limit - - if (ener_lsat == 0) fluxs= fden_bnen(jk)*cdf2*wave_act(inc,iaz)*sig_u2az_m(iaz) - -! single mode saturation limit: [rho(z)/bn(z)*kx *linsat2* cd^3] /dc - - if (ener_lsat == 1) fluxs= fden_Lsat(jkp)*cdf2*sqrt(cdf2)*rdci(inc)*wave_act(inc,iaz) -! - endif -!---------------------------------------------------------------------------- -! dicrete mode saturation fden_sat(jkp) = rhoint(jkp)/bn(jkp)*v_kxw -! fluxs = fden_sat(jkp)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat -! fluxs_src = fden_sat(ksrc)*cdf2*sqrt(cdf2)/zdci(inc)*L2sat -!---------------------------------------------------------------------------- - zdep = fdis-fluxs ! dimension [Pa/dc] *dc = Pa - if(zdep > 0.0 ) then -! subs on sat-limit - ze1 = flux(inc,iaz) - flux(inc,iaz) = fluxs - ze2 = log(ze1/fluxs)*w1 ! Kdsat-compute damping of mode =>df = f-fluxs - ! here we can add extra-dissip for the next layer - else -! assign dis-ve flux - flux(inc,iaz) = fdis - endif - - dtau = flux_m(inc,iaz)-flux(inc,iaz) - if (dtau .lt. 0) then - flux(inc,iaz) = flux_m(inc,iaz) - endif -! -! GW-sponge domain: saturate all "GW"-modes above "zsp_gw" -! - if ( azmeti(jkp) .ge. zsp_gw) then - mi_sponge = .5/dz_meti(jk) - ze2 = v_wdp /v_kzw * mi_sponge ! Ksat*v_kzw2 = [mi_sat*wdp/kzw] - v_wdi = ze2 + v_wdi*0.25 ! diss-sat GW-sponge - v_wdpc = sqrt(v_wdp*v_wdp +v_wdi*v_wdi) - v_kzi = v_kzw*v_wdi/v_wdpc -! - ze1 = v_kzi*v_zmet(jk) - exp_sponge = exp(-ze1) -! -! additional sponge -! - flux(inc,iaz) = flux(inc,iaz) *exp_sponge - endif - - endif ! coriolis or CL condition-checkif => (v_cdp .le. ucrit_max) then - endif ! only for waves w/o CL-absorption wave_act=1 -! -! sum for given (jk, iaz) all active "wave" contributions -! - if (wave_act(inc,iaz) == 1) then - - zcinc =zdci(inc) - vc_zflx_mode = flux(inc,iaz) - vmdiff = max(0., flux_m(inc,iaz)-vc_zflx_mode) - if (vmdiff <= 0. ) vc_zflx_mode = flux_m(inc,iaz) - ze1 = vc_zflx_mode*zcinc - fpu(iaz, jkp) = fpu(iaz,jkp) + ze1 ! flux (pa) at - sig_u2az(iaz) = sig_u2az(iaz) + ze1*flux_2_sig ! ekin(m2/s2) at z+dz - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! (heat deposition integration over spectral mode for each azimuth -! later sum over selected azimuths as "non-negative" scalars) -! cdf1 = sqrt( (zci(inc)-umfc)**2-c2f2) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! zdelp = wrk3(jk)*cdf1 *zcinc - - zdelp = wrk3(jk)* v_cdp *zcinc * vmdiff - - -! zcool = 1. ! COOL=(-3.5 + Pr)/Pr -! zcool = [Kv/Pr]*N2*(Pr-Cp/R)/cp -! edis = (c-u)*ax/cp = Kv_dis*N2/cp -! cool = -Kt*N2/R -! add heat-conduction "bulk" impact: 1/Pr*(g*g*rho)* d [rho*Kv(dT/dp- R/Cp *T/p)] -! - dfdz_v(iaz, jk) = dfdz_v(iaz,jk) + zdelp ! +cool !heating & simple cooling < 0 - dfdz_heat(iaz, jk) = dfdz_heat(iaz,jk) + zdelp ! heating -only > 0 - endif !wave_act(inc,iaz) == 1) -! - enddo ! wave-inc-loop - - ze1 =fpu(iaz, jk) - if (fpu(iaz, jkp) > ze1 ) fpu(iaz, jkp) = ze1 -! -! compute wind and temp-re rms -! - if (idebug_gwrms == 1) then - pwrms =0. - ptrms =0. - do inc=1, nwav - if (wave_act(inc,iaz) > 0.) then - v_kzw =akzw(inc, iaz, jk) - ze1 = flux(inc,iaz)*v_kzw*zdci(inc)*wrk1(jk) - pwrms = pwrms + ze1 - ptrms = ptrms + ze1*wrk2(jk) - endif - enddo - Awrms(iaz, jk) = pwrms - Atrms(iaz, jk) = ptrms - endif - -! -------------- - enddo ! end Azimuth do-loop - -! -! eddy wave dissipation to limit GW-rms -! - tx1 = sum(abs(dfdz_heat(1:nazd, jk)))/bn2(jk) - ze1=max(dked_min, tx1) - ze2=min(dked_max, ze1) - vueff(jkp) = ze2 + vueff(jkp) -! - enddo ! end Vertical do-loop -! -! top-layers constant interface-fluxes and zero-heat -! we allow non-zero momentum fluxes and thermal effects -! fpu(1:nazd,levs+1) = fpu(1:nazd, levs) -! dfdz_v(1:nazd, levs) = 0.0 - -! --------------------------------------------------------------------- -! sum contribution for total zonal and meridional fluxes + -! energy dissipation -! --------------------------------------------------- -! -!======================================================================== -! at the source level and below taux = 0 (taux_E=-taux_W by assumption) -!======================================================================== - - do jk=ksrc, levs - taux(jk) = 0.0 - tauy(jk) = 0.0 - do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) - pdtdt(jl,jk) = pdtdt(jl,jk) + dfdz_v(iaz,jk) - dked(jl,jk) = dked(jl,jk) + dfdz_heat(iaz,jk) - enddo - enddo - jk = ktop; taux(jk)=0.; tauy(jk)=0. - do iaz=1,nazd - taux(jk) = taux(jk) + fpu(iaz,jk)*zcosang(iaz) - tauy(jk) = tauy(jk) + fpu(iaz,jk)*zsinang(iaz) - enddo - - if (idebug_gwrms == 1) then - do jk=kp1, levs - do iaz=1,nazd - wrms(jl,jk) =wrms(jl,jk) + Awrms(iaz,jk) - trms(jl,jk) =trms(jl,jk) + Atrms(iaz,jk) - tauabs(jl,jk)=tauabs(jl,jk) + fpu(iaz,jk) - enddo - enddo - endif -! - - do jk=ksrc+1,levs - jkp = jk + 1 - zdelp = wrk3(jk)*gw_eff - ze1 = (taux(jkp)-taux(jk))* zdelp - ze2 = (tauy(jkp)-tauy(jk))* zdelp - - if (abs(ze1) >= maxdudt ) then - ze1 = sign(maxdudt, ze1) - endif - if (abs(ze2) >= maxdudt ) then - ze2 = sign(maxdudt, ze2) - endif - - pdudt(jl,jk) = -ze1 - pdvdt(jl,jk) = -ze2 -! -! Cx =0 based Cx=/= 0. above -! -! - if (knob_ugwp_doheat == 1) then -! -!maxdtdt= dked_max * bnfix2 -! - pdtdt(jl,jk) = pdtdt(jl,jk)*gw_eff - ze2 = pdtdt(jl,jk) - if (abs(ze2) >= max_eps ) pdtdt(jl,jk) = sign(max_eps, ze2) - - dked(jl,jk) = dked(jl,jk)/bn2(jk) - ze1 = max(dked_min, dked(jl,jk)) - dked(jl,jk) = min(dked_max, ze1) - qmid(jk) = pdtdt(j,jk) - endif - enddo -!---------------------------------------------------------------------------------- -! Update heat = ek_diss/cp and aply 1-2-1 smoother for "dked" => dktur -! here with "u_new = u +dtp*dudt ; vnew = v + v +dtp*dvdt -! can check "stability" in the column and "add" ktur-estimation -! to suppress instability as needed so dked = dked_gw + ktur_ric -!---------------------------------------------------------------------------------- - - dktur(1:levs) = dked(jl,1:levs) -! - do ist= 1, nstdif - do jk=ksrc,levs-1 - adif(jk) =.25*(dktur(jk-1)+ dktur(jk+1)) + .5*dktur(jk) - enddo - dktur(ksrc:levs-1) = adif(ksrc:levs-1) - enddo - dktur(levs) = .5*( dked(jl,levs)+ dked(jl,levs-1)) - dktur(levs+1) = dktur(levs) - - do jk=ksrc,levs+1 - ze1 = .5*( dktur(jk) +dktur(jk-1) ) - kvint(jk) = ze1 - ktint(jk) = ze1*iPr_ktgw - enddo - -! -! Thermal budget qmid = qheat + qcool -! - do jk=ksrc+1,levs - ze2 = qmid(jk) + dktur(jk)*Akt(jk) + grav*(ktint(jk+1)-ktint(jk))/dz_meti(jk) - qmid(jk) = ze2 - if (abs(ze2) >= max_eps ) qmid(jk) = sign(max_eps, ze2) - pdtdt(jl,jk) = qmid(jk)*rcpd - dked(jl, jk) = dktur(jk) - enddo -! -! perform explicit eddy "diffusive" 3-point smoothing of "u-v-t" -! from the surface/launch-gw to the "top" -! -! -! update by source function X(t+dt) = X(t) + dtp * dXdt -! - uold(km2:levs) = aum(km2:levs)+pdudt(jl,km2:levs)*dtp - vold(km2:levs) = avm(km2:levs)+pdvdt(jl,km2:levs)*dtp - told(km2:levs) = atm(km2:levs)+pdtdt(jl,km2:levs)*dtp -! -! diagnose turb-profile using "stability-check" relying on the free-atm diffusion -! sc2 = 30m x 30m -! - dktur(km2:levs) = dked_min - - do jk=km1,levs - uz = uold(jk) - uold(jk-1) - vz = vold(jk) - vold(jk-1) - ze1 = dz_met(jk) - zdelm = 1./ze1 - - tvc = told(jk) * (1. +fv*aqm(jk)) - tvm = told(jk-1) * (1. +fv*aqm(jk-1)) - zthm = 2.0 / (tvc+tvm) - shr2 = (max(uz*uz+vz*vz, dw2min)) * zdelm *zdelm - - bn2(jk) = grav2cpd*zthm * (1.0+rcpdl*(tvc-tvm)*zdelm) - - bn2(jk) = max(min(bn2(jk), bnv2max), bnv2min) - zmetk = azmet(jk)* rh4 ! mid-layer height k_int => k_int+1 - zgrow = exp(zmetk) - ritur = bn2(jk)/shr2 - w1 = 1./(1. + 5*ritur) - ze2 = min( sc2 *zgrow, 4.*ze1*ze1) -! -! Smag-type of eddy diffusion K_smag = Sqrt(Deformation - N2/Pr)* L2 *const -! - kamp = sqrt(shr2)* ze2 * w1 * w1 - ktur= min(max(kamp, dked_min), dked_max) - dktur(jk) = ktur -! -! update of dked = dked_gw + k_turb_mf -! - dked(jl, jk) = dked(jl, jk) +ktur - - enddo - -! -! apply eddy effects due to GWs: explicit scheme Kzz*dt/dz2 < 0.5 stability -! - if (knob_ugwp_dokdis == 2) then - - do jk=ksrc,levs - ze1 = min(.5*(dktur(jk) +dktur(jk-1)), dturb_max) - kvint(jk) = kvint(jk) + ze1 -! ktint(jk) = ktint(jk) + ze1*iPr_ktgw - enddo - kvint(km1) = kvint(ksrc) - kvint(ktop) = kvint(levs) - - dzmetm = 1./dz_met(km1) - Adif(km1:levs) = 0. - Cdif(km1:levs) = 0. - do jk=km1,levs-1 - - dzmetp = 1./dz_met(jk+1) - dzmetf = 1./(dz_meti(jk)*rhomid(jk)) - - - ktur = kvint(jk) *rhoint(jk) * dzmetf - kturp =Kvint(jk+1)*rhoint(jk+1) * dzmetf - - Adif(jk) = ktur * dzmetm - Cdif(jk) = kturp * dzmetp - ApC = adif(jk)+cdif(jk) - ACdif(jk) = ApC - - w1 = ApC*iPr_max - if (rdtp < w1 ) then - Anstab(jk) = floor(w1*dtp) + 1 - else - Anstab(jk) = 1 - endif - dzmetm = dzmetp - enddo - - nstab = maxval( Anstab(ksrc:levs-1)) - -! if (nstab .ge. 3) print *, 'nstab ', nstab -! -! k instead Jk -! - dtdif = dtp/real(nstab) - ze1 = 1./dtdif - - do ist= 1, nstab - do k=ksrc,levs-1 - Bdif = ze1 - ACdif(k) - Bt_dif = ze1 - ACdif(k)* iPr_ktgw ! ipr_Ktgw = 1./Pr <1 - unew(k) = uold(k)*Bdif + uold(k-1)*Adif(k) + uold(k+1)*Cdif(k) - vnew(k) = vold(k)*Bdif + vold(k-1)*Adif(k) + vold(k+1)*Cdif(k) - tnew(k) = told(k)*Bt_dif+(told(k-1)*Adif(k) + told(k+1)*Cdif(k))*iPr_ktgw - enddo - - uold(ksrc:levs-1) = unew(ksrc:levs-1)*dtdif ! value du/dtp *dtp = du - vold(ksrc:levs-1) = vnew(ksrc:levs-1)*dtdif - told(ksrc:levs-1) = tnew(ksrc:levs-1)*dtdif -! -! smoothing the boundary points: "k-1" = ksrc-1 and "k+1" = levs -! - uold(levs) = uold(levs-1) - vold(levs) = vold(levs-1) - told(levs) = told(levs-1) - enddo -! -! compute "smoothed" tendencies by molecular + GW-eddy diffusions -! - do k=ksrc,levs-1 -! -! final updates of tendencies and diffusion -! - ze2 = rdtp*(uold(k) - aum(k)) - ze1 = rdtp*(vold(k) - avm(k)) - pdtdt(jl,k)= rdtp*( told(k) - atm(k) ) - - if (abs(pdtdt(jl,k)) >= maxdtdt ) pdtdt(jl,k) = sign(maxdtdt,pdtdt(jl,k) ) - if (abs(ze1) >= maxdudt ) then - ze1 = sign(maxdudt, ze1) - endif - if (abs(ze2) >= maxdudt ) then - ze2 = sign(maxdudt, ze2) - endif - - pdudt(jl, k) = ze2 - pdvdt(jl, k) = ze1 - uz = uold(k+1) - uold(k-1) - vz = vold(k+1) - vold(k-1) - ze2 = 1./(dz_met(k+1)+dz_met(k) ) - mf_diss_heat = rcpd*kvint(k)*(uz*uz +vz*vz)*ze2*ze2 ! vert grad heat - pdtdt(jl,k)= pdtdt(jl,k) + mf_diss_heat ! extra heat due to eddy viscosity - - enddo - - - ENDIF ! dissipative IF-loop for vertical eddy difusion u-v-t - - enddo ! J-loop -! - RETURN - -!================================= diag print after "return" ====================== - if (kdt ==1 .and. mpi_id == master) then -! - print *, ' ugwpv1: nazd-nw-ilaunch=', nazd, nwav,ilaunch, maxval(kvg), ' kvg ' - print *, 'ugwpv1: zdci(inc)=' , maxval(zdci), minval(zdci) - print *, 'ugwpv1: zcimax=' , maxval(zci) ,' zcimin=' , minval(zci) -! print *, 'ugwpv1: tau_ngw=' , maxval(taub_src)*1.e3, minval(taub_src)*1.e3, tau_min - - print * - - endif - - if (kdt == 1 .and. mpi_id == master) then - print *, 'vgw done nstab ', nstab -! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax ugwp' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay ugwp' - print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec ugwp' - print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps ugwp' -! -! print *, ' ugwp -heating rates ' - endif -!================================= - return - end subroutine cires_ugwpv1_ngw_solv2 - - -end module cires_ugwpv1_solv2 From 38a637eb34059d4414234ea213ed98b45fb684f5 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 23 Sep 2021 17:30:22 +0000 Subject: [PATCH 08/36] fixing a bug as pointed out by Tanya Smirnova --- physics/radiation_surface.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 2d0940faf..1c93e5d92 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -892,7 +892,7 @@ subroutine setemis & semis_lnd(i) = emsref(8) else tmp1 = (fracl(i)-fsno) / fracl(i) - semis_lnd(i) = semis_lnd(i) * tmp1 + (f_one-tmp1)*fsno + semis_lnd(i) = semis_lnd(i) * tmp1 + (f_one-tmp1)*fsno*emsref(8) endif endif if (fraci(i) > f_zero) then @@ -914,7 +914,7 @@ subroutine setemis & semis_lnd(i) = emsref(8) else tmp1 = (fracl(i)-fsno) / fracl(i) - semis_lnd(i) = semis_lnd(i)*tmp1 + (f_one-tmp1)*fsno + semis_lnd(i) = semis_lnd(i)*tmp1 + (f_one-tmp1)*fsno*emsref(8) endif endif if (fraci(i) > f_zero) then From 70f84bd027e77e3d71a57a69d8dee29b76415c18 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 23 Sep 2021 17:39:13 +0000 Subject: [PATCH 09/36] fixing the error in my last fix --- physics/radiation_surface.f | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 1c93e5d92..7437ca203 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -892,7 +892,8 @@ subroutine setemis & semis_lnd(i) = emsref(8) else tmp1 = (fracl(i)-fsno) / fracl(i) - semis_lnd(i) = semis_lnd(i) * tmp1 + (f_one-tmp1)*fsno*emsref(8) + semis_lnd(i) = semis_lnd(i) * tmp1 & + & + emsref(8) *(f_one-tmp1) endif endif if (fraci(i) > f_zero) then @@ -914,7 +915,8 @@ subroutine setemis & semis_lnd(i) = emsref(8) else tmp1 = (fracl(i)-fsno) / fracl(i) - semis_lnd(i) = semis_lnd(i)*tmp1 + (f_one-tmp1)*fsno*emsref(8) + semis_lnd(i) = semis_lnd(i) * tmp1 & + & + emsref(8) * (f_one-tmp1) endif endif if (fraci(i) > f_zero) then From 8eae6225d50d736a4e56341df484a7f61f68b5fa Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 23 Sep 2021 17:53:02 +0000 Subject: [PATCH 10/36] reverting a change that happened while merging with PR branch --- physics/GFS_rrtmgp_lw_post.F90 | 99 +++++++++++++++--------------- physics/GFS_rrtmgp_sw_post.F90 | 109 ++++++++++++++++++--------------- 2 files changed, 109 insertions(+), 99 deletions(-) diff --git a/physics/GFS_rrtmgp_lw_post.F90 b/physics/GFS_rrtmgp_lw_post.F90 index ff0346fe4..4bb940547 100644 --- a/physics/GFS_rrtmgp_lw_post.F90 +++ b/physics/GFS_rrtmgp_lw_post.F90 @@ -1,4 +1,4 @@ -module GFS_rrtmgp_lw_post +module GFS_rrtmgp_lw_post use machine, only: kind_phys use module_radiation_aerosols, only: NSPC1 use module_radlw_parameters, only: topflw_type, sfcflw_type, proflw_type @@ -6,9 +6,9 @@ module GFS_rrtmgp_lw_post use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_fluxes_byband, only: ty_fluxes_byband use mo_heating_rates, only: compute_heating_rate - use radiation_tools, only: check_error_msg + use radiation_tools, only: check_error_msg implicit none - + public GFS_rrtmgp_lw_post_init,GFS_rrtmgp_lw_post_run,GFS_rrtmgp_lw_post_finalize contains @@ -29,16 +29,16 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag fluxlwDOWN_clrsky, raddt, aerodp, cldsa, mtopa, mbota, cld_frac, cldtaulw, fluxr, & sfcdlw, sfculw, sfcflw, tsflw, htrlw, topflw, flxprf_lw, htrlwc, errmsg, errflg) - ! Inputs - integer, intent(in) :: & + ! Inputs + integer, intent(in) :: & nCol, & ! Horizontal loop extent nLev ! Number of vertical layers - logical, intent(in) :: & + logical, intent(in) :: & lslwr, & ! Logical flags for lw radiation calls - do_lw_clrsky_hr, & ! Output clear-sky SW heating-rate? - save_diag ! Output radiation diagnostics? + do_lw_clrsky_hr, & ! Output clear-sky SW heating-rate? + save_diag ! Output radiation diagnostics? real(kind_phys), intent(in) :: & - fhlwr ! Frequency for SW radiation + fhlwr ! Frequency for SW radiation real(kind_phys), dimension(nCol), intent(in) :: & tsfa ! Lowest model layer air temperature for radiation (K) real(kind_phys), dimension(nCol, nLev), intent(in) :: & @@ -52,25 +52,25 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag real(kind_phys), intent(in) :: & raddt ! Radiation time step real(kind_phys), dimension(nCol,NSPC1), intent(in) :: & - aerodp ! Vertical integrated optical depth for various aerosol species + aerodp ! Vertical integrated optical depth for various aerosol species real(kind_phys), dimension(nCol,5), intent(in) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL + cldsa ! Fraction of clouds for low, middle, high, total and BL integer, dimension(nCol,3), intent(in) ::& mbota, & ! vertical indices for low, middle and high cloud tops mtopa ! vertical indices for low, middle and high cloud bases real(kind_phys), dimension(nCol,nLev), intent(in) :: & cld_frac, & ! Total cloud fraction in each layer - cldtaulw ! approx 10.mu band layer cloud optical depth - + cldtaulw ! approx 10.mu band layer cloud optical depth + real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr - + ! Outputs (mandatory) real(kind_phys), dimension(nCol), intent(inout) :: & sfcdlw, & ! Total sky sfc downward lw flux (W/m2) sfculw, & ! Total sky sfc upward lw flux (W/m2) tsflw ! surface air temp during lw calculation (K) type(sfcflw_type), dimension(nCol), intent(inout) :: & - sfcflw ! LW radiation fluxes at sfc + sfcflw ! LW radiation fluxes at sfc real(kind_phys), dimension(nCol,nLev), intent(inout) :: & htrlw ! LW all-sky heating rate type(topflw_type), dimension(nCol), intent(out) :: & @@ -79,7 +79,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag errmsg integer, intent(out) :: & errflg - + ! Outputs (optional) type(proflw_type), dimension(nCol, nLev+1), optional, intent(inout) :: & flxprf_lw ! 2D radiative fluxes, components: @@ -89,7 +89,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag ! dnfx0 - clear sky dnward flux (W/m2) real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & htrlwc ! Longwave clear-sky heating-rate (K/sec) - + ! Local variables integer :: i, j, k, iSFC, iTOA, itop, ibtc logical :: l_fluxeslw2d, top_at_1 @@ -118,7 +118,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag endif ! ####################################################################################### - ! Compute LW heating-rates. + ! Compute LW heating-rates. ! ####################################################################################### ! Clear-sky heating-rate (optional) if (do_lw_clrsky_hr) then @@ -128,7 +128,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag p_lev, & ! IN - Pressure @ layer-interfaces (Pa) htrlwc)) ! OUT - Longwave clear-sky heating rate (K/sec) endif - + ! All-sky heating-rate (mandatory) call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & fluxlwUP_allsky, & ! IN - RRTMGP upward longwave all-sky flux profiles (W/m2) @@ -140,14 +140,24 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag ! Save LW outputs. ! ####################################################################################### ! Copy fluxes from RRTGMP types into model radiation types. + + do i=1,nCol ! Mandatory outputs - topflw(:)%upfxc = fluxlwUP_allsky(:,iTOA) - topflw(:)%upfx0 = fluxlwUP_clrsky(:,iTOA) - sfcflw(:)%upfxc = fluxlwUP_allsky(:,iSFC) - sfcflw(:)%upfx0 = fluxlwUP_clrsky(:,iSFC) - sfcflw(:)%dnfxc = fluxlwDOWN_allsky(:,iSFC) - sfcflw(:)%dnfx0 = fluxlwDOWN_clrsky(:,iSFC) - + topflw(i)%upfxc = fluxlwUP_allsky(i,iTOA) + topflw(i)%upfx0 = fluxlwUP_clrsky(i,iTOA) + sfcflw(i)%upfxc = fluxlwUP_allsky(i,iSFC) + sfcflw(i)%upfx0 = fluxlwUP_clrsky(i,iSFC) + sfcflw(i)%dnfxc = fluxlwDOWN_allsky(i,iSFC) + sfcflw(i)%dnfx0 = fluxlwDOWN_clrsky(i,iSFC) + + ! Save surface air temp for diurnal adjustment at model t-steps + tsflw (i) = tsfa(i) + + ! Radiation fluxes for other physics processes + sfcdlw(i) = sfcflw(i)%dnfxc + sfculw(i) = sfcflw(i)%upfxc + enddo + ! Optional outputs if(l_fluxeslw2d) then flxprf_lw%upfxc = fluxlwUP_allsky @@ -155,18 +165,11 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag flxprf_lw%upfx0 = fluxlwUP_clrsky flxprf_lw%dnfx0 = fluxlwDOWN_clrsky endif - - ! Save surface air temp for diurnal adjustment at model t-steps - tsflw (:) = tsfa(:) - - ! Radiation fluxes for other physics processes - sfcdlw(:) = sfcflw(:)%dnfxc - sfculw(:) = sfcflw(:)%upfxc ! ####################################################################################### ! Save LW diagnostics - ! - For time averaged output quantities (including total-sky and clear-sky SW and LW - ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base + ! - For time averaged output quantities (including total-sky and clear-sky SW and LW + ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base ! pressure, and cloud top temperature; aerosols AOD, etc.), store computed results in ! corresponding slots of array fluxr with appropriate time weights. ! - Collect the fluxr data for wrtsfc @@ -182,24 +185,24 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag fluxr(i,30) = fluxr(i,30) + fhlwr * fluxlwDOWN_clrsky(i,iSFC) ! clear sky sfc lw dn fluxr(i,33) = fluxr(i,33) + fhlwr * fluxlwUP_clrsky( i,iSFC) ! clear sky sfc lw up enddo - - do i=1,nCol - fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) - fluxr(i,18) = fluxr(i,18) + raddt * cldsa(i,5) - enddo + +! do i=1,nCol +! fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) +! fluxr(i,18) = fluxr(i,18) + raddt * cldsa(i,5) +! enddo ! Save cld frac,toplyr,botlyr and top temp, note that the order of h,m,l cloud is reversed for ! the fluxr output. save interface pressure (pa) of top/bot do j = 1, 3 do i = 1, nCol - tem0d = raddt * cldsa(i,j) - itop = mtopa(i,j) - ibtc = mbota(i,j) - fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d - fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop) - fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc) - fluxr(i,17-j) = fluxr(i,17-j) + tem0d * t_lay(i,itop) - +! tem0d = raddt * cldsa(i,j) +! itop = mtopa(i,j) +! ibtc = mbota(i,j) +! fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d +! fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop) +! fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc) +! fluxr(i,17-j) = fluxr(i,17-j) + tem0d * t_lay(i,itop) + ! Add optical depth and emissivity output tem2 = 0. do k=ibtc,itop diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 index 23a681826..38dbe17d5 100644 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ b/physics/GFS_rrtmgp_sw_post.F90 @@ -1,14 +1,14 @@ -module GFS_rrtmgp_sw_post +module GFS_rrtmgp_sw_post use machine, only: kind_phys use module_radiation_aerosols, only: NSPC1 use module_radsw_parameters, only: topfsw_type, sfcfsw_type, profsw_type, cmpfsw_type use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_fluxes_byband, only: ty_fluxes_byband use mo_heating_rates, only: compute_heating_rate - use radiation_tools, only: check_error_msg + use radiation_tools, only: check_error_msg use rrtmgp_sw_gas_optics, only: sw_gas_props implicit none - + public GFS_rrtmgp_sw_post_init,GFS_rrtmgp_sw_post_run,GFS_rrtmgp_sw_post_finalize contains @@ -33,23 +33,23 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky nirbmdi, nirdfdi, visbmdi, visdfdi, nirbmui, nirdfui, visbmui, visdfui, sfcnsw, & sfcdsw, htrsw, sfcfsw, topfsw, htrswc, flxprf_sw, scmpsw, errmsg, errflg) - ! Inputs - integer, intent(in) :: & - nCol, & ! Horizontal loop extent + ! Inputs + integer, intent(in) :: & + nCol, & ! Horizontal loop extent nLev, & ! Number of vertical layers nDay ! Number of daylit columns integer, intent(in), dimension(nday) :: & idxday ! Index array for daytime points - logical, intent(in) :: & - lsswr, & ! Call SW radiation? - do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? - save_diag ! Output radiation diagnostics? + logical, intent(in) :: & + lsswr, & ! Call SW radiation? + do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? + save_diag ! Output radiation diagnostics? real(kind_phys), intent(in) :: & fhswr ! Frequency for SW radiation real(kind_phys), dimension(nCol), intent(in) :: & t_lay, & ! Temperature at model layer centers (K) - coszen, & ! Cosine(SZA) - coszdg ! Cosine(SZA), daytime + coszen, & ! Cosine(SZA) + coszdg ! Cosine(SZA), daytime real(kind_phys), dimension(nCol, nLev+1), intent(in) :: & p_lev ! Pressure @ model layer-interfaces (Pa) real(kind_phys), dimension(sw_gas_props%get_nband(),ncol), intent(in) :: & @@ -65,17 +65,17 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky real(kind_phys), intent(in) :: & raddt ! Radiation time step real(kind_phys), dimension(nCol,NSPC1), intent(in) :: & - aerodp ! Vertical integrated optical depth for various aerosol species + aerodp ! Vertical integrated optical depth for various aerosol species real(kind_phys), dimension(nCol,5), intent(in) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL + cldsa ! Fraction of clouds for low, middle, high, total and BL integer, dimension(nCol,3), intent(in) ::& mbota, & ! vertical indices for low, middle and high cloud tops mtopa ! vertical indices for low, middle and high cloud bases real(kind_phys), dimension(nCol,nLev), intent(in) :: & cld_frac, & ! Total cloud fraction in each layer cldtausw ! approx .55mu band layer cloud optical depth - - ! Inputs (optional) + + ! Inputs (optional) type(cmpfsw_type), dimension(nCol), intent(inout), optional :: & scmpsw ! 2D surface fluxes, components: ! uvbfc - total sky downward uv-b flux at (W/m2) @@ -83,10 +83,10 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! nirbm - downward nir direct beam flux (W/m2) ! nirdf - downward nir diffused flux (W/m2) ! visbm - downward uv+vis direct beam flux (W/m2) - ! visdf - downward uv+vis diffused flux (W/m2) - + ! visdf - downward uv+vis diffused flux (W/m2) + real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr - + ! Outputs (mandatory) real(kind_phys), dimension(nCol), intent(inout) :: & nirbmdi, & ! sfc nir beam sw downward flux (W/m2) @@ -96,7 +96,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky nirbmui, & ! sfc nir beam sw upward flux (W/m2) nirdfui, & ! sfc nir diff sw upward flux (W/m2) visbmui, & ! sfc uv+vis beam sw upward flux (W/m2) - visdfui, & ! sfc uv+vis diff sw upward flux (W/m2) + visdfui, & ! sfc uv+vis diff sw upward flux (W/m2) sfcnsw, & ! total sky sfc netsw flx into ground sfcdsw ! real(kind_phys), dimension(nCol,nLev), intent(inout) :: & @@ -119,7 +119,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! dnfx0 - clear sky dnward flux (W/m2) real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & htrswc ! Clear-sky heating rate (K/s) - + ! Local variables integer :: i, j, k, iSFC, iTOA, itop, ibtc real(kind_phys) :: tem0d, tem1, tem2 @@ -135,7 +135,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! Are any optional outputs requested? l_fluxessw2d = present(flxprf_sw) - + ! Are the components of the surface fluxes provided? l_scmpsw = present(scmpsw) @@ -150,7 +150,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky iSFC = 1 iTOA = nLev+1 endif - + ! ####################################################################################### ! Compute SW heating-rates ! ####################################################################################### @@ -178,14 +178,17 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! Save SW outputs ! ####################################################################################### ! Copy fluxes from RRTGMP types into model radiation types. + ! Mandatory outputs - topfsw(:)%upfxc = fluxswUP_allsky(:,iTOA) - topfsw(:)%upfx0 = fluxswUP_clrsky(:,iTOA) - topfsw(:)%dnfxc = fluxswDOWN_allsky(:,iTOA) - sfcfsw(:)%upfxc = fluxswUP_allsky(:,iSFC) - sfcfsw(:)%upfx0 = fluxswUP_clrsky(:,iSFC) - sfcfsw(:)%dnfxc = fluxswDOWN_allsky(:,iSFC) - sfcfsw(:)%dnfx0 = fluxswDOWN_clrsky(:,iSFC) + do i=1,nCol + topfsw(i)%upfxc = fluxswUP_allsky(i,iTOA) + topfsw(i)%upfx0 = fluxswUP_clrsky(i,iTOA) + topfsw(i)%dnfxc = fluxswDOWN_allsky(i,iTOA) + sfcfsw(i)%upfxc = fluxswUP_allsky(i,iSFC) + sfcfsw(i)%upfx0 = fluxswUP_clrsky(i,iSFC) + sfcfsw(i)%dnfxc = fluxswDOWN_allsky(i,iSFC) + sfcfsw(i)%dnfx0 = fluxswDOWN_clrsky(i,iSFC) + enddo ! Optional output if(l_fluxessw2D) then @@ -194,10 +197,10 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky flxprf_sw(:,:)%upfx0 = fluxswUP_clrsky(:,:) flxprf_sw(:,:)%dnfx0 = fluxswDOWN_clrsky(:,:) endif - + ! Surface down and up spectral component fluxes ! - Save two spectral bands' surface downward and upward fluxes for output. - if (l_scmpsw) then + if (l_scmpsw) then do i=1,nCol nirbmdi(i) = scmpsw(i)%nirbm nirdfdi(i) = scmpsw(i)%nirdf @@ -209,15 +212,17 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(1,i) enddo else - nirbmdi(:) = 0.0 - nirdfdi(:) = 0.0 - visbmdi(:) = 0.0 - visdfdi(:) = 0.0 - nirbmui(:) = 0.0 - nirdfui(:) = 0.0 - visbmui(:) = 0.0 - visdfui(:) = 0.0 - endif + do i=1,nCol + nirbmdi(i) = 0.0 + nirdfdi(i) = 0.0 + visbmdi(i) = 0.0 + visdfdi(i) = 0.0 + nirbmui(i) = 0.0 + nirdfui(i) = 0.0 + visbmui(i) = 0.0 + visdfui(i) = 0.0 + enddo + endif else ! if_nday_block ! ####################################################################################### ! Dark everywhere @@ -225,15 +230,17 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky htrsw(:,:) = 0.0 sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) topfsw = topfsw_type( 0.0, 0.0, 0.0 ) - nirbmdi(:) = 0.0 - nirdfdi(:) = 0.0 - visbmdi(:) = 0.0 - visdfdi(:) = 0.0 - nirbmui(:) = 0.0 - nirdfui(:) = 0.0 - visbmui(:) = 0.0 - visdfui(:) = 0.0 - + do i=1,nCol + nirbmdi(i) = 0.0 + nirdfdi(i) = 0.0 + visbmdi(i) = 0.0 + visdfdi(i) = 0.0 + nirbmui(i) = 0.0 + nirdfui(i) = 0.0 + visbmui(i) = 0.0 + visdfui(i) = 0.0 + enddo + if (do_sw_clrsky_hr) then htrswc(:,:) = 0 endif @@ -279,7 +286,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky fluxr(i,27) = fluxr(i,27) + nirdfdi(i) * tem0d ! nir diff sw dn ! SW clear-sky fluxes fluxr(i,29) = fluxr(i,29) + topfsw(i)%upfx0 * tem0d - fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d + fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d fluxr(i,32) = fluxr(i,32) + sfcfsw(i)%dnfx0 * tem0d endif enddo From 32af5e9862fcd89fa3d1da9774ec20b71f7edb12 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 23 Sep 2021 18:33:33 +0000 Subject: [PATCH 11/36] just adding ablank --- physics/radiation_surface.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 7437ca203..02aa601a3 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -893,7 +893,7 @@ subroutine setemis & else tmp1 = (fracl(i)-fsno) / fracl(i) semis_lnd(i) = semis_lnd(i) * tmp1 & - & + emsref(8) *(f_one-tmp1) + & + emsref(8) * (f_one-tmp1) endif endif if (fraci(i) > f_zero) then From f506e4d2cb9d5e62f166d6f08ec4493cd17d03b3 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 24 Sep 2021 14:23:58 +0000 Subject: [PATCH 12/36] some cimin bug fix --- physics/GFS_radiation_surface.F90 | 11 +++++------ physics/radiation_surface.f | 2 +- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index 65cfe1858..fa62a67e3 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -103,8 +103,7 @@ subroutine GFS_radiation_surface_run ( & ! Local variables integer :: i real(kind=kind_phys) :: lndp_alb - real(kind=kind_phys) :: cimin - real(kind=kind_phys), dimension(im) :: fracl, fraci, fraco + real(kind=kind_phys), dimension(im) :: fracl, fraci, fraco, cimin logical, dimension(im) :: icy ! Initialize CCPP error handling variables @@ -116,9 +115,9 @@ subroutine GFS_radiation_surface_run ( & do i=1,im if (lakefrac(i) > f_zero) then - cimin = min_lakeice + cimin(i) = min_lakeice else - cimin = min_seaice + cimin(i) = min_seaice endif enddo @@ -133,7 +132,7 @@ subroutine GFS_radiation_surface_run ( & else fracl(i) = f_zero fraco(i) = f_one - if(fice(i) < cimin) then + if(fice(i) < cimin(i)) then fraci(i) = f_zero icy(i) = .false. else @@ -147,7 +146,7 @@ subroutine GFS_radiation_surface_run ( & do i=1,im fracl(i) = landfrac(i) fraco(i) = max(f_zero, f_one - fracl(i)) - if(fice(i) < cimin) then + if(fice(i) < cimin(i)) then fraci(i) = f_zero icy(i) = .false. else diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 7437ca203..02aa601a3 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -893,7 +893,7 @@ subroutine setemis & else tmp1 = (fracl(i)-fsno) / fracl(i) semis_lnd(i) = semis_lnd(i) * tmp1 & - & + emsref(8) *(f_one-tmp1) + & + emsref(8) * (f_one-tmp1) endif endif if (fraci(i) > f_zero) then From 1d3e762159044c0beebea987654f03aa78abc8e4 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 25 Sep 2021 01:15:16 +0000 Subject: [PATCH 13/36] updating radiation_surface.f --- physics/radiation_surface.f | 87 ++++++++++++++++++++----------------- 1 file changed, 48 insertions(+), 39 deletions(-) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 02aa601a3..d8231e16a 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -802,7 +802,7 @@ subroutine setemis & integer :: ivgtyp real (kind=kind_phys) :: dltg, hdlt, tmp1, tmp2, & - & asnow, argh, hrgh, fsno + & asnow, argh, hrgh, fsno, fsnol, fsnoi real (kind=kind_phys) :: sfcemis_land, sfcemis_ice ! --- reference emiss value for diff surface emiss index @@ -883,22 +883,21 @@ subroutine setemis & endif ! end if_slmsk_block !> - Check for snow covered area. - if ( sncovr(i) > f_zero ) then ! input land/ice area snow cover + if ( sncovr(i)+sncovr_ice(i) > f_zero ) then ! input land/ice area snow cover - fsno = sncovr(i) - sfcemis(i) = sfcemis(i)*(f_one - fsno) + emsref(8)*fsno - if (fracl(i) > f_zero) then - if (fracl(i) <= fsno) then - semis_lnd(i) = emsref(8) - else - tmp1 = (fracl(i)-fsno) / fracl(i) - semis_lnd(i) = semis_lnd(i) * tmp1 & - & + emsref(8) * (f_one-tmp1) - endif +! it is assume here that "snocovr" is the fraction of land covered by snow +! and "snocovr_ice" is the fraction of ice coverd by snow + + if (sncovr(i) > f_zero) then + semis_lnd(i) = semis_lnd(i) * (f_one - sncovr(i)) & + & + emsref(8) * sncovr(i) endif - if (fraci(i) > f_zero) then - semis_ice(i) = emsref(8) + if (sncovr_ice(i) > f_zero) then + semis_ice(i) = semis_ice(i) * (f_one - sncovr_ice(i)) & + & + emsref(8) * sncovr_ice(i) endif + sfcemis(i) = fracl(i)*semis_lnd(i) + fraco(i)*emsref(1) & + & + fraci(i)*semis_ice(i) else ! compute snow cover from snow depth if (abs(fraco(i)-f_one) > epsln .and. & @@ -906,23 +905,36 @@ subroutine setemis & asnow = 0.02*snowf(i) argh = min(0.50, max(.025, 0.01*zorlf(i))) hrgh = min(f_one, max(0.20, 1.0577-1.1538e-3*hprif(i) ) ) - fsno = asnow / (argh + asnow) * hrgh - - sfcemis(i) = sfcemis(i)*(f_one - fsno) + emsref(8)*fsno - - if (fracl(i) > f_zero) then - if (fracl(i) <= fsno) then - semis_lnd(i) = emsref(8) - else - tmp1 = (fracl(i)-fsno) / fracl(i) - semis_lnd(i) = semis_lnd(i) * tmp1 & - & + emsref(8) * (f_one-tmp1) + tmp1 = fracl(i) + fraci(i) + if (tmp1 > f_zero) then + fsno = min(tmp1, asnow / (argh + asnow) * hrgh) + tmp2 = fsno / tmp1 + fsnol = fracl(i) * tmp2 + fsnoi = fraci(i) * tmp2 + + + if (fracl(i) > f_zero) then + if (fracl(i) <= fsnol) then + semis_lnd(i) = emsref(8) + else + tmp1 = (fracl(i)-fsnol) / fracl(i) + semis_lnd(i) = semis_lnd(i) * tmp1 & + & + emsref(8) * (f_one-tmp1) + endif + endif + if (fraci(i) > f_zero) then + if (fraci(i) <= fsnoi) then + semis_ice(i) = emsref(8) + else + tmp1 = (fraci(i)-fsnoi) / fraci(i) + semis_ice(i) = semis_ice(i) * tmp1 & + & + emsref(8) * (f_one-tmp1) + endif endif - endif - if (fraci(i) > f_zero) then - semis_ice(i) = emsref(8) endif endif + sfcemis(i) = fracl(i)*semis_lnd(i) + fraco(i)*emsref(1) & + & + fraci(i)*semis_ice(i) endif ! end if_ialbflg @@ -932,23 +944,20 @@ subroutine setemis & do i = 1, IMAX - !-- ice emissivity - sfcemis_ice = emsref(7) + if ( icy(i) ) then !-- ice emissivity - if ( icy(i) ) then !-- complete or fractional ice if (lsm == lsm_noahmp) then - if ( snowf(i) > f_zero ) then + if (sncovr_ice(i) > f_zero) then + sfcemis_ice = emsref(7) * (f_one-sncovr_ice(i)) & + & + emsref(8) * sncovr_ice(i) + elseif (snowf(i) > f_zero) then asnow = 0.02*snowf(i) argh = min(0.50, max(.025,0.01*zorlf(i))) hrgh = min(f_one,max(0.20,1.0577-1.1538e-3*hprif(i))) fsno = asnow / (argh + asnow) * hrgh - if (fraci(i) > fsno) then - tmp1 = (fraci(i) - fsno) / fraci(i) - sfcemis_ice = sfcemis_ice*tmp1+emsref(8)*(f_one-tmp1) - else - sfcemis_ice = emsref(8) - endif + fsnoi = min(f_one, fsno / (fraci(i)+fracl(i))) + sfcemis_ice = emsref(7)*(f_one-fsnoi) + emsref(8)*fsnoi endif semis_ice(i) = sfcemis_ice elseif (lsm == lsm_ruc) then @@ -961,7 +970,7 @@ subroutine setemis & sfcemis_land = semis_lnd(i) ! albedo with snow effect from LSM !-- Composite emissivity from land, water and ice fractions. - sfcemis(i) = fracl(i)*sfcemis_land + fraco(i)*emsref(1) & + sfcemis(i) = fracl(i)*sfcemis_land + fraco(i)*emsref(1) & & + fraci(i)*sfcemis_ice enddo ! i From 34aa8c885682f8b67a2c608275398bbaaf340783 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 25 Sep 2021 01:26:00 +0000 Subject: [PATCH 14/36] updating radiation_surface.f --- physics/radiation_surface.f | 87 ++++++++++++++++++++----------------- 1 file changed, 48 insertions(+), 39 deletions(-) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 02aa601a3..d8231e16a 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -802,7 +802,7 @@ subroutine setemis & integer :: ivgtyp real (kind=kind_phys) :: dltg, hdlt, tmp1, tmp2, & - & asnow, argh, hrgh, fsno + & asnow, argh, hrgh, fsno, fsnol, fsnoi real (kind=kind_phys) :: sfcemis_land, sfcemis_ice ! --- reference emiss value for diff surface emiss index @@ -883,22 +883,21 @@ subroutine setemis & endif ! end if_slmsk_block !> - Check for snow covered area. - if ( sncovr(i) > f_zero ) then ! input land/ice area snow cover + if ( sncovr(i)+sncovr_ice(i) > f_zero ) then ! input land/ice area snow cover - fsno = sncovr(i) - sfcemis(i) = sfcemis(i)*(f_one - fsno) + emsref(8)*fsno - if (fracl(i) > f_zero) then - if (fracl(i) <= fsno) then - semis_lnd(i) = emsref(8) - else - tmp1 = (fracl(i)-fsno) / fracl(i) - semis_lnd(i) = semis_lnd(i) * tmp1 & - & + emsref(8) * (f_one-tmp1) - endif +! it is assume here that "snocovr" is the fraction of land covered by snow +! and "snocovr_ice" is the fraction of ice coverd by snow + + if (sncovr(i) > f_zero) then + semis_lnd(i) = semis_lnd(i) * (f_one - sncovr(i)) & + & + emsref(8) * sncovr(i) endif - if (fraci(i) > f_zero) then - semis_ice(i) = emsref(8) + if (sncovr_ice(i) > f_zero) then + semis_ice(i) = semis_ice(i) * (f_one - sncovr_ice(i)) & + & + emsref(8) * sncovr_ice(i) endif + sfcemis(i) = fracl(i)*semis_lnd(i) + fraco(i)*emsref(1) & + & + fraci(i)*semis_ice(i) else ! compute snow cover from snow depth if (abs(fraco(i)-f_one) > epsln .and. & @@ -906,23 +905,36 @@ subroutine setemis & asnow = 0.02*snowf(i) argh = min(0.50, max(.025, 0.01*zorlf(i))) hrgh = min(f_one, max(0.20, 1.0577-1.1538e-3*hprif(i) ) ) - fsno = asnow / (argh + asnow) * hrgh - - sfcemis(i) = sfcemis(i)*(f_one - fsno) + emsref(8)*fsno - - if (fracl(i) > f_zero) then - if (fracl(i) <= fsno) then - semis_lnd(i) = emsref(8) - else - tmp1 = (fracl(i)-fsno) / fracl(i) - semis_lnd(i) = semis_lnd(i) * tmp1 & - & + emsref(8) * (f_one-tmp1) + tmp1 = fracl(i) + fraci(i) + if (tmp1 > f_zero) then + fsno = min(tmp1, asnow / (argh + asnow) * hrgh) + tmp2 = fsno / tmp1 + fsnol = fracl(i) * tmp2 + fsnoi = fraci(i) * tmp2 + + + if (fracl(i) > f_zero) then + if (fracl(i) <= fsnol) then + semis_lnd(i) = emsref(8) + else + tmp1 = (fracl(i)-fsnol) / fracl(i) + semis_lnd(i) = semis_lnd(i) * tmp1 & + & + emsref(8) * (f_one-tmp1) + endif + endif + if (fraci(i) > f_zero) then + if (fraci(i) <= fsnoi) then + semis_ice(i) = emsref(8) + else + tmp1 = (fraci(i)-fsnoi) / fraci(i) + semis_ice(i) = semis_ice(i) * tmp1 & + & + emsref(8) * (f_one-tmp1) + endif endif - endif - if (fraci(i) > f_zero) then - semis_ice(i) = emsref(8) endif endif + sfcemis(i) = fracl(i)*semis_lnd(i) + fraco(i)*emsref(1) & + & + fraci(i)*semis_ice(i) endif ! end if_ialbflg @@ -932,23 +944,20 @@ subroutine setemis & do i = 1, IMAX - !-- ice emissivity - sfcemis_ice = emsref(7) + if ( icy(i) ) then !-- ice emissivity - if ( icy(i) ) then !-- complete or fractional ice if (lsm == lsm_noahmp) then - if ( snowf(i) > f_zero ) then + if (sncovr_ice(i) > f_zero) then + sfcemis_ice = emsref(7) * (f_one-sncovr_ice(i)) & + & + emsref(8) * sncovr_ice(i) + elseif (snowf(i) > f_zero) then asnow = 0.02*snowf(i) argh = min(0.50, max(.025,0.01*zorlf(i))) hrgh = min(f_one,max(0.20,1.0577-1.1538e-3*hprif(i))) fsno = asnow / (argh + asnow) * hrgh - if (fraci(i) > fsno) then - tmp1 = (fraci(i) - fsno) / fraci(i) - sfcemis_ice = sfcemis_ice*tmp1+emsref(8)*(f_one-tmp1) - else - sfcemis_ice = emsref(8) - endif + fsnoi = min(f_one, fsno / (fraci(i)+fracl(i))) + sfcemis_ice = emsref(7)*(f_one-fsnoi) + emsref(8)*fsnoi endif semis_ice(i) = sfcemis_ice elseif (lsm == lsm_ruc) then @@ -961,7 +970,7 @@ subroutine setemis & sfcemis_land = semis_lnd(i) ! albedo with snow effect from LSM !-- Composite emissivity from land, water and ice fractions. - sfcemis(i) = fracl(i)*sfcemis_land + fraco(i)*emsref(1) & + sfcemis(i) = fracl(i)*sfcemis_land + fraco(i)*emsref(1) & & + fraci(i)*sfcemis_ice enddo ! i From e39d4e6bf80944a9329c8eaacce7206a90a435fa Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 25 Sep 2021 23:54:35 +0000 Subject: [PATCH 15/36] fixing a typo in a comment line --- physics/radiation_surface.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index d8231e16a..3c50df6ef 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -885,8 +885,8 @@ subroutine setemis & !> - Check for snow covered area. if ( sncovr(i)+sncovr_ice(i) > f_zero ) then ! input land/ice area snow cover -! it is assume here that "snocovr" is the fraction of land covered by snow -! and "snocovr_ice" is the fraction of ice coverd by snow +! it is assume here that "sncovr" is the fraction of land covered by snow +! and "sncovr_ice" is the fraction of ice coverd by snow if (sncovr(i) > f_zero) then semis_lnd(i) = semis_lnd(i) * (f_one - sncovr(i)) & From f7d43950524f8cffe8a2698091196f419de3adbe Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 26 Sep 2021 00:14:12 +0000 Subject: [PATCH 16/36] removing some blanks and fixing a typo in comment lines --- physics/radiation_surface.f | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index d8231e16a..036e2597b 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -96,9 +96,9 @@ !! !!\version NCEP-Radiation_surface v5.1 Nov 2012 -!> This module sets up surface albedo for SW radiation and surface +!> This module sets up surface albedo for SW radiation and surface !! emissivity for LW radiation. - module module_radiation_surface + module module_radiation_surface ! !! \section arg_table_module_radiation_surface !! \htmlinclude module_radiation_surface.html @@ -631,7 +631,7 @@ subroutine setalb & ! direct asevb_ice = asevd_ice asenb_ice = asend_ice - + if (fsno0 > f_zero) then ! Snow on ice dtgd = max(f_zero, min(5.0, (con_ttp-tisfc(i)) )) @@ -647,7 +647,7 @@ subroutine setalb & asnvb = asnvd asnnb = asnnd endif - + ! composite ice and snow albedos asevd_ice = asevd_ice * (1. - fsno0) + asnvd * fsno0 asend_ice = asend_ice * (1. - fsno0) + asnnd * fsno0 @@ -885,8 +885,8 @@ subroutine setemis & !> - Check for snow covered area. if ( sncovr(i)+sncovr_ice(i) > f_zero ) then ! input land/ice area snow cover -! it is assume here that "snocovr" is the fraction of land covered by snow -! and "snocovr_ice" is the fraction of ice coverd by snow +! it is assume here that "sncovr" is the fraction of land covered by snow +! and "sncovr_ice" is the fraction of ice coverd by snow if (sncovr(i) > f_zero) then semis_lnd(i) = semis_lnd(i) * (f_one - sncovr(i)) & @@ -911,7 +911,6 @@ subroutine setemis & tmp2 = fsno / tmp1 fsnol = fracl(i) * tmp2 fsnoi = fraci(i) * tmp2 - if (fracl(i) > f_zero) then if (fracl(i) <= fsnol) then From 9e14237c5cc973a4561149cbb57faae6d18cdf54 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 26 Sep 2021 00:16:28 +0000 Subject: [PATCH 17/36] remove some blanks in radiation_surface --- physics/radiation_surface.f | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 3c50df6ef..036e2597b 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -96,9 +96,9 @@ !! !!\version NCEP-Radiation_surface v5.1 Nov 2012 -!> This module sets up surface albedo for SW radiation and surface +!> This module sets up surface albedo for SW radiation and surface !! emissivity for LW radiation. - module module_radiation_surface + module module_radiation_surface ! !! \section arg_table_module_radiation_surface !! \htmlinclude module_radiation_surface.html @@ -631,7 +631,7 @@ subroutine setalb & ! direct asevb_ice = asevd_ice asenb_ice = asend_ice - + if (fsno0 > f_zero) then ! Snow on ice dtgd = max(f_zero, min(5.0, (con_ttp-tisfc(i)) )) @@ -647,7 +647,7 @@ subroutine setalb & asnvb = asnvd asnnb = asnnd endif - + ! composite ice and snow albedos asevd_ice = asevd_ice * (1. - fsno0) + asnvd * fsno0 asend_ice = asend_ice * (1. - fsno0) + asnnd * fsno0 @@ -911,7 +911,6 @@ subroutine setemis & tmp2 = fsno / tmp1 fsnol = fracl(i) * tmp2 fsnoi = fraci(i) * tmp2 - if (fracl(i) > f_zero) then if (fracl(i) <= fsnol) then From bb59e9646a411f9da7ffc20ad1f164621c7a353d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 27 Sep 2021 18:14:36 +0000 Subject: [PATCH 18/36] fix typo in comments --- physics/radiation_surface.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 036e2597b..32682453e 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -885,8 +885,8 @@ subroutine setemis & !> - Check for snow covered area. if ( sncovr(i)+sncovr_ice(i) > f_zero ) then ! input land/ice area snow cover -! it is assume here that "sncovr" is the fraction of land covered by snow -! and "sncovr_ice" is the fraction of ice coverd by snow +! it is assumed here that "sncovr" is the fraction of land covered by snow +! and "sncovr_ice" is the fraction of ice covered by snow if (sncovr(i) > f_zero) then semis_lnd(i) = semis_lnd(i) * (f_one - sncovr(i)) & From 3618e665523f3fb41bb68347e806ac787907873c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 28 Sep 2021 16:05:16 +0000 Subject: [PATCH 19/36] updating to use estimated emissivity from the ice model when coupled --- physics/GFS_phys_time_vary.fv3.meta | 4 +- physics/GFS_radiation_surface.F90 | 6 +-- physics/GFS_radiation_surface.meta | 12 +++++- physics/GFS_surface_composites.F90 | 62 +++++++++++++---------------- physics/GFS_surface_composites.meta | 30 +------------- physics/radiation_surface.f | 55 +++++++++++++++---------- physics/sfc_drv_ruc.F90 | 8 ++-- physics/sfc_drv_ruc.meta | 13 +----- physics/sfc_sice.f | 51 ++++++++++++++---------- physics/sfc_sice.meta | 51 ++++++++++++++++++------ 10 files changed, 156 insertions(+), 136 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 3fb2473bd..b55ecda4d 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -1746,8 +1746,8 @@ intent = inout optional = F [tisfc] - standard_name = sea_ice_temperature - long_name = sea ice surface skin temperature + standard_name = surface_skin_temperature_over_ice + long_name = surface skin temperature over ice units = K dimensions = (horizontal_dimension) type = real diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index 680d1e3e5..cddcd85dd 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -60,7 +60,7 @@ subroutine GFS_radiation_surface_run ( & vtype, xlat, xlon, slmsk, lndp_type, n_var_lndp, sfc_alb_pert, & lndp_var_list, lndp_prt_list, landfrac, snowd, sncovr, & sncovr_ice, fice, zorl, hprime, tsfg, tsfa, tisfc, coszen, & - min_seaice, min_lakeice, lakefrac, & + cplice, min_seaice, min_lakeice, lakefrac, & alvsf, alnsf, alvwf, alnwf, facsf, facwf, & semis_lnd, semis_ice, snoalb, use_cice_alb, & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & @@ -74,7 +74,7 @@ subroutine GFS_radiation_surface_run ( & implicit none integer, intent(in) :: im - logical, intent(in) :: frac_grid, lslwr, lsswr, use_cice_alb + logical, intent(in) :: frac_grid, lslwr, lsswr, use_cice_alb, cplice integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc, lndp_type, n_var_lndp real(kind=kind_phys), intent(in) :: min_seaice, min_lakeice @@ -161,7 +161,7 @@ subroutine GFS_radiation_surface_run ( & !> - Call module_radiation_surface::setemis(),to set up surface !! emissivity for LW radiation. call setemis (lsm, lsm_noahmp, lsm_ruc, vtype, & - frac_grid, xlon, xlat, slmsk, & + frac_grid,cplice,lakefrac, xlon, xlat, slmsk,& ! frac_grid, min_seaice, xlon, xlat, slmsk, & snowd, sncovr, sncovr_ice, zorl, tsfg, tsfa, & hprime, semis_lnd, semis_ice, im, & diff --git a/physics/GFS_radiation_surface.meta b/physics/GFS_radiation_surface.meta index f021cfe4d..2bfe12658 100644 --- a/physics/GFS_radiation_surface.meta +++ b/physics/GFS_radiation_surface.meta @@ -279,8 +279,8 @@ intent = in optional = F [tisfc] - standard_name = sea_ice_temperature - long_name = sea ice surface skin temperature + standard_name = surface_skin_temperature_over_ice + long_name = surface_skin_temperature_over_ice units = K dimensions = (horizontal_loop_extent) type = real @@ -296,6 +296,14 @@ kind = kind_phys intent = in optional = F +[cplice] + standard_name = flag_for_sea_ice_coupling + long_name = flag controlling cplice collection (default on) + units = flag + dimensions = () + type = logical + intent = in + optional = F [min_seaice] standard_name = min_sea_ice_area_fraction long_name = minimum sea ice value diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 76da96a4c..ea67cbd43 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -33,7 +33,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & weasd, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & - tsfc_ice, tisfc, tsurf_wat, tsurf_lnd, tsurf_ice, & + tisfc, tsurf_wat, tsurf_lnd, tsurf_ice, & gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_wat, semis_lnd, semis_ice, & qss, qss_wat, qss_lnd, qss_ice, & min_lakeice, min_seaice, kdt, errmsg, errflg) @@ -52,7 +52,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra real(kind=kind_phys), dimension(:), intent(inout) :: tsfc, tsfco, tsfcl, tisfc real(kind=kind_phys), dimension(:), intent(inout) :: snowd_lnd, snowd_ice, tprcp_wat, & - tprcp_lnd, tprcp_ice, tsfc_wat, tsfc_ice, tsurf_wat,tsurf_lnd, tsurf_ice, & + tprcp_lnd, tprcp_ice, tsfc_wat, tsurf_wat,tsurf_lnd, tsurf_ice, & uustar_wat, uustar_lnd, uustar_ice, weasd_lnd, weasd_ice, & qss_wat, qss_lnd, qss_ice, ep1d_ice, gflx_ice real(kind=kind_phys), intent(in ) :: tgice @@ -236,7 +236,6 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) weasd_ice(i) = weasd(i) - tsfc_ice(i) = tisfc(i) tsurf_ice(i) = tisfc(i) ep1d_ice(i) = zero gflx_ice(i) = zero @@ -417,7 +416,8 @@ subroutine GFS_surface_composites_post_run ( cmm, cmm_wat, cmm_lnd, cmm_ice, chh, chh_wat, chh_lnd, chh_ice, gflx, gflx_wat, gflx_lnd, gflx_ice, ep1d, ep1d_wat, & ep1d_lnd, ep1d_ice, weasd, weasd_lnd, weasd_ice, snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, evap, evap_wat, evap_lnd, evap_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, qss, qss_wat, qss_lnd, & - qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_ice, tisfc, hice, cice, min_seaice, tiice, & + qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tisfc, hice, cice, tiice, & +! qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tisfc, hice, cice, min_seaice, tiice, & sigmaf, zvfun, lheatstrg, h0facu, h0facs, hflxq, hffac, stc, & grav, prsik1, prslk1, prslki, z1, ztmax_wat, ztmax_lnd, ztmax_ice, errmsg, errflg) @@ -434,7 +434,7 @@ subroutine GFS_surface_composites_post_run ( fm10_wat, fm10_lnd, fm10_ice, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, cmm_wat, cmm_lnd, cmm_ice, & chh_wat, chh_lnd, chh_ice, gflx_wat, gflx_lnd, gflx_ice, ep1d_wat, ep1d_lnd, ep1d_ice, weasd_lnd, weasd_ice, & snowd_lnd, snowd_ice, tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & - hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, tsfc_ice, zorlo, zorll, zorli, garea + hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, zorlo, zorll, zorli, garea real(kind=kind_phys), dimension(:), intent(inout) :: zorl, cd, cdq, rb, stress, ffmm, ffhh, uustar, fm10, & fh2, cmm, chh, gflx, ep1d, weasd, snowd, tprcp, evap, hflx, qss, tsfc, tsfco, tsfcl, tisfc @@ -442,7 +442,7 @@ subroutine GFS_surface_composites_post_run ( real(kind=kind_phys), dimension(:), intent(inout) :: hice, cice real(kind=kind_phys), dimension(:), intent(inout) :: sigmaf, zvfun, hflxq, hffac real(kind=kind_phys), intent(in ) :: h0facu, h0facs - real(kind=kind_phys), intent(in ) :: min_seaice +! real(kind=kind_phys), intent(in ) :: min_seaice real(kind=kind_phys), intent(in ) :: rd, rvrdm1 real(kind=kind_phys), dimension(:,:), intent(in ) :: tiice @@ -491,24 +491,24 @@ subroutine GFS_surface_composites_post_run ( ! sigmaf(i) = txl*sigmaf(i) - if (.not. flag_cice(i)) then - if (islmsk(i) == 2) then - evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) - hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) - qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) - gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) - else - evap(i) = txl*evap_lnd(i) + wfrac*evap_wat(i) - hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_wat(i) - qss(i) = txl*qss_lnd(i) + wfrac*qss_wat(i) - gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_wat(i) - endif - else +! if (.not. flag_cice(i)) then +! if (islmsk(i) == 2) then +! evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) +! hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) +! qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) +! gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) +! else +! evap(i) = txl*evap_lnd(i) + wfrac*evap_wat(i) +! hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_wat(i) +! qss(i) = txl*qss_lnd(i) + wfrac*qss_wat(i) +! gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_wat(i) +! endif +! else evap(i) = txl*evap_lnd(i) + txi*evap_ice(i) + txo*evap_wat(i) hflx(i) = txl*hflx_lnd(i) + txi*hflx_ice(i) + txo*hflx_wat(i) qss(i) = txl*qss_lnd(i) + txi*qss_ice(i) + txo*qss_wat(i) gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_wat(i) - endif +! endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Call stability for consistent surface properties. Currently this comes from ! @@ -631,12 +631,6 @@ subroutine GFS_surface_composites_post_run ( tisfc(i) = tsfcl(i) ! over land endif ! for coupled model ocean will replace this -! if (icy(i)) tisfc(i) = tsfc_ice(i) ! over ice when uncoupled -! if (icy(i)) tisfc(i) = tice(i) ! over ice when uncoupled - -! if (wet(i) .and. .not. cplflx) then -! tsfco(i) = tsfc_wat(i) ! over lake or ocean when uncoupled -! tisfc(i) = tsfc_ice(i) ! over ice when uncoupled ! endif ! if (.not. flag_cice(i)) then @@ -728,23 +722,23 @@ subroutine GFS_surface_composites_post_run ( qss(i) = qss_ice(i) evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) - tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) +! tsfc(i) = tisfc(i) ! over lake (and ocean when uncoupled) ! - if (flag_cice(i)) then - if (wet(i) .and. cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice +! if (flag_cice(i)) then +! if (wet(i) .and. cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice txi = cice(i) txo = one - txi evap(i) = txi * evap_ice(i) + txo * evap_wat(i) hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) - tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_wat(i) + tsfc(i) = txi * tisfc(i) + txo * tsfc_wat(i) stress(i) = txi * stress_ice(i) + txo * stress_wat(i) qss(i) = txi * qss_ice(i) + txo * qss_wat(i) ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) zorl(i) = exp(txi*log(zorli(i)) + txo*log(zorlo(i))) - endif - elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array - zorl(i) = exp(cice(i)*log(zorli(i)) + (one-cice(i))*log(zorlo(i))) - endif +! endif +! elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array +! zorl(i) = exp(cice(i)*log(zorli(i)) + (one-cice(i))*log(zorlo(i))) +! endif ! if (wet(i)) then tsfco(i) = tsfc_wat(i) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 1462edfb7..dfe7e5261 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -380,7 +380,7 @@ kind = kind_phys intent = inout optional = F -[tsfc_ice] +[tisfc] standard_name = surface_skin_temperature_over_ice long_name = surface skin temperature over ice units = K @@ -389,15 +389,6 @@ kind = kind_phys intent = inout optional = F -[tisfc] - standard_name = sea_ice_temperature - long_name = sea ice surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F [tsurf_wat] standard_name = surface_skin_temperature_after_iteration_over_water long_name = surface skin temperature after iteration over water @@ -1677,22 +1668,13 @@ kind = kind_phys intent = in optional = F -[tsfc_ice] +[tisfc] standard_name = surface_skin_temperature_over_ice long_name = surface skin temperature over ice units = K dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in - optional = F -[tisfc] - standard_name = sea_ice_temperature - long_name = sea ice surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys intent = inout optional = F [hice] @@ -1713,14 +1695,6 @@ kind = kind_phys intent = inout optional = F -[min_seaice] - standard_name = min_sea_ice_area_fraction - long_name = minimum sea ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in [tiice] standard_name = temperature_in_ice_layer long_name = sea ice internal temperature diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 036e2597b..0cfd9d30d 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -724,8 +724,8 @@ end subroutine setalb !! @{ !----------------------------------- subroutine setemis & - & ( lsm,lsm_noahmp,lsm_ruc,vtype,frac_grid, & ! --- inputs: - & xlon,xlat,slmsk,snowf,sncovr,sncovr_ice, & + & ( lsm,lsm_noahmp,lsm_ruc,vtype,frac_grid,cplice, & ! --- inputs: + & lakefrac,xlon,xlat,slmsk,snowf,sncovr,sncovr_ice, & & zorlf,tsknf,tairf,hprif, & & semis_lnd,semis_ice,IMAX,fracl,fraco,fraci,icy, & & semisbase, sfcemis & ! --- outputs: @@ -742,6 +742,7 @@ subroutine setemis & ! ==================== defination of variables ==================== ! ! ! ! inputs: ! +! cplice - logical, ".true." when coupled to an ice model ! ! xlon (IMAX) - longitude in radiance, ok for both 0->2pi or ! ! -pi -> +pi ranges ! ! xlat (IMAX) - latitude in radiance, default to pi/2 -> -pi/2 ! @@ -754,7 +755,8 @@ subroutine setemis & ! tsknf (IMAX) - ground surface temperature in k ! ! tairf (IMAX) - lowest model layer air temperature in k ! ! hprif (IMAX) - topographic sdv in m ! -! semis_lnd (IMAX) - emissivity from lsm ! +! semis_lnd (IMAX) - land emissivity ! +! semis_ice (IMAX) - ice emissivity ! ! IMAX - array horizontal dimension ! ! ! ! outputs: ! @@ -780,8 +782,9 @@ subroutine setemis & ! --- inputs integer, intent(in) :: IMAX integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc - logical, intent(in) :: frac_grid - real (kind=kind_phys), dimension(:), intent(in) :: vtype + logical, intent(in) :: frac_grid, cplice + real (kind=kind_phys), dimension(:), intent(in) :: vtype, & + ^ lakefrac real (kind=kind_phys), dimension(:), intent(in) :: & & xlon,xlat, slmsk, snowf,sncovr, sncovr_ice, & @@ -802,7 +805,7 @@ subroutine setemis & integer :: ivgtyp real (kind=kind_phys) :: dltg, hdlt, tmp1, tmp2, & - & asnow, argh, hrgh, fsno, fsnol, fsnoi + & asnow, argh, hrgh, fsno, fsnol, fsnoi, snowc real (kind=kind_phys) :: sfcemis_land, sfcemis_ice ! --- reference emiss value for diff surface emiss index @@ -827,7 +830,11 @@ subroutine setemis & lab_do_IMAX : do i = 1, IMAX - semis_ice(i) = emsref(7) + snowc = sncovr(i) + if (.not. cplice .or. lakefrac(i) > f_zero) then + semis_ice(i) = emsref(7) + snowc = sncovr(i) + sncovr_ice(i) + endif if (fracl(i) < epsln) then ! no land if ( abs(fraco(i)-f_one) < epsln ) then ! open water point sfcemis(i) = emsref(1) @@ -883,7 +890,8 @@ subroutine setemis & endif ! end if_slmsk_block !> - Check for snow covered area. - if ( sncovr(i)+sncovr_ice(i) > f_zero ) then ! input land/ice area snow cover + + if (snowc > f_zero) then ! input land/ice area snow cover ! it is assume here that "sncovr" is the fraction of land covered by snow ! and "sncovr_ice" is the fraction of ice coverd by snow @@ -892,7 +900,7 @@ subroutine setemis & semis_lnd(i) = semis_lnd(i) * (f_one - sncovr(i)) & & + emsref(8) * sncovr(i) endif - if (sncovr_ice(i) > f_zero) then + if (sncovr_ice(i) > f_zero .and. .not. cplice) then semis_ice(i) = semis_ice(i) * (f_one - sncovr_ice(i)) & & + emsref(8) * sncovr_ice(i) endif @@ -921,7 +929,8 @@ subroutine setemis & & + emsref(8) * (f_one-tmp1) endif endif - if (fraci(i) > f_zero) then + if (fraci(i) > f_zero .and. & + & (lakefrac(i) > f_zero .or. .not. cplice)) then if (fraci(i) <= fsnoi) then semis_ice(i) = emsref(8) else @@ -947,18 +956,22 @@ subroutine setemis & !-- complete or fractional ice if (lsm == lsm_noahmp) then - if (sncovr_ice(i) > f_zero) then - sfcemis_ice = emsref(7) * (f_one-sncovr_ice(i)) & - & + emsref(8) * sncovr_ice(i) - elseif (snowf(i) > f_zero) then - asnow = 0.02*snowf(i) - argh = min(0.50, max(.025,0.01*zorlf(i))) - hrgh = min(f_one,max(0.20,1.0577-1.1538e-3*hprif(i))) - fsno = asnow / (argh + asnow) * hrgh - fsnoi = min(f_one, fsno / (fraci(i)+fracl(i))) - sfcemis_ice = emsref(7)*(f_one-fsnoi) + emsref(8)*fsnoi + if (.not. cplice .or. lakefrac(i) > f_zero) then + if (sncovr_ice(i) > f_zero) then + sfcemis_ice = emsref(7) * (f_one-sncovr_ice(i)) & + & + emsref(8) * sncovr_ice(i) + elseif (snowf(i) > f_zero) then + asnow = 0.02*snowf(i) + argh = min(0.50, max(.025,0.01*zorlf(i))) + hrgh = min(f_one,max(0.20,1.0577-1.1538e-3*hprif(i))) + fsno = asnow / (argh + asnow) * hrgh + fsnoi = min(f_one, fsno / (fraci(i)+fracl(i))) + sfcemis_ice = emsref(7)*(f_one-fsnoi) + emsref(8)*fsnoi + endif + semis_ice(i) = sfcemis_ice + else + sfcemis_ice = semis_ice(i) ! output from CICE endif - semis_ice(i) = sfcemis_ice elseif (lsm == lsm_ruc) then sfcemis_ice = semis_ice(i) ! output from lsm (with snow effect) endif ! lsm check diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 3cfd314ff..01d692985 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -370,7 +370,8 @@ subroutine lsm_ruc_run & ! inputs & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & ! for ice & sfcqc_ice, sfcqv_ice, & - & tice, tsurf_ice, tsnow_ice, z0rl_ice, & + & tsurf_ice, tsnow_ice, z0rl_ice, & +! & tice, tsurf_ice, tsnow_ice, z0rl_ice, & & qsurf_ice, gflux_ice, evap_ice, ep1d_ice, hflx_ice, & & cm_ice, ch_ice, snowfallac_ice, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & @@ -432,7 +433,8 @@ subroutine lsm_ruc_run & ! inputs ! for ice & weasd_ice, snwdph_ice, tskin_ice, & & tsurf_ice, z0rl_ice, tsnow_ice, & - & sfcqc_ice, sfcqv_ice, fice, tice + & sfcqc_ice, sfcqv_ice, fice +! & sfcqc_ice, sfcqv_ice, fice, tice ! --- in real (kind=kind_phys), dimension(:), intent(in) :: & @@ -1466,7 +1468,7 @@ subroutine lsm_ruc_run & ! inputs if(debug_print) write (0,*)'iter run', i,j, tskin_ice(i),tsurf_ice(i) tskin_lnd(i) = tsurf_lnd(i) tskin_ice(i) = tsurf_ice(i) - tice(i) = tsurf_ice(i) +! tice(i) = tsurf_ice(i) endif ! flag_guess endif ! flag enddo ! i diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index bdb058343..a0a3768f5 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -192,8 +192,8 @@ intent = in optional = F [tsfc_ice] - standard_name = sea_ice_temperature - long_name = sea ice surface skin temperature + standard_name = surface_skin_temperature_over_ice + long_name = surface skin temperature over ice units = K dimensions = (horizontal_dimension) type = real @@ -1543,15 +1543,6 @@ kind = kind_phys intent = inout optional = F -[tice] - standard_name = sea_ice_temperature - long_name = sea ice surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F [tsurf_ice] standard_name = surface_skin_temperature_after_iteration_over_ice long_name = surface skin temperature after iteration over ice diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 176a3e8de..312c35dfa 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -46,9 +46,9 @@ subroutine sfc_sice_run & & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & & cm, ch, prsl1, prslki, prsik1, prslk1, wind, & & flag_iter, use_flake, lprnt, ipr, thsfc_loc, & - & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: - & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & - & islmsk, & + & hice, fice, tice, weasd, tsfc_wat, tprcp, tiice, ep, & ! --- input/outputs: + & snwdph, qss_i, qss_w, snowmt, gflux, cmm, chh, & + & evapi, evapw, hflxi, hflxw, islmsk, & & errmsg, errflg & ) @@ -64,9 +64,10 @@ subroutine sfc_sice_run & ! cm, ch, prsl1, prslki, prsik1, prslk1, wind, ! ! flag_iter, ! ! input/outputs: ! -! hice, fice, tice, weasd, tskin, tprcp, tiice, ep, ! +! hice, fice, tice, weasd, tsfc_wat, tprcp, tiice, ep, ! ! outputs: ! -! snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx ) ! +! snwdph, qsurf, snowmt, gflux, cmm, chh, evapi, evapw, ! +! hflxi, hflxw, ) ! ! ! ! subprogram called: ice3lay. ! ! ! @@ -170,26 +171,27 @@ subroutine sfc_sice_run & ! --- input/outputs: real (kind=kind_phys), dimension(:), intent(inout) :: hice, & - & fice, tice, weasd, tskin, tprcp, ep + & fice, tice, weasd, tsfc_wat, tprcp, ep real (kind=kind_phys), dimension(:,:), intent(inout) :: tiice ! --- outputs: real (kind=kind_phys), dimension(:), intent(inout) :: snwdph, & - & qsurf, snowmt, gflux, cmm, chh, evap, hflx + & snowmt, gflux, cmm, chh, evapi, evapw, hflxi, hflxw, & + & qss_i, qss_w character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! --- locals: - real (kind=kind_phys), dimension(im) :: ffw, evapi, evapw, & + real (kind=kind_phys), dimension(im) :: ffw, & & sneti, hfd, hfi, & ! & hflxi, hflxw, sneti, snetw, qssi, qssw, hfd, hfi, hfw, & & focn, snof, rch, rho, & & snowd, theta1 real (kind=kind_phys) :: t12, t14, tem, stsice(im,kice) - &, hflxi, hflxw, q0, qs1, qssi, qssw + &, q0, qs1, qssi, qssw real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw ! real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin logical do_sice @@ -300,7 +302,6 @@ subroutine sfc_sice_run & evapi(i) = elocp * rch(i) * (qssi - q0) evapw(i) = elocp * rch(i) * (qssw - q0) -! evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) snetw = sfcdsw(i) * (one - albfw) snetw = min(3.0_kind_phys*sfcnsw(i) & @@ -394,20 +395,25 @@ subroutine sfc_sice_run & ! --- ... calculate sensible heat flux (& evap over sea ice) if(thsfc_loc) then ! Use local potential temperature - hflxi = rch(i) * (tice(i) - theta1(i)) - hflxw = rch(i) * (tgice - theta1(i)) + hflxi(i) = rch(i) * (tice(i) - theta1(i)) + hflxw(i) = rch(i) * (tgice - theta1(i)) else ! Use potential temperature referenced to 1000 hPa - hflxi = rch(i) * (tice(i)/prsik1(i) - theta1(i)) - hflxw = rch(i) * (tgice / prsik1(i) - theta1(i)) + tem = one / prsik1(i) + hflxi(i) = rch(i) * (tice(i)*tem - theta1(i)) + hflxw(i) = rch(i) * (tgice*tem - theta1(i)) endif + tsfc_wat(i) = tgice - hflx(i) = fice(i)*hflxi + ffw(i)*hflxw - evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) - tskin(i) = fice(i)*tice(i) + ffw(i)*tgice +! hflx(i) = fice(i)*hflxi + ffw(i)*hflxw +! evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) +! tskin(i) = fice(i)*tice(i) + ffw(i)*tgice ! ! --- ... the rest of the output - qsurf(i) = q1(i) + evap(i) / (elocp*rch(i)) + qss_i(i) = q1(i) + evapi(i) / (elocp*rch(i)) + qss_w(i) = q1(i) + evapw(i) / (elocp*rch(i)) + +! qsurf(i) = q1(i) + evap(i) / (elocp*rch(i)) ! --- ... convert snow depth back to mm of water equivalent @@ -415,8 +421,13 @@ subroutine sfc_sice_run & snwdph(i) = weasd(i) * dsi ! snow depth in mm tem = one / rho(i) - hflx(i) = hflx(i) * tem * cpinv - evap(i) = evap(i) * tem * hvapi + hflxi(i) = hflxi(i) * tem * cpinv + hflxw(i) = hflxw(i) * tem * cpinv + evapi(i) = evapi(i) * tem * hvapi + evapw(i) = evapw(i) * tem * hvapi + +! hflx(i) = hflx(i) * tem * cpinv +! evap(i) = evap(i) * tem * hvapi endif enddo ! diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index de0e41de0..f87afeac0 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -316,8 +316,8 @@ intent = inout optional = F [tice] - standard_name = sea_ice_temperature - long_name = sea ice surface skin temperature + standard_name = surface_skin_temperature_over_ice + long_name = surface skin temperature over ice units = K dimensions = (horizontal_loop_extent) type = real @@ -333,14 +333,14 @@ kind = kind_phys intent = inout optional = F -[tskin] - standard_name = surface_skin_temperature_over_ice - long_name = surface skin temperature over ice +[tsfc_wat] + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water units = K dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = inout + intent = in optional = F [tprcp] standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ice @@ -378,14 +378,23 @@ kind = kind_phys intent = inout optional = F -[qsurf] +[qss_i] standard_name = surface_specific_humidity_over_ice long_name = surface air saturation specific humidity over ice units = kg kg-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = inout + intent = in + optional = F +[qss_w] + standard_name = surface_specific_humidity_over_water + long_name = surface air saturation specific humidity over water + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in optional = F [snowmt] standard_name = surface_snow_melt @@ -423,23 +432,41 @@ kind = kind_phys intent = inout optional = F -[evap] +[evapi] standard_name = kinematic_surface_upward_latent_heat_flux_over_ice long_name = kinematic surface upward latent heat flux over ice units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = inout + intent = in + optional = F +[evapw] + standard_name = kinematic_surface_upward_latent_heat_flux_over_water + long_name = kinematic surface upward latent heat flux over water + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in optional = F -[hflx] +[hflxi] standard_name = kinematic_surface_upward_sensible_heat_flux_over_ice long_name = kinematic surface upward sensible heat flux over ice units = K m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = inout + intent = in + optional = F +[hflxw] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_water + long_name = kinematic surface upward sensible heat flux over water + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in optional = F [islmsk] standard_name = sea_land_ice_mask_cice From 4d33e7160858e4e00c9dc93c778ab39c44a7bb94 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 29 Sep 2021 01:36:10 +0000 Subject: [PATCH 20/36] fixing a bug in radiation_surface.f --- physics/radiation_surface.f | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 0cfd9d30d..69b8abd85 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -952,6 +952,7 @@ subroutine setemis & do i = 1, IMAX + sfcemis_ice = emsref(7) if ( icy(i) ) then !-- ice emissivity !-- complete or fractional ice From d09eb9cedb3a09413dc754edac631b0fe6e64a48 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 29 Sep 2021 01:37:38 +0000 Subject: [PATCH 21/36] fixing a bug in radiation_surface.f --- physics/radiation_surface.f | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 0cfd9d30d..69b8abd85 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -952,6 +952,7 @@ subroutine setemis & do i = 1, IMAX + sfcemis_ice = emsref(7) if ( icy(i) ) then !-- ice emissivity !-- complete or fractional ice From 7445eb03cd4622264e1af43b81b0e264ba18b8a3 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 30 Sep 2021 00:32:48 +0000 Subject: [PATCH 22/36] making 'huge' a namelist variable --- physics/GFS_PBL_generic.F90 | 6 +- physics/GFS_PBL_generic.meta | 9 +++ physics/GFS_surface_composites.F90 | 104 ++++++++++++++-------------- physics/GFS_surface_composites.meta | 18 +++++ physics/module_MYNNPBL_wrapper.F90 | 6 +- physics/module_MYNNPBL_wrapper.meta | 9 +++ 6 files changed, 94 insertions(+), 58 deletions(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 63e622204..5bbbefe52 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -336,7 +336,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqsfc_diag, dusfci_diag, dvsfci_diag, dtsfci_diag, dqsfci_diag, & rd, cp, fvirt, hvap, t1, q1, prsl, hflx, ushfsfci, oceanfrac, kdt, dusfc_cice, dvsfc_cice, & dtsfc_cice, dqsfc_cice, wet, dry, icy, wind, stress_wat, hflx_wat, evap_wat, ugrs1, vgrs1, hffac, & - ugrs, vgrs, tgrs, qgrs, save_u, save_v, save_t, save_q, errmsg, errflg) + ugrs, vgrs, tgrs, qgrs, save_u, save_v, save_t, save_q, huge, errmsg, errflg) use machine, only : kind_phys use GFS_PBL_generic_common, only : set_aerosol_tracer_index @@ -357,7 +357,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, real(kind=kind_phys), dimension(:,:, :), intent(in) :: save_q real(kind=kind_phys), intent(in) :: dtf - real(kind=kind_phys), intent(in) :: rd, cp, fvirt, hvap + real(kind=kind_phys), intent(in) :: rd, cp, fvirt, hvap, huge real(kind=kind_phys), dimension(:), intent(in) :: t1, q1, hflx, oceanfrac real(kind=kind_phys), dimension(:,:), intent(in) :: prsl real(kind=kind_phys), dimension(:), intent(in) :: dusfc_cice, dvsfc_cice, dtsfc_cice, dqsfc_cice, & @@ -392,7 +392,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, integer, intent(out) :: errflg real(kind=kind_phys), parameter :: zero = 0.0_kp, one = 1.0_kp - real(kind=kind_phys), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue, same as in GFS_typedefs.F90 +! real(kind=kind_phys), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue, same as in GFS_typedefs.F90 real(kind=kind_phys), parameter :: qmin = 1.0e-8_kp integer :: i, k, kk, k1, n real(kind=kind_phys) :: tem, rho diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 59501e467..2dc2d3be7 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -1383,6 +1383,15 @@ kind = kind_phys intent = in optional = F +[huge] + standard_name = netcdf_float_fillvalue + long_name = definition of NetCDF float FillValue + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index ea67cbd43..cbdb2052c 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -14,7 +14,7 @@ module GFS_surface_composites_pre 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), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue +! real(kind=kind_phys), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue contains @@ -36,7 +36,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra tisfc, tsurf_wat, tsurf_lnd, tsurf_ice, & gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_wat, semis_lnd, semis_ice, & qss, qss_wat, qss_lnd, qss_ice, & - min_lakeice, min_seaice, kdt, errmsg, errflg) + min_lakeice, min_seaice, kdt, huge, errmsg, errflg) implicit none @@ -58,7 +58,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra real(kind=kind_phys), intent(in ) :: tgice integer, dimension(:), intent(inout) :: islmsk, islmsk_cice real(kind=kind_phys), dimension(:), intent(inout) :: semis_wat, semis_lnd, semis_ice, slmsk - real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice + real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice, huge ! real(kind=kind_phys), dimension(:), intent(inout) :: zorlo, zorll, zorli ! @@ -419,7 +419,7 @@ subroutine GFS_surface_composites_post_run ( qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tisfc, hice, cice, tiice, & ! qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tisfc, hice, cice, min_seaice, tiice, & sigmaf, zvfun, lheatstrg, h0facu, h0facs, hflxq, hffac, stc, & - grav, prsik1, prslk1, prslki, z1, ztmax_wat, ztmax_lnd, ztmax_ice, errmsg, errflg) + grav, prsik1, prslk1, prslki, z1, ztmax_wat, ztmax_lnd, ztmax_ice, huge, errmsg, errflg) implicit none @@ -443,16 +443,16 @@ subroutine GFS_surface_composites_post_run ( real(kind=kind_phys), dimension(:), intent(inout) :: sigmaf, zvfun, hflxq, hffac real(kind=kind_phys), intent(in ) :: h0facu, h0facs ! real(kind=kind_phys), intent(in ) :: min_seaice - real(kind=kind_phys), intent(in ) :: rd, rvrdm1 + real(kind=kind_phys), intent(in ) :: rd, rvrdm1, huge real(kind=kind_phys), dimension(:,:), intent(in ) :: tiice real(kind=kind_phys), dimension(:,:), intent(inout) :: stc ! Additional data needed for calling "stability" - logical, intent(in ) :: thsfc_loc - real(kind=kind_phys), intent(in ) :: grav - real(kind=kind_phys), dimension(:), intent(in ) :: prsik1, prslk1, prslki, z1 - real(kind=kind_phys), dimension(:), intent(in ) :: ztmax_wat, ztmax_lnd, ztmax_ice + logical, intent(in ) :: thsfc_loc + real(kind=kind_phys), intent(in ) :: grav + real(kind=kind_phys), dimension(:), intent(in ) :: prsik1, prslk1, prslki, z1 + real(kind=kind_phys), dimension(:), intent(in ) :: ztmax_wat, ztmax_lnd, ztmax_ice character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -462,6 +462,7 @@ subroutine GFS_surface_composites_post_run ( real(kind=kind_phys) :: txl, txi, txo, wfrac, q0, rho ! For calling "stability" real(kind=kind_phys) :: tsurf, virtfac, tv1, thv1, tvs, z0max, ztmax + real(kind=kind_phys) :: lnzorll, lnzorli, lnzorlo ! real(kind=kind_phys) :: tem1, tem2, gdx real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 @@ -483,32 +484,18 @@ subroutine GFS_surface_composites_post_run ( txi = cice(i) * wfrac ! txi = ice fraction wrt whole cell txo = max(zero, wfrac-txi) ! txo = open water fraction - !gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_wat(i) - ep1d(i) = txl*ep1d_lnd(i) + txi*ep1d_ice(i) + txo*ep1d_wat(i) - weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) - snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) - !tprcp(i) = txl*tprcp_lnd(i) + txi*tprcp_ice(i) + txo*tprcp_wat(i) + !gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_wat(i) + ep1d(i) = txl*ep1d_lnd(i) + txi*ep1d_ice(i) + txo*ep1d_wat(i) + weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) + snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) + !tprcp(i) = txl*tprcp_lnd(i) + txi*tprcp_ice(i) + txo*tprcp_wat(i) ! sigmaf(i) = txl*sigmaf(i) -! if (.not. flag_cice(i)) then -! if (islmsk(i) == 2) then -! evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) -! hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) -! qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) -! gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) -! else -! evap(i) = txl*evap_lnd(i) + wfrac*evap_wat(i) -! hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_wat(i) -! qss(i) = txl*qss_lnd(i) + wfrac*qss_wat(i) -! gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_wat(i) -! endif -! else - evap(i) = txl*evap_lnd(i) + txi*evap_ice(i) + txo*evap_wat(i) - hflx(i) = txl*hflx_lnd(i) + txi*hflx_ice(i) + txo*hflx_wat(i) - qss(i) = txl*qss_lnd(i) + txi*qss_ice(i) + txo*qss_wat(i) - gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_wat(i) -! endif + evap(i) = txl*evap_lnd(i) + txi*evap_ice(i) + txo*evap_wat(i) + hflx(i) = txl*hflx_lnd(i) + txi*hflx_ice(i) + txo*hflx_wat(i) + qss(i) = txl*qss_lnd(i) + txi*qss_ice(i) + txo*qss_wat(i) + gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_wat(i) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Call stability for consistent surface properties. Currently this comes from ! @@ -537,12 +524,23 @@ subroutine GFS_surface_composites_post_run ( tvs = half * (tsfc(i)+tsurf)/prsik1(i) * virtfac endif - zorl(i) = exp(txl*log(zorll(i)) + txi*log(zorli(i)) + txo*log(zorlo(i))) + lnzorll = zero ; lnzorli = zero ; lnzorlo = zero + if (zorll(i) /= huge) then + lnzorll = log(zorll(i)) + endif + if (zorli(i) /= huge) then + lnzorli = log(zorli(i)) + endif + if (zorlo(i) /= huge) then + lnzorlo = log(zorlo(i)) + endif + zorl(i) = exp(txl*lnzorll + txi*lnzorli + txo*lnzorlo) + ! zorl(i) = exp(txl*log(zorll(i)) + txi*log(zorli(i)) + txo*log(zorlo(i))) z0max = 0.01_kind_phys * zorl(i) ztmax = exp(txl*log(ztmax_lnd(i)) + txi*log(ztmax_ice(i)) + txo*log(ztmax_wat(i))) ! Only actually need to call "stability" if multiple surface types exist... - if(txl .eq. one) then ! 100% land + if(txl == one) then ! 100% land rb(i) = rb_lnd(i) ffmm(i) = ffmm_lnd(i) ffhh(i) = ffhh_lnd(i) @@ -552,7 +550,7 @@ subroutine GFS_surface_composites_post_run ( cdq(i) = cdq_lnd(i) stress(i) = stress_lnd(i) uustar(i) = uustar_lnd(i) - elseif(txo .eq. one) then ! 100% open water + elseif(txo == one) then ! 100% open water rb(i) = rb_wat(i) ffmm(i) = ffmm_wat(i) ffhh(i) = ffhh_wat(i) @@ -562,7 +560,7 @@ subroutine GFS_surface_composites_post_run ( cdq(i) = cdq_wat(i) stress(i) = stress_wat(i) uustar(i) = uustar_wat(i) - elseif(txi .eq. one) then ! 100% ice + elseif(txi == one) then ! 100% ice rb(i) = rb_ice(i) ffmm(i) = ffmm_ice(i) ffhh(i) = ffhh_ice(i) @@ -722,23 +720,25 @@ subroutine GFS_surface_composites_post_run ( qss(i) = qss_ice(i) evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) -! tsfc(i) = tisfc(i) ! over lake (and ocean when uncoupled) ! -! if (flag_cice(i)) then -! if (wet(i) .and. cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice - txi = cice(i) - txo = one - txi - evap(i) = txi * evap_ice(i) + txo * evap_wat(i) - hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) - tsfc(i) = txi * tisfc(i) + txo * tsfc_wat(i) - stress(i) = txi * stress_ice(i) + txo * stress_wat(i) - qss(i) = txi * qss_ice(i) + txo * qss_wat(i) - ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) - zorl(i) = exp(txi*log(zorli(i)) + txo*log(zorlo(i))) -! endif -! elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array -! zorl(i) = exp(cice(i)*log(zorli(i)) + (one-cice(i))*log(zorlo(i))) -! endif + txi = cice(i) + txo = one - txi + evap(i) = txi * evap_ice(i) + txo * evap_wat(i) + hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) + tsfc(i) = txi * tisfc(i) + txo * tsfc_wat(i) + stress(i) = txi * stress_ice(i) + txo * stress_wat(i) + qss(i) = txi * qss_ice(i) + txo * qss_wat(i) + ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) + + lnzorli = zero ; lnzorlo = zero + if (zorli(i) /= huge) then + lnzorli = log(zorli(i)) + endif + if (zorlo(i) /= huge) then + lnzorlo = log(zorlo(i)) + endif + zorl(i) = exp(txi*lnzorli + txo*lnzorlo) +! zorl(i) = exp(txi*log(zorli(i)) + txo*log(zorlo(i))) ! if (wet(i)) then tsfco(i) = tsfc_wat(i) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index dfe7e5261..a8f76e2ed 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -548,6 +548,15 @@ type = integer intent = in optional = F +[huge] + standard_name = netcdf_float_fillvalue + long_name = definition of NetCDF float FillValue + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1856,6 +1865,15 @@ kind = kind_phys intent = in optional = F +[huge] + standard_name = netcdf_float_fillvalue + long_name = definition of NetCDF float FillValue + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 4b034f588..294e1e018 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -108,7 +108,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & ltaerosol, lprnt, errmsg, errflg ) + & ltaerosol, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: use machine , only : kind_phys @@ -178,13 +178,13 @@ SUBROUTINE mynnedmf_wrapper_run( & & cliq, Cice, rcp, XLV, XLF, EP_1, EP_2 real(kind=kind_phys) :: xlvcp, xlscp, ev, rd, & - & rk, svp11, p608, ep_3,tv0, tv1, gtr,g_inv + & rk, svp11, p608, ep_3,tv0, tv1, gtr,g_inv, huge REAL, PARAMETER :: tref=300.0 !< reference temperature (K) REAL, PARAMETER :: TKmin=253.0 !< for total water conversion, Tripoli and Cotton (1981) REAL, PARAMETER :: zero=0.0d0, one=1.0d0 - REAL, PARAMETER :: huge=9.9692099683868690E36 ! NetCDF float FillValue, same as in GFS_typedefs.F90 +! REAL, PARAMETER :: huge=9.9692099683868690E36 ! NetCDF float FillValue, same as in GFS_typedefs.F90 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index e88975aff..ee58000ad 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1435,6 +1435,15 @@ type = logical intent = in optional = F +[huge] + standard_name = netcdf_float_fillvalue + long_name = definition of NetCDF float FillValue + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 19e675ab9666e5d34de66fcb6c7465cc67d47788 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 30 Sep 2021 17:58:51 +0000 Subject: [PATCH 23/36] The ice/water flux composition is removed for consistency with the GFS_surface_composites.F90 in theis PR. --- physics/sfc_drv_ruc.F90 | 50 ++++------------------------------------ physics/sfc_drv_ruc.meta | 22 ++---------------- 2 files changed, 7 insertions(+), 65 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 01d692985..eb309f25c 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -353,8 +353,6 @@ subroutine lsm_ruc_run & ! inputs ! --- constants & con_cp, con_rd, con_rv, con_g, con_pi, con_hvap, & & con_fvirt, & - ! for water - & ch_wat, tskin_wat, & ! --- in/outs for ice and land & semisbase, semis_lnd, semis_ice, sfalb_lnd, sfalb_ice, & & sncovr1_lnd, weasd_lnd, snwdph_lnd, tskin_lnd, & @@ -370,8 +368,7 @@ subroutine lsm_ruc_run & ! inputs & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & ! for ice & sfcqc_ice, sfcqv_ice, & - & tsurf_ice, tsnow_ice, z0rl_ice, & -! & tice, tsurf_ice, tsnow_ice, z0rl_ice, & + & tsurf_ice, tsnow_ice, z0rl_ice, & & qsurf_ice, gflux_ice, evap_ice, ep1d_ice, hflx_ice, & & cm_ice, ch_ice, snowfallac_ice, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & @@ -388,7 +385,6 @@ subroutine lsm_ruc_run & ! inputs ! --- constant parameters: real(kind=kind_phys), parameter :: rhoh2o = 1000.0 real(kind=kind_phys), parameter :: stbolt = 5.670400e-8 - real(kind=kind_phys), parameter :: con_tice = 271.2 ! --- input: integer, intent(in) :: me, master @@ -403,7 +399,7 @@ subroutine lsm_ruc_run & ! inputs ! for land & cm_lnd, ch_lnd, & ! for water - & ch_wat, tskin_wat, oceanfrac, & + & oceanfrac, & ! for ice & cm_ice, ch_ice @@ -557,7 +553,7 @@ subroutine lsm_ruc_run & ! inputs do i = 1, im ! i - horizontal loop flag_ice(i) = .false. - if (icy(i) .and. .not. flag_cice(i)) then + if (icy(i) .and. .not. flag_cice(i)) then ! flag_cice(i)=.true. when coupled to CICE ! - uncoupled ice model if (oceanfrac(i) > zero) then cimin(i) = min_seaice @@ -569,8 +565,8 @@ subroutine lsm_ruc_run & ! inputs flag_ice(i) = .true. endif endif - ! - Set flag for ice points for uncoupled model (islmsk(i) == 4 when coupled to CICE) - ! - Exclude ice on the lakes if the lake model is turned on. + ! - Ice points for uncoupled model + ! - Exclude ice on the lakes if the lake model is turned on: lake(i)=.true. flag_ice_uncoupled(i) = (flag_ice(i) .and. .not. lake(i)) !> - Set flag for land and ice points. !- 10may19 - ice points are turned off. @@ -1388,42 +1384,6 @@ subroutine lsm_ruc_run & ! inputs enddo ! j enddo ! i - !-- Take care of fractional sea ice for uncoupled run with frac_grid=.false. - !-- When frac_grid=.true. GFS_surface_composite will take care of this. - do i = 1, im ! i - horizontal loop - if ( flag_iter(i) .and. flag(i) ) then - ! Do this only when the fractional grid is not turned on! - ! Compute composite for a fractional sea ice: fice(i) < 1. - ! This is needed for the 2-way coupling - ! in the upcoupled case (when sfc_cice is not used). - if(.not. frac_grid) then - if( flag_ice_uncoupled(i) .and. fice(i) < 1.) then - !write (0,*)'Fractional sea ice at i', i, fice(i) - fwat = 1.0 - fice(i) - ! Check if ice fraction is below the minimum value: 15% in GFS - ! physics. - if (fice(i) < cimin(i)) then ! cimin - minimal ice fraction - write (0,*)'warning: ice fraction is low:', fice(i) - fice(i) = cimin(i) - fwat = 1.0 - cimin(i) - write (0,*)'fix ice fraction: reset it to:', fice(i), tskin_wat(i) - endif - - ! Compute the composite of ice and open water for 2-way coupling in the - ! uncoupled sea-ice model. Use ice variables for the composite. - tsurf_ice(i) = tsurf_ice(i) * fice(i) + min(con_tice,tskin_wat(i)) * fwat - chh_ice(i) = chh_ice(i) * fice(i) + ch_wat(i) * wind(i) * rho(i) * fwat - hfxw = ch_wat(i) * wind(i) * (min(con_tice,tskin_wat(i)) - t1(i)) - hflx_ice(i) = hflx_ice(i) * fice(i) + hfxw * fwat - qsw = rslf(prsl1(i),min(con_tice,tskin_wat(i))) - evapw = ch_wat(i) * wind(i) * (qsw - q0(i)) - evap_ice(i) = evap_ice(i) * fice(i) + evapw * fwat - qsurf_ice(i) = q1(i) + evap_ice(i) * rho(i) / chh_ice(i) - endif ! flag_ice_uncoupled(i) .and. fice(i) < 1. - endif ! flag_iter, icy, not frac_grid - endif - enddo ! i - !> - Restore land-related prognostic fields for guess run. do j = 1, 1 do i = 1, im diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index a0a3768f5..474ad1018 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -192,8 +192,8 @@ intent = in optional = F [tsfc_ice] - standard_name = surface_skin_temperature_over_ice - long_name = surface skin temperature over ice + standard_name = sea_ice_temperature + long_name = sea ice surface skin temperature units = K dimensions = (horizontal_dimension) type = real @@ -1102,24 +1102,6 @@ kind = kind_phys intent = in optional = F -[ch_wat] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_water - long_name = surface exchange coeff heat surface exchange coeff heat & moisture over ocean moisture over water - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tskin_wat] - standard_name = surface_skin_temperature_over_water - long_name = surface skin temperature over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [semisbase] standard_name = baseline_surface_longwave_emissivity long_name = baseline surface lw emissivity in fraction From 8ae21d6a88482d0484925906e55bded8342610c7 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 30 Sep 2021 22:04:12 +0000 Subject: [PATCH 24/36] Added updating of snow temperature and some clean-up. --- physics/sfc_drv_ruc.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index eb309f25c..b29fbb7e3 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -430,7 +430,6 @@ subroutine lsm_ruc_run & ! inputs & weasd_ice, snwdph_ice, tskin_ice, & & tsurf_ice, z0rl_ice, tsnow_ice, & & sfcqc_ice, sfcqv_ice, fice -! & sfcqc_ice, sfcqv_ice, fice, tice ! --- in real (kind=kind_phys), dimension(:), intent(in) :: & @@ -1168,11 +1167,12 @@ subroutine lsm_ruc_run & ! inputs !snohf(i) = snoh(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 - gflux_lnd(i) = ssoil_lnd(i,j) + evap_lnd(i) = qfx_lnd(i,j) / rho(i) ! kinematic + hflx_lnd(i) = hfx_lnd(i,j) / (con_cp*rho(i)) ! 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) @@ -1341,6 +1341,7 @@ subroutine lsm_ruc_run & ! inputs qsurf_ice(i) = qsfc_ice(i,j) tsurf_ice(i) = soilt_ice(i,j) + tsnow_ice(i) = soilt1_ice(i,j) sfcqv_ice(i) = qvg_ice(i,j) sfcqc_ice(i) = qcg_ice(i,j) @@ -1428,7 +1429,6 @@ subroutine lsm_ruc_run & ! inputs if(debug_print) write (0,*)'iter run', i,j, tskin_ice(i),tsurf_ice(i) tskin_lnd(i) = tsurf_lnd(i) tskin_ice(i) = tsurf_ice(i) -! tice(i) = tsurf_ice(i) endif ! flag_guess endif ! flag enddo ! i From 0fd3702f82edf15d8310297cc405984d2a8c3e53 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 30 Sep 2021 23:30:36 +0000 Subject: [PATCH 25/36] minor fix in sfc_drv_ruc.meta and removing some blanks in sfc_drv_ruc.F90 --- physics/sfc_drv_ruc.F90 | 44 ++++++++++++++++++++-------------------- physics/sfc_drv_ruc.meta | 12 +++++------ 2 files changed, 28 insertions(+), 28 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index b29fbb7e3..ea0157fb5 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -268,7 +268,7 @@ end subroutine lsm_ruc_finalize ! ===================================================================== ! ! lsm_ruc_run: ! -! RUC Surface Model - WRF4.0 version ! +! RUC Surface Model - WRF4.0 version ! ! program history log: ! ! may 2018 -- tanya smirnova ! ! ! @@ -488,7 +488,7 @@ subroutine lsm_ruc_run & ! inputs & keepfr_old, smfrkeep_old real (kind=kind_phys),dimension (im,1,1) :: & - & conflx2, sfcprs, sfctmp, q2, qcatm, rho2 + & conflx2, sfcprs, sfctmp, q2, qcatm, rho2 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, & @@ -594,7 +594,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'flag_init =',flag_init write (0,*)'flag_restart =',flag_restart endif - + ims = 1 its = 1 ime = 1 @@ -617,7 +617,7 @@ subroutine lsm_ruc_run & ! inputs landusef (:,:,:) = 0.0 soilctop (:,:,:) = 0.0 - !> -- number of soil categories + !> -- number of soil categories !if(isot == 1) then !nscat = 19 ! stasgo !else @@ -651,7 +651,7 @@ subroutine lsm_ruc_run & ! inputs smcref2 (i) = 1. smcwlt2 (i) = 0. else - !land + !land smcref2 (i) = REFSMC(soiltyp(i)) smcwlt2 (i) = WLTSMC(soiltyp(i)) endif @@ -760,13 +760,13 @@ subroutine lsm_ruc_run & ! inputs endif ! flag_iter & flag enddo ! i -!> - Prepare variables to run RUC LSM: +!> - Prepare variables to run RUC LSM: !! - 1. configuration information (c): !!\n \a ffrozp - fraction of frozen precipitation !!\n \a frpcpn - .true. if mixed phase precipitation available !!\n \a 1:im - horizontal_loop_extent !!\n \a fice - fraction of sea-ice in the grid cell -!!\n \a delt - timestep (sec) (dt should not exceed 3600 secs) +!!\n \a delt - timestep (sec) (dt should not exceed 3600 secs) !!\n \a conflx2 - height (\f$m\f$) above ground of atmospheric forcing variables !!\n \a lsoil_ruc - number of soil layers (= 6 or 9) !!\n \a zs - the depth of each soil level (\f$m\f$) @@ -968,7 +968,7 @@ subroutine lsm_ruc_run & ! inputs wet(i,j) = max(0.0001,smsoil(i,1,j)/0.3) endif - chs_lnd (i,j) = ch_lnd(i) * wind(i) ! compute conductance + 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)) flqc_lnd(i,j) = chs_lnd(i,j) * rho(i) * wet(i,j) ! for output @@ -980,11 +980,11 @@ subroutine lsm_ruc_run & ! inputs 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 + snowh_lnd(i,j) = 0.003 * sneqv_lnd(i,j) ! snow density ~300 kg m-3 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 + 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 @@ -1053,7 +1053,7 @@ subroutine lsm_ruc_run & ! inputs endif endif -!> - Call RUC LSM lsmruc() for land. +!> - Call RUC LSM lsmruc() for land. call lsmruc( & & delt, flag_init, flag_restart, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & @@ -1071,7 +1071,7 @@ subroutine lsm_ruc_run & ! inputs & 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, & +! & 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), & @@ -1183,7 +1183,7 @@ subroutine lsm_ruc_run & ! inputs ! 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] + ! --- ... units [m/s] = [g m-2 s-1] rhosnf(i) = rhosnfr(i,j) !acsnow(i) = acsn(i,j) ! kg m-2 @@ -1265,7 +1265,7 @@ subroutine lsm_ruc_run & ! inputs wet_ice(i,j) = 1. - chs_ice (i,j) = ch_ice(i) * wind(i) ! compute conductance + 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)) flqc_ice(i,j) = chs_ice(i,j) * rho(i) * wet_ice(i,j) ! for output @@ -1283,7 +1283,7 @@ subroutine lsm_ruc_run & ! inputs 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 + sneqv_ice(i,j) = 300. * snowh_ice(i,j) ! snow density ~300 kg m-3 endif if (sneqv_ice(i,j) > 0. .and. snowh_ice(i,j) > 0.) then @@ -1295,7 +1295,7 @@ subroutine lsm_ruc_run & ! inputs z0_ice(i,j) = z0rl_ice(i)/100. znt_ice(i,j) = z0rl_ice(i)/100. -!> - Call RUC LSM lsmruc() for ice. +!> - Call RUC LSM lsmruc() for ice. call lsmruc( & & delt, flag_init, flag_restart, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & @@ -1447,7 +1447,7 @@ end subroutine lsm_ruc_run subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in me, master, lsm_ruc, lsm, slmsk, & ! in soiltyp, vegtype, & ! in - tskin_lnd, tskin_wat, tg3, & ! !in + tskin_lnd, tskin_wat, tg3, & ! in zs, dzs, smc, slc, stc, & ! in sh2o, smfrkeep, tslb, smois, & ! out wetness, errmsg, errflg) @@ -1550,7 +1550,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in jds = 1 jms = 1 jts = 1 - jde = 1 + jde = 1 jme = 1 jte = 1 kds = 1 @@ -1733,7 +1733,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do k=1,lsoil_ruc factorsm(k)=1. enddo - + ! RUC soil moisture bucket smtotr(i,j)=0. do k=1,lsoil_ruc -1 @@ -1741,7 +1741,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in 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. - + if(debug_print) then if(i==ipr) then write (0,*)'from Noah to RUC: RUC bucket and Noah bucket at', & @@ -1749,12 +1749,12 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in write (0,*)'before smois=',i,j,soilm(i,:,j) endif endif - + ! 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))) 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 diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 474ad1018..7e80a1761 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -183,8 +183,8 @@ intent = in optional = F [tsfc_lnd] - standard_name = surface_skin_temperature - long_name = surface skin temperature + standard_name = surface_skin_temperature_over_land + long_name = surface skin temperature over land units = K dimensions = (horizontal_dimension) type = real @@ -192,8 +192,8 @@ intent = in optional = F [tsfc_ice] - standard_name = sea_ice_temperature - long_name = sea ice surface skin temperature + standard_name = surface_skin_temperature_over_ice + long_name = surface skin temperature over ice units = K dimensions = (horizontal_dimension) type = real @@ -201,8 +201,8 @@ intent = in optional = F [tsfc_wat] - standard_name = sea_surface_temperature - long_name = sea surface temperature + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water units = K dimensions = (horizontal_dimension) type = real From 76f0b35d082083b1a7da1017e9d79a679d599875 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 1 Oct 2021 23:45:24 +0000 Subject: [PATCH 26/36] changing ^ to & in radiation_surface.f --- physics/radiation_surface.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 69b8abd85..c507f0a83 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -784,7 +784,7 @@ subroutine setemis & integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc logical, intent(in) :: frac_grid, cplice real (kind=kind_phys), dimension(:), intent(in) :: vtype, & - ^ lakefrac + & lakefrac real (kind=kind_phys), dimension(:), intent(in) :: & & xlon,xlat, slmsk, snowf,sncovr, sncovr_ice, & From b8a5bc05f859433eb141aef49a1834e376f04eb6 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 4 Oct 2021 19:19:37 -0400 Subject: [PATCH 27/36] fixing radiation_surface and GFS_surface_composite --- physics/GFS_surface_composites.F90 | 2 +- physics/radiation_surface.f | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index ea67cbd43..91a326591 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -249,7 +249,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra ! to prepare to separate lake from ocean under water category do i = 1, im - if(wet(i) .and. lakefrac(i) > zero) then + if ((wet(i) .or. icy(i)) .and. lakefrac(i) > zero) then lake(i) = .true. if (lkm == 1 .and. lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then use_flake(i) = .true. diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index accd58511..41e22bf08 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -974,8 +974,7 @@ subroutine setemis & sfcemis_ice = semis_ice(i) ! output from CICE endif elseif (lsm == lsm_ruc) then - if (.not. cplice .or. & - & (lakefrac(i) > f_zero .and. use_flake(i))) then + if (use_flake(i)) then if (sncovr_ice(i) > f_zero) then sfcemis_ice = emsref(7) * (f_one-sncovr_ice(i)) & & + emsref(8) * sncovr_ice(i) From efd7e5ae019420c40ddb70f6796f6f1a5ea3e5d1 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 8 Oct 2021 09:22:08 -0600 Subject: [PATCH 28/36] Update documentation for input/output variables in radiation_surface.f / setemis --- physics/radiation_surface.f | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 41e22bf08..7e9027d44 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -755,9 +755,11 @@ subroutine setemis & ! tsknf (IMAX) - ground surface temperature in k ! ! tairf (IMAX) - lowest model layer air temperature in k ! ! hprif (IMAX) - topographic sdv in m ! +! IMAX - array horizontal dimension ! +! ! +! inputs/outputs: ! ! semis_lnd (IMAX) - land emissivity ! ! semis_ice (IMAX) - ice emissivity ! -! IMAX - array horizontal dimension ! ! ! ! outputs: ! ! sfcemis(IMAX) - surface emissivity ! From 85ffbb223f73990ac8763b8da49b23c3c65b92f3 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 9 Oct 2021 23:47:38 +0000 Subject: [PATCH 29/36] fixing some errors in radiation_surface and rearranging dcyc2.meta to match fortran --- physics/dcyc2.meta | 70 ++++++++++++++++++------------------- physics/radiation_surface.f | 21 ++++++----- 2 files changed, 47 insertions(+), 44 deletions(-) diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index b90195c3b..da9476e84 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -61,24 +61,6 @@ kind = kind_phys intent = in optional = F -[xlon] - standard_name = longitude - long_name = longitude of grid box - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[coszen] - standard_name = cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep - long_name = average of cosine of zenith angle over daytime shortwave call time interval - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -115,6 +97,24 @@ kind = kind_phys intent = in optional = F +[xlon] + standard_name = longitude + long_name = longitude of grid box + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[coszen] + standard_name = cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep + long_name = average of cosine of zenith angle over daytime shortwave call time interval + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [tsfc_lnd] standard_name = surface_skin_temperature_over_land long_name = surface skin temperature over land @@ -169,15 +169,6 @@ kind = kind_phys intent = in optional = F -[tsfc_radtime] - standard_name = surface_skin_temperature_on_radiation_timestep - long_name = surface skin temperature on radiation timestep - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [sfcemis_lnd] standard_name = surface_longwave_emissivity_over_land long_name = surface lw emissivity in fraction over land @@ -398,14 +389,6 @@ type = logical intent = in optional = F -[use_LW_jacobian] - standard_name = flag_to_calc_RRTMGP_LW_jacobian - long_name = logical flag to control RRTMGP LW calculation - units = flag - dimensions = () - type = logical - intent = in - optional = F [damp_LW_fluxadj] standard_name = flag_to_damp_RRTMGP_LW_jacobian_flux_adjustment long_name = logical flag to control RRTMGP LW calculation @@ -432,6 +415,14 @@ kind = kind_phys intent = in optional = F +[use_LW_jacobian] + standard_name = flag_to_calc_RRTMGP_LW_jacobian + long_name = logical flag to control RRTMGP LW calculation + units = flag + dimensions = () + type = logical + intent = in + optional = F [sfculw] standard_name = surface_upwelling_longwave_flux_on_radiation_timestep long_name = total sky sfc upward lw flux @@ -519,6 +510,15 @@ type = logical intent = in optional = F +[tsfc_radtime] + standard_name = surface_skin_temperature_on_radiation_timestep + long_name = surface skin temperature on radiation timestep + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [dtdt] standard_name = process_split_cumulative_tendency_of_air_temperature long_name = total radiative heating rate at current time diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 41e22bf08..3bb53be73 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -120,12 +120,12 @@ module module_radiation_surface ! --- constant parameters integer, parameter, public :: NF_ALBD = 4 !< number of surface albedo components - integer, parameter, public :: IMXEMS = 360 !< number of longtitude points in global emis-type map - integer, parameter, public :: JMXEMS = 180 !< number of latitude points in global emis-type map + integer, parameter, public :: IMXEMS = 360 !< number of longtitude points in global emis-type map + integer, parameter, public :: JMXEMS = 180 !< number of latitude points in global emis-type map real (kind=kind_phys), parameter :: f_zero = 0.0 real (kind=kind_phys), parameter :: f_one = 1.0 real (kind=kind_phys), parameter :: epsln = 1.0e-6 - real (kind=kind_phys), parameter :: rad2dg= 180.0 / con_pi + real (kind=kind_phys), parameter :: rad2dg = 180.0 / con_pi integer, allocatable :: idxems(:,:) !< global surface emissivity index array integer :: iemslw = 1 !< global surface emissivity control flag set up in 'sfc_init' ! @@ -830,19 +830,21 @@ subroutine setemis & lab_do_IMAX : do i = 1, IMAX - snowc = sncovr(i) + snowc = sncovr(i) * fracl(i) if (.not. cplice .or. lakefrac(i) > f_zero) then semis_ice(i) = emsref(7) - snowc = sncovr(i) + sncovr_ice(i) + snowc = sncovr(i) + sncovr_ice(i)*fraci(i) endif if (fracl(i) < epsln) then ! no land if ( abs(fraco(i)-f_one) < epsln ) then ! open water point sfcemis(i) = emsref(1) - elseif ( abs(fraci(i)-f_one) > epsln ) then ! complete sea/lake ice - sfcemis(i) = emsref(7) + elseif ( abs(fraci(i)-f_one) < epsln ) then ! complete sea/lake ice +! sfcemis(i) = emsref(7) + sfcemis(i) = semis_ice(i) else !-- fractional sea ice - sfcemis(i) = fraco(i)*emsref(1) + fraci(i)*emsref(7) +! sfcemis(i) = fraco(i)*emsref(1) + fraci(i)*emsref(7) + sfcemis(i) = fraco(i)*emsref(1) + fraci(i)*semis_ice(i) endif else ! land or fractional grid @@ -900,7 +902,8 @@ subroutine setemis & semis_lnd(i) = semis_lnd(i) * (f_one - sncovr(i)) & & + emsref(8) * sncovr(i) endif - if (sncovr_ice(i) > f_zero .and. .not. cplice) then + if (sncovr_ice(i) > f_zero .and. & + & (lakefrac(i) > f_zero .or. .not. cplice)) then semis_ice(i) = semis_ice(i) * (f_one - sncovr_ice(i)) & & + emsref(8) * sncovr_ice(i) endif From e7dfdefe90cc2db965faba2f0dc8e5d145cc1f26 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 15 Oct 2021 16:18:31 +0000 Subject: [PATCH 30/36] additional updates to emissivity calculation etc --- physics/GFS_debug.F90 | 2 +- physics/GFS_radiation_surface.F90 | 24 +++---- physics/GFS_radiation_surface.meta | 24 ++++++- physics/GFS_surface_composites.F90 | 27 +++---- physics/GFS_surface_composites.meta | 36 ---------- physics/radiation_surface.f | 107 +++++++++++----------------- physics/rte-rrtmgp | 2 +- 7 files changed, 90 insertions(+), 132 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index deb88458b..33e5beec0 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1307,7 +1307,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%visdf ', Interstitial%scmpsw%visdf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%semis_ice ', Interstitial%semis_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%semis_land ', Interstitial%semis_land ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%semis_water ', Interstitial%semis_water ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%semis_water ', Interstitial%semis_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sfcalb ', Interstitial%sfcalb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigma ', Interstitial%sigma ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmaf ', Interstitial%sigmaf ) diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index 02d0f1c57..d48bce332 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -58,11 +58,11 @@ end subroutine GFS_radiation_surface_init subroutine GFS_radiation_surface_run ( & im, frac_grid, lslwr, lsswr, lsm, lsm_noahmp, lsm_ruc, & xlat, xlon, slmsk, lndp_type, n_var_lndp, sfc_alb_pert, & - lndp_var_list, lndp_prt_list, landfrac, snowd, sncovr, & + lndp_var_list, lndp_prt_list, landfrac, snodl, snodi, sncovr, & sncovr_ice, fice, zorl, hprime, tsfg, tsfa, tisfc, coszen, & cplice, min_seaice, min_lakeice, lakefrac, use_flake, & alvsf, alnsf, alvwf, alnwf, facsf, facwf, & - semis_lnd, semis_ice, snoalb, use_cice_alb, & + semis_lnd, semis_ice, semis_wat, snoalb, use_cice_alb, & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & semisbase, semis, sfcalb, sfc_alb_dif, errmsg, errflg) @@ -82,7 +82,7 @@ subroutine GFS_radiation_surface_run ( & real(kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, slmsk, & sfc_alb_pert, lndp_prt_list, & landfrac, lakefrac, & - snowd, sncovr, & + snodl, snodi, sncovr, & sncovr_ice, fice, zorl, & hprime, tsfg, tsfa, tisfc, & coszen, alvsf, alnsf, alvwf, & @@ -93,7 +93,7 @@ subroutine GFS_radiation_surface_run ( & real(kind=kind_phys), dimension(:), intent(inout) :: albdvis_lnd, albdnir_lnd, & albivis_lnd, albinir_lnd, & - semis_lnd, semis_ice + semis_lnd, semis_ice, semis_wat real(kind=kind_phys), dimension(:), intent(inout) :: semisbase, semis real(kind=kind_phys), dimension(:,:), intent(inout) :: sfcalb real(kind=kind_phys), dimension(:), intent(inout) :: sfc_alb_dif @@ -161,13 +161,13 @@ subroutine GFS_radiation_surface_run ( & if (lslwr) then !> - Call module_radiation_surface::setemis(),to set up surface !! emissivity for LW radiation. - call setemis (lsm, lsm_noahmp, lsm_ruc, frac_grid, cplice, & - use_flake, lakefrac, xlon, xlat, slmsk, & -! frac_grid, min_seaice, xlon, xlat, slmsk, & - snowd, sncovr, sncovr_ice, zorl, tsfg, tsfa, & - hprime, semis_lnd, semis_ice, im, & - fracl, fraco, fraci, icy, & ! --- inputs - semisbase, semis) ! --- outputs + call setemis (lsm, lsm_noahmp, lsm_ruc, frac_grid, cplice, & + use_flake, lakefrac, xlon, xlat, slmsk, & +! frac_grid, min_seaice, xlon, xlat, slmsk, & + snodl, snodi, sncovr, sncovr_ice, zorl, tsfg, & + tsfa, hprime, semis_lnd, semis_ice, semis_wat,& + im, fracl, fraco, fraci, icy, & ! --- inputs + semisbase, semis) ! --- outputs endif if (lsswr) then @@ -184,7 +184,7 @@ subroutine GFS_radiation_surface_run ( & !> - Call module_radiation_surface::setalb(),to set up surface !! albedor for SW radiation. - call setalb (slmsk, lsm, lsm_noahmp, lsm_ruc, use_cice_alb, snowd, sncovr, sncovr_ice, & + call setalb (slmsk, lsm, lsm_noahmp, lsm_ruc, use_cice_alb, snodl, sncovr, sncovr_ice, & snoalb, zorl, coszen, tsfg, tsfa, hprime, frac_grid, lakefrac, & ! snoalb, zorl, coszen, tsfg, tsfa, hprime, frac_grid, min_seaice, & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & diff --git a/physics/GFS_radiation_surface.meta b/physics/GFS_radiation_surface.meta index d360b37d8..5aa40ff1f 100644 --- a/physics/GFS_radiation_surface.meta +++ b/physics/GFS_radiation_surface.meta @@ -197,9 +197,18 @@ kind = kind_phys intent = in optional = F -[snowd] - standard_name = lwe_surface_snow - long_name = water equivalent snow depth +[snodl] + standard_name = surface_snow_thickness_water_equivalent_over_land + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snodi] + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice units = mm dimensions = (horizontal_loop_extent) type = real @@ -402,6 +411,15 @@ kind = kind_phys intent = in optional = F +[semis_wat] + standard_name = surface_longwave_emissivity_over_water + long_name = surface lw emissivity in fraction over water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [snoalb] standard_name = upper_bound_of_max_albedo_assuming_deep_snow long_name = maximum snow albedo diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index ca5ea2765..2ad6ef3d8 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -34,8 +34,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & weasd, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & tisfc, tsurf_wat, tsurf_lnd, tsurf_ice, & - gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_wat, semis_lnd, semis_ice, & - qss, qss_wat, qss_lnd, qss_ice, & + gflx_ice, tgice, islmsk, islmsk_cice, slmsk, qss, qss_wat, qss_lnd, qss_ice, & min_lakeice, min_seaice, kdt, huge, errmsg, errflg) implicit none @@ -57,7 +56,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra qss_wat, qss_lnd, qss_ice, ep1d_ice, gflx_ice real(kind=kind_phys), intent(in ) :: tgice integer, dimension(:), intent(inout) :: islmsk, islmsk_cice - real(kind=kind_phys), dimension(:), intent(inout) :: semis_wat, semis_lnd, semis_ice, slmsk + real(kind=kind_phys), dimension(:), intent(inout) :: slmsk real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice, huge ! real(kind=kind_phys), dimension(:), intent(inout) :: zorlo, zorll, zorli @@ -212,11 +211,6 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra uustar_wat(i) = uustar(i) tsfc_wat(i) = tsfco(i) tsurf_wat(i) = tsfco(i) - !-- reference emiss value for surface emissivity in setemis - ! 1-open water, 2-grass/shrub land, 3-bare soil, tundra, - ! 4-sandy desert, 5-rocky desert, 6-forest, 7-ice, 8-snow - !data emsref / 0.97, 0.95, 0.94, 0.90, 0.93, 0.96, 0.96, 0.99 / - semis_wat(i) = 0.97_kind_phys ! consistent with setemis ! DH* else zorlo(i) = huge @@ -325,8 +319,9 @@ end subroutine GFS_surface_composites_inter_finalize !> \section arg_table_GFS_surface_composites_inter_run Argument Table !! \htmlinclude GFS_surface_composites_inter_run.html !! - subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis_lnd, semis_ice, adjsfcdlw, & - gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat, & +! subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis_lnd, semis_ice, adjsfcdlw, & + subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_lnd, semis_ice, adjsfcdlw, & + gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat, & adjsfcusw, adjsfcdsw, adjsfcnsw, errmsg, errflg) implicit none @@ -334,7 +329,8 @@ subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis ! Interface variables integer, intent(in ) :: im logical, dimension(:), intent(in ) :: dry, icy, wet - real(kind=kind_phys), dimension(:), intent(in ) :: semis_wat, semis_lnd, semis_ice, adjsfcdlw, & +! real(kind=kind_phys), dimension(:), intent(in ) :: semis_wat, semis_lnd, semis_ice, adjsfcdlw, & + real(kind=kind_phys), dimension(:), intent(in ) :: semis_lnd, semis_ice, adjsfcdlw, & adjsfcdsw, adjsfcnsw real(kind=kind_phys), dimension(:), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat real(kind=kind_phys), dimension(:), intent(out) :: adjsfcusw @@ -343,6 +339,13 @@ subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg +! + !-- reference emiss value for surface emissivity in setemis + ! 1-open water, 2-grass/shrub land, 3-bare soil, tundra, + ! 4-sandy desert, 5-rocky desert, 6-forest, 7-ice, 8-snow + !data emsref / 0.97, 0.95, 0.94, 0.90, 0.93, 0.96, 0.96, 0.99 / + real(kind=kind_phys), parameter :: semis_wat = 0.97_kind_phys ! consistent with setemis + ! Local variables integer :: i @@ -371,7 +374,7 @@ subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis do i=1,im if (dry(i)) gabsbdlw_lnd(i) = semis_lnd(i) * adjsfcdlw(i) if (icy(i)) gabsbdlw_ice(i) = semis_ice(i) * adjsfcdlw(i) - if (wet(i)) gabsbdlw_wat(i) = semis_wat(i) * adjsfcdlw(i) + if (wet(i)) gabsbdlw_wat(i) = semis_wat * adjsfcdlw(i) adjsfcusw(i) = adjsfcdsw(i) - adjsfcnsw(i) enddo diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index a8f76e2ed..7d60d2b82 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -459,33 +459,6 @@ kind = kind_phys intent = inout optional = F -[semis_wat] - standard_name = surface_longwave_emissivity_over_water - long_name = surface lw emissivity in fraction over water - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[semis_lnd] - standard_name = surface_longwave_emissivity_over_land - long_name = surface lw emissivity in fraction over land - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[semis_ice] - standard_name = surface_longwave_emissivity_over_ice - long_name = surface lw emissivity in fraction over ice - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F [qss] standard_name = surface_specific_humidity long_name = surface air saturation specific humidity @@ -617,15 +590,6 @@ type = logical intent = in optional = F -[semis_wat] - standard_name = surface_longwave_emissivity_over_water - long_name = surface lw emissivity in fraction over water - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [semis_lnd] standard_name = surface_longwave_emissivity_over_land long_name = surface lw emissivity in fraction over land diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 3bb53be73..29cae3992 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -298,7 +298,7 @@ end subroutine sfc_init !! \n 1) climatological surface albedo scheme (\cite briegleb_1992) !! \n 2) MODIS retrieval based scheme from Boston univ. !!\param slmsk (IMAX), sea(0),land(1),ice(2) mask on fcst model grid -!!\param snowf (IMAX), snow depth water equivalent in mm +!!\param snowf (IMAX), snow depth water equivalent in mm over land !!\param sncovr (IMAX), snow cover over land !!\param snoalb (IMAX), maximum snow albedo over land (for deep snow) !!\param zorlf (IMAX), surface roughness in cm @@ -712,7 +712,8 @@ end subroutine setalb !! or -pi -> +pi ranges !!\param xlat (IMAX), latitude in radiance, default to pi/2 -> !! -pi/2 range, otherwise see in-line comment -!!\param snowf (IMAX), snow depth water equivalent in mm +!!\param snodl (IMAX), snow depth water equivalent in mm land +!!\param snodi (IMAX), snow depth water equivalent in mm ice !!\param sncovr (IMAX), snow cover over land !!\param zorlf (IMAX), surface roughness in cm !!\param tsknf (IMAX), ground surface temperature in K @@ -725,9 +726,9 @@ end subroutine setalb !----------------------------------- subroutine setemis & & ( lsm,lsm_noahmp,lsm_ruc,frac_grid,cplice,use_flake, & ! --- inputs: - & lakefrac,xlon,xlat,slmsk,snowf,sncovr,sncovr_ice, & + & lakefrac,xlon,xlat,slmsk,snodl,snodi,sncovr,sncovr_ice, & & zorlf,tsknf,tairf,hprif, & - & semis_lnd,semis_ice,IMAX,fracl,fraco,fraci,icy, & + & semis_lnd,semis_ice,semis_wat,IMAX,fracl,fraco,fraci,icy, & & semisbase, sfcemis & ! --- outputs: & ) @@ -748,7 +749,8 @@ subroutine setemis & ! xlat (IMAX) - latitude in radiance, default to pi/2 -> -pi/2 ! ! range, otherwise see in-line comment ! ! slmsk (IMAX) - sea(0),land(1),ice(2) mask on fcst model grid ! -! snowf (IMAX) - snow depth water equivalent in mm ! +! snodl (IMAX) - snow depth water equivalent in mm over land ! +! snodi (IMAX) - snow depth water equivalent in mm over ice ! ! sncovr(IMAX) - ialbflg=1: snow cover over land in fraction ! ! sncovr_ice(IMAX) - snow cover over ice in fraction ! ! zorlf (IMAX) - surface roughness in cm ! @@ -757,6 +759,7 @@ subroutine setemis & ! hprif (IMAX) - topographic sdv in m ! ! semis_lnd (IMAX) - land emissivity ! ! semis_ice (IMAX) - ice emissivity ! +! semis_wat (IMAX) - water emissivity ! ! IMAX - array horizontal dimension ! ! ! ! outputs: ! @@ -787,12 +790,12 @@ subroutine setemis & real (kind=kind_phys), dimension(:), intent(in) :: lakefrac real (kind=kind_phys), dimension(:), intent(in) :: & - & xlon,xlat, slmsk, snowf,sncovr, sncovr_ice, & + & xlon,xlat, slmsk, snodl, snodi, sncovr, sncovr_ice, & & zorlf, tsknf, tairf, hprif real (kind=kind_phys), dimension(:), intent(in) :: & & fracl, fraco, fraci real (kind=kind_phys), dimension(:), intent(inout) :: & - & semis_lnd, semis_ice + & semis_lnd, semis_ice, semis_wat logical, dimension(:), intent(in) :: & & icy @@ -805,7 +808,7 @@ subroutine setemis & integer :: ivgtyp real (kind=kind_phys) :: dltg, hdlt, tmp1, tmp2, & - & asnow, argh, hrgh, fsno, fsnol, fsnoi, snowc + & asnow, argh, hrgh, fsno real (kind=kind_phys) :: sfcemis_land, sfcemis_ice ! --- reference emiss value for diff surface emiss index @@ -819,6 +822,8 @@ subroutine setemis & !===> ... begin here ! !> -# Set emissivity by surface type and conditions + + semis_wat = emsref(1) if ( iemslw == 1 ) then dltg = 360.0 / float(IMXEMS) @@ -830,20 +835,16 @@ subroutine setemis & lab_do_IMAX : do i = 1, IMAX - snowc = sncovr(i) * fracl(i) if (.not. cplice .or. lakefrac(i) > f_zero) then semis_ice(i) = emsref(7) - snowc = sncovr(i) + sncovr_ice(i)*fraci(i) endif if (fracl(i) < epsln) then ! no land if ( abs(fraco(i)-f_one) < epsln ) then ! open water point sfcemis(i) = emsref(1) elseif ( abs(fraci(i)-f_one) < epsln ) then ! complete sea/lake ice -! sfcemis(i) = emsref(7) sfcemis(i) = semis_ice(i) else !-- fractional sea ice -! sfcemis(i) = fraco(i)*emsref(1) + fraci(i)*emsref(7) sfcemis(i) = fraco(i)*emsref(1) + fraci(i)*semis_ice(i) endif @@ -889,65 +890,39 @@ subroutine setemis & semisbase(i) = sfcemis(i) semis_lnd(i) = emsref(idx) - endif ! end if_slmsk_block + endif !> - Check for snow covered area. +!> it is assume here that "sncovr" is the fraction of land covered by snow +!> and "sncovr_ice" is the fraction of ice coverd by snow - if (snowc > f_zero) then ! input land/ice area snow cover - -! it is assume here that "sncovr" is the fraction of land covered by snow -! and "sncovr_ice" is the fraction of ice coverd by snow - + if (fracl(i) > epsln) then if (sncovr(i) > f_zero) then semis_lnd(i) = semis_lnd(i) * (f_one - sncovr(i)) & & + emsref(8) * sncovr(i) + elseif (snodl(i) > f_zero) then + asnow = 0.02*snodl(i) + argh = min(0.50, max(.025, 0.01*zorlf(i))) + hrgh = min(f_one, max(0.20, 1.0577-1.1538e-3*hprif(i) ) ) + fsno = min(f_one, max(f_zero, asnow/(argh+asnow) * hrgh)) + semis_lnd(i) = semis_lnd(i)*(f_one-fsno) + emsref(8)*fsno endif - if (sncovr_ice(i) > f_zero .and. & - & (lakefrac(i) > f_zero .or. .not. cplice)) then + endif + if (fraci(i) > epsln .and. & + & (lakefrac(i) > f_zero .or. .not. cplice)) then + if (sncovr_ice(i) > f_zero) then semis_ice(i) = semis_ice(i) * (f_one - sncovr_ice(i)) & & + emsref(8) * sncovr_ice(i) - endif - sfcemis(i) = fracl(i)*semis_lnd(i) + fraco(i)*emsref(1) & - & + fraci(i)*semis_ice(i) - - else ! compute snow cover from snow depth - if (abs(fraco(i)-f_one) > epsln .and. & - & snowf(i) > f_zero) then - asnow = 0.02*snowf(i) + elseif (snodi(i) > f_zero) then + asnow = 0.02*snodi(i) argh = min(0.50, max(.025, 0.01*zorlf(i))) hrgh = min(f_one, max(0.20, 1.0577-1.1538e-3*hprif(i) ) ) - tmp1 = fracl(i) + fraci(i) - if (tmp1 > f_zero) then - fsno = min(tmp1, asnow / (argh + asnow) * hrgh) - tmp2 = fsno / tmp1 - fsnol = fracl(i) * tmp2 - fsnoi = fraci(i) * tmp2 - - if (fracl(i) > f_zero) then - if (fracl(i) <= fsnol) then - semis_lnd(i) = emsref(8) - else - tmp1 = (fracl(i)-fsnol) / fracl(i) - semis_lnd(i) = semis_lnd(i) * tmp1 & - & + emsref(8) * (f_one-tmp1) - endif - endif - if (fraci(i) > f_zero .and. & - & (lakefrac(i) > f_zero .or. .not. cplice)) then - if (fraci(i) <= fsnoi) then - semis_ice(i) = emsref(8) - else - tmp1 = (fraci(i)-fsnoi) / fraci(i) - semis_ice(i) = semis_ice(i) * tmp1 & - & + emsref(8) * (f_one-tmp1) - endif - endif - endif + fsno = min(f_one, max(f_zero, asnow/(argh+asnow) * hrgh)) + semis_ice(i) = semis_ice(i)*(f_one-fsno) + emsref(8)*fsno endif - sfcemis(i) = fracl(i)*semis_lnd(i) + fraco(i)*emsref(1) & - & + fraci(i)*semis_ice(i) - - endif ! end if_ialbflg + endif + sfcemis(i) = fracl(i)*semis_lnd(i) + fraco(i)*emsref(1) & + & + fraci(i)*semis_ice(i) enddo lab_do_IMAX @@ -964,13 +939,12 @@ subroutine setemis & if (sncovr_ice(i) > f_zero) then sfcemis_ice = emsref(7) * (f_one-sncovr_ice(i)) & & + emsref(8) * sncovr_ice(i) - elseif (snowf(i) > f_zero) then - asnow = 0.02*snowf(i) + elseif (snodi(i) > f_zero) then + asnow = 0.02*snodi(i) argh = min(0.50, max(.025,0.01*zorlf(i))) hrgh = min(f_one,max(0.20,1.0577-1.1538e-3*hprif(i))) fsno = asnow / (argh + asnow) * hrgh - fsnoi = min(f_one, fsno / (fraci(i)+fracl(i))) - sfcemis_ice = emsref(7)*(f_one-fsnoi)+emsref(8)*fsnoi + sfcemis_ice = emsref(7)*(f_one-fsno) + emsref(8)*fsno endif semis_ice(i) = sfcemis_ice else @@ -981,13 +955,12 @@ subroutine setemis & if (sncovr_ice(i) > f_zero) then sfcemis_ice = emsref(7) * (f_one-sncovr_ice(i)) & & + emsref(8) * sncovr_ice(i) - elseif (snowf(i) > f_zero) then - asnow = 0.02*snowf(i) + elseif (snodi(i) > f_zero) then + asnow = 0.02*snodi(i) argh = min(0.50, max(.025,0.01*zorlf(i))) hrgh = min(f_one,max(0.20,1.0577-1.1538e-3*hprif(i))) fsno = asnow / (argh + asnow) * hrgh - fsnoi = min(f_one, fsno / (fraci(i)+fracl(i))) - sfcemis_ice = emsref(7)*(f_one-fsnoi)+emsref(8)*fsnoi + sfcemis_ice = emsref(7)*(f_one-fsno) + emsref(8)*fsno endif semis_ice(i) = sfcemis_ice else diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 9588c7bd8..d9594c46c 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 9588c7bd89e4f51a924f766e313bc42830fb4479 +Subproject commit d9594c46c877a2ab8001f5cd37961efdcf08ad8e From 7c1b474bd0de3e048794d191c248563a5c708952 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 18 Oct 2021 14:31:56 +0000 Subject: [PATCH 31/36] updating rte-rrtmgp pointer --- physics/rte-rrtmgp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index d9594c46c..9588c7bd8 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit d9594c46c877a2ab8001f5cd37961efdcf08ad8e +Subproject commit 9588c7bd89e4f51a924f766e313bc42830fb4479 From f6f3ce0540c64355e89270ddfac209257a4716b4 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 19 Oct 2021 14:56:16 +0000 Subject: [PATCH 32/36] updating GFS_surface_composites to import sfcemis_wat --- physics/GFS_surface_composites.F90 | 19 +++++-------------- physics/GFS_surface_composites.meta | 9 +++++++++ 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 2ad6ef3d8..879f6e79e 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -319,9 +319,8 @@ end subroutine GFS_surface_composites_inter_finalize !> \section arg_table_GFS_surface_composites_inter_run Argument Table !! \htmlinclude GFS_surface_composites_inter_run.html !! -! subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis_lnd, semis_ice, adjsfcdlw, & - subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_lnd, semis_ice, adjsfcdlw, & - gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat, & + subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis_lnd, semis_ice, & + adjsfcdlw, gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat,& adjsfcusw, adjsfcdsw, adjsfcnsw, errmsg, errflg) implicit none @@ -329,23 +328,15 @@ subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_lnd, semis ! Interface variables integer, intent(in ) :: im logical, dimension(:), intent(in ) :: dry, icy, wet -! real(kind=kind_phys), dimension(:), intent(in ) :: semis_wat, semis_lnd, semis_ice, adjsfcdlw, & - real(kind=kind_phys), dimension(:), intent(in ) :: semis_lnd, semis_ice, adjsfcdlw, & - adjsfcdsw, adjsfcnsw + real(kind=kind_phys), dimension(:), intent(in ) :: semis_wat, semis_lnd, semis_ice, adjsfcdlw, & + adjsfcdlw, adjsfcdsw, adjsfcnsw real(kind=kind_phys), dimension(:), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat real(kind=kind_phys), dimension(:), intent(out) :: adjsfcusw ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - ! - !-- reference emiss value for surface emissivity in setemis - ! 1-open water, 2-grass/shrub land, 3-bare soil, tundra, - ! 4-sandy desert, 5-rocky desert, 6-forest, 7-ice, 8-snow - !data emsref / 0.97, 0.95, 0.94, 0.90, 0.93, 0.96, 0.96, 0.99 / - real(kind=kind_phys), parameter :: semis_wat = 0.97_kind_phys ! consistent with setemis - ! Local variables integer :: i @@ -374,7 +365,7 @@ subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_lnd, semis do i=1,im if (dry(i)) gabsbdlw_lnd(i) = semis_lnd(i) * adjsfcdlw(i) if (icy(i)) gabsbdlw_ice(i) = semis_ice(i) * adjsfcdlw(i) - if (wet(i)) gabsbdlw_wat(i) = semis_wat * adjsfcdlw(i) + if (wet(i)) gabsbdlw_wat(i) = semis_wat(i) * adjsfcdlw(i) adjsfcusw(i) = adjsfcdsw(i) - adjsfcnsw(i) enddo diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 7d60d2b82..f5cc0ce46 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -590,6 +590,15 @@ type = logical intent = in optional = F +[sfcemis_wat] + standard_name = surface_longwave_emissivity_over_water + long_name = surface lw emissivity in fraction over water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [semis_lnd] standard_name = surface_longwave_emissivity_over_land long_name = surface lw emissivity in fraction over land From 42e7b97d3fe12a23285c43972dc9a3e5e9784c34 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 19 Oct 2021 15:04:39 +0000 Subject: [PATCH 33/36] fix a typo in GFS_radiation_surface.F90 --- physics/GFS_surface_composites.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 879f6e79e..14bc48cd7 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -328,7 +328,7 @@ subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis ! Interface variables integer, intent(in ) :: im logical, dimension(:), intent(in ) :: dry, icy, wet - real(kind=kind_phys), dimension(:), intent(in ) :: semis_wat, semis_lnd, semis_ice, adjsfcdlw, & + real(kind=kind_phys), dimension(:), intent(in ) :: semis_wat, semis_lnd, semis_ice, & adjsfcdlw, adjsfcdsw, adjsfcnsw real(kind=kind_phys), dimension(:), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat real(kind=kind_phys), dimension(:), intent(out) :: adjsfcusw From bc6a7c3006cc58bac76e6cf7b04fdd5207a239b0 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 19 Oct 2021 16:15:46 +0000 Subject: [PATCH 34/36] fix typo in GFS_surface_composites.meta --- physics/GFS_surface_composites.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index f5cc0ce46..06678f1cb 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -590,7 +590,7 @@ type = logical intent = in optional = F -[sfcemis_wat] +[semis_wat] standard_name = surface_longwave_emissivity_over_water long_name = surface lw emissivity in fraction over water units = frac From 3d4e05642bfc11c1993fb0aa86303fccfa45b49c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 20 Oct 2021 18:12:48 +0000 Subject: [PATCH 35/36] replacing snodl by snodi in call to setalb --- physics/GFS_radiation_surface.F90 | 2 +- physics/radiation_surface.f | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index d48bce332..69cb25e81 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -184,7 +184,7 @@ subroutine GFS_radiation_surface_run ( & !> - Call module_radiation_surface::setalb(),to set up surface !! albedor for SW radiation. - call setalb (slmsk, lsm, lsm_noahmp, lsm_ruc, use_cice_alb, snodl, sncovr, sncovr_ice, & + call setalb (slmsk, lsm, lsm_noahmp, lsm_ruc, use_cice_alb, snodi, sncovr, sncovr_ice, & snoalb, zorl, coszen, tsfg, tsfa, hprime, frac_grid, lakefrac, & ! snoalb, zorl, coszen, tsfg, tsfa, hprime, frac_grid, min_seaice, & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 05e62ae88..c432b3ac9 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -332,7 +332,7 @@ end subroutine sfc_init !! @{ !----------------------------------- subroutine setalb & - & ( slmsk,lsm,lsm_noahmp,lsm_ruc,use_cice_alb,snowf, & ! --- inputs: + & ( slmsk,lsm,lsm_noahmp,lsm_ruc,use_cice_alb,snodi, & ! --- inputs: & sncovr,sncovr_ice,snoalb,zorlf,coszf, & & tsknf,tairf,hprif,frac_grid, lakefrac, & & alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc, & @@ -358,7 +358,7 @@ subroutine setalb & ! ! ! inputs: ! ! slmsk (IMAX) - sea(0),land(1),ice(2) mask on fcst model grid ! -! snowf (IMAX) - snow depth water equivalent in mm ! +! snodi (IMAX) - snow depth water equivalent in mm over ice ! ! sncovr(IMAX) - ialgflg=0: not used ! ! ialgflg=1: snow cover over land in fraction ! ! sncovr_ice(IMAX) - ialgflg=0: not used ! @@ -410,7 +410,7 @@ subroutine setalb & real (kind=kind_phys), dimension(:), intent(in) :: & & lakefrac, & - & slmsk, snowf, zorlf, coszf, tsknf, tairf, hprif, & + & slmsk, snodi, zorlf, coszf, tsknf, tairf, hprif, & & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & & icealbdvis, icealbdnir, icealbivis, icealbinir, & & sncovr, sncovr_ice, snoalb, albPpert ! sfc-perts, mgehne @@ -478,7 +478,7 @@ subroutine setalb & asevb_ice = icealbdvis(i) asenb_ice = icealbdnir(i) else - asnow = 0.02*snowf(i) + asnow = 0.02*snodi(i) argh = min(0.50, max(.025, 0.01*zorlf(i))) hrgh = min(f_one,max(0.20,1.0577-1.1538e-3*hprif(i))) fsno0 = asnow / (argh + asnow) * hrgh ! snow fraction on ice @@ -614,7 +614,7 @@ subroutine setalb & asenb_ice = icealbdnir(i) else !-- Computation of ice albedo - asnow = 0.02*snowf(i) + asnow = 0.02*snodi(i) argh = min(0.50, max(.025, 0.01*zorlf(i))) hrgh = min(f_one,max(0.20,1.0577-1.1538e-3*hprif(i))) fsno0 = asnow / (argh + asnow) * hrgh @@ -750,7 +750,7 @@ subroutine setemis & ! range, otherwise see in-line comment ! ! slmsk (IMAX) - sea(0),land(1),ice(2) mask on fcst model grid ! ! snodl (IMAX) - snow depth water equivalent in mm over land ! -! snodi (IMAX) - snow depth water equivalent in mm over ice ! +! snodi (IMAX) - snow depth water equivalent in mm over ice ! ! sncovr(IMAX) - ialbflg=1: snow cover over land in fraction ! ! sncovr_ice(IMAX) - snow cover over ice in fraction ! ! zorlf (IMAX) - surface roughness in cm ! From 6c0183e6c6ff6459caf297498b4819d36625d94b Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 20 Oct 2021 18:52:16 +0000 Subject: [PATCH 36/36] updating comments in radiation_surface.f --- physics/radiation_surface.f | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index c432b3ac9..066bcfbef 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -20,18 +20,22 @@ ! ! ! 'setalb' -- set up four-component surface albedoes ! ! inputs: ! -! (slmsk,snowf,sncovr,snoalb,zorlf,coszf,tsknf,tairf,hprif, ! +! (slmsk,snodi,sncovr,snoalb,zorlf,coszf,tsknf,tairf,hprif, ! ! alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc ! ! IMAX) ! ! outputs: ! ! (sfcalb) ! ! ! ! 'setemis' -- set up surface emissivity for lw radiation ! -! inputs: ! -! (xlon,xlat,slmsk,snowf,sncovr,zorlf,tsknf,tairf,hprif, ! -! IMAX) ! -! outputs: ! -! (sfcemis) ! +! ( lsm,lsm_noahmp,lsm_ruc,frac_grid,cplice,use_flake, ! +! --- inputs: +! lakefrac,xlon,xlat,slmsk,snodl,snodi,sncovr,sncovr_ice, ! +! zorlf,tsknf,tairf,hprif, ! +! semis_lnd,semis_ice,semis_wat,IMAX,fracl,fraco,fraci,icy, ! +! +! --- outputs: +! semisbase, sfcemis ! +! ! ! ! external modules referenced: ! ! ! @@ -298,7 +302,7 @@ end subroutine sfc_init !! \n 1) climatological surface albedo scheme (\cite briegleb_1992) !! \n 2) MODIS retrieval based scheme from Boston univ. !!\param slmsk (IMAX), sea(0),land(1),ice(2) mask on fcst model grid -!!\param snowf (IMAX), snow depth water equivalent in mm over land +!!\param snodi (IMAX), snow depth water equivalent in mm over ice !!\param sncovr (IMAX), snow cover over land !!\param snoalb (IMAX), maximum snow albedo over land (for deep snow) !!\param zorlf (IMAX), surface roughness in cm