Skip to content

Commit

Permalink
Merge branch 'main' of https://github.com/NCAR/ccpp-physics into bugf…
Browse files Browse the repository at this point in the history 
…ix/SPP
  • Loading branch information
@JeffBeck-NOAA
JeffBeck-NOAA committed Apr 7, 2022
2 parents fdc9b2e + b1326ba commit 2e8f340
Show file tree
Hide file tree
Showing 12 changed files with 332 additions and 134 deletions.
29 changes: 26 additions & 3 deletions physics/GFS_PBL_generic.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -395,8 +395,8 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac,
ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev,nqrimef, &
trans_aero, ntchs, ntchm, ntccn, nthl, nthnc, ntgv, nthv, &
imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, imp_physics_mg, &
imp_physics_fer_hires, imp_physics_nssl, nssl_ccn_on, &
ltaerosol, nssl_hail_on, cplflx, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf,&
imp_physics_fer_hires, imp_physics_nssl, nssl_ccn_on, ltaerosol, nssl_hail_on, &
cplflx, cplaqm, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, &
shinhong, do_ysu, dvdftra, dusfc1, dvsfc1, dtsfc1, dqsfc1, dtf, dudt, dvdt, dtdt, htrsw, htrlw, xmu, &
dqdt, dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, &
index_of_process_pbl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, &
Expand All @@ -419,7 +419,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac,
integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires
integer, intent(in) :: imp_physics_nssl
logical, intent(in) :: nssl_ccn_on, nssl_hail_on
logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, lsidea
logical, intent(in) :: ltaerosol, cplflx, cplaqm, cplchm, lssav, ldiag3d, lsidea
logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu

logical, intent(in) :: flag_for_pbl_generic_tend
Expand Down Expand Up @@ -741,6 +741,29 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac,
end if
end if

if (cplaqm .and. .not.cplflx) then
do i=1,im
if (oceanfrac(i) > zero) then ! Ocean only, NO LAKES
if ( .not. wet(i)) then ! no open water
if (kdt > 1) then !use results from CICE
dtsfci_cpl(i) = dtsfc_cice(i)
dqsfci_cpl(i) = dqsfc_cice(i)
else !use PBL fluxes when CICE fluxes is unavailable
dtsfci_cpl(i) = dtsfc1(i)*hffac(i)
dqsfci_cpl(i) = dqsfc1(i)
end if
elseif (icy(i) .or. dry(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point
rho = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin)))
dtsfci_cpl(i) = cp * rho * hflx_wat(i) ! sensible heat flux over open ocean
dqsfci_cpl(i) = hvap * rho * evap_wat(i) ! latent heat flux over open ocean
else ! use results from PBL scheme for 100% open ocean
dtsfci_cpl(i) = dtsfc1(i)*hffac(i)
dqsfci_cpl(i) = dqsfc1(i)
endif
endif ! Ocean only, NO LAKES
enddo
end if

!-------------------------------------------------------lssav if loop ----------
if (lssav) then
do i=1,im
Expand Down
7 changes: 7 additions & 0 deletions physics/GFS_PBL_generic.meta
View file
Original file line number Diff line number Diff line change
Expand Up @@ -728,6 +728,13 @@
dimensions = ()
type = logical
intent = in
[cplaqm]
standard_name = flag_for_air_quality_coupling
long_name = flag controlling cplaqm collection (default off)
units = flag
dimensions = ()
type = logical
intent = in
[cplchm]
standard_name = flag_for_chemistry_coupling
long_name = flag controlling cplchm collection (default off)
Expand Down
32 changes: 30 additions & 2 deletions physics/GFS_surface_generic.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -274,7 +274,7 @@ end subroutine GFS_surface_generic_post_finalize
!> \section arg_table_GFS_surface_generic_post_run Argument Table
!! \htmlinclude GFS_surface_generic_post_run.html
!!
subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, icy, wet, &
subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, lssav, dry, icy, wet, &
lsm, lsm_noahmp, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, &
adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, &
adjvisbmu, adjvisdfu, t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, pah, pahi, &
Expand All @@ -288,7 +288,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry,
implicit none

integer, intent(in) :: im
logical, intent(in) :: cplflx, cplchm, cplwav, lssav
logical, intent(in) :: cplflx, cplaqm, cplchm, cplwav, lssav
logical, dimension(:), intent(in) :: dry, icy, wet
integer, intent(in) :: lsm, lsm_noahmp
real(kind=kind_phys), intent(in) :: dtf
Expand Down Expand Up @@ -416,6 +416,34 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry,
enddo
endif

if (cplaqm .and. .not.cplflx) then
do i=1,im
t2mi_cpl (i) = t2m(i)
q2mi_cpl (i) = q2m(i)
psurfi_cpl (i) = pgr(i)
if (wet(i)) then ! some open water
! --- compute open water albedo
xcosz_loc = max( zero, min( one, xcosz(i) ))
ocalnirdf_cpl = 0.06_kind_phys
ocalnirbm_cpl = max(albdf, 0.026_kind_phys/(xcosz_loc**1.7_kind_phys+0.065_kind_phys) &
& + 0.15_kind_phys * (xcosz_loc-0.1_kind_phys) * (xcosz_loc-0.5_kind_phys) &
& * (xcosz_loc-one))
ocalvisdf_cpl = 0.06_kind_phys
ocalvisbm_cpl = ocalnirbm_cpl

nswsfci_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl) + &
adjnirdfd(i) * (one-ocalnirdf_cpl) + &
adjvisbmd(i) * (one-ocalvisbm_cpl) + &
adjvisdfd(i) * (one-ocalvisdf_cpl)
else
nswsfci_cpl(i) = adjnirbmd(i) - adjnirbmu(i) + &
adjnirdfd(i) - adjnirdfu(i) + &
adjvisbmd(i) - adjvisbmu(i) + &
adjvisdfd(i) - adjvisdfu(i)
endif
enddo
endif

if (lssav) then
do i=1,im
gflux(i) = gflux(i) + gflx(i) * dtf
Expand Down
7 changes: 7 additions & 0 deletions physics/GFS_surface_generic.meta
View file
Original file line number Diff line number Diff line change
Expand Up @@ -558,6 +558,13 @@
dimensions = ()
type = logical
intent = in
[cplaqm]
standard_name = flag_for_air_quality_coupling
long_name = flag controlling cplaqm collection (default off)
units = flag
dimensions = ()
type = logical
intent = in
[cplchm]
standard_name = flag_for_chemistry_coupling
long_name = flag controlling cplchm collection (default off)
Expand Down
23 changes: 16 additions & 7 deletions physics/mfpbltq.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@
subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt,
& cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx,
& gdx,hpbl,kpbl,vpert,buo,xmf,
& tcko,qcko,ucko,vcko,xlamue,a1)
& tcko,qcko,ucko,vcko,xlamueq,a1)
!
use machine , only : kind_phys
use funcphys , only : fpvs
Expand All @@ -35,14 +35,15 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt,
& buo(im,km), xmf(im,km),
& tcko(im,km),qcko(im,km,ntrac1),
& ucko(im,km),vcko(im,km),
& xlamue(im,km-1)
& xlamueq(im,km-1)
!
c local variables and arrays
!
integer i, j, k, n, ndc
integer kpblx(im), kpbly(im)
!
real(kind=kind_phys) dt2, dz, ce0, cm,
real(kind=kind_phys) dt2, dz, ce0,
& cm, cq,
& factor, gocp,
& g, b1, f1,
& bb1, bb2,
Expand All @@ -56,7 +57,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt,
& thup, thvu, dq
!
real(kind=kind_phys) rbdn(im), rbup(im), hpblx(im),
& xlamuem(im,km-1)
& xlamue(im,km-1), xlamuem(im,km-1)
real(kind=kind_phys) delz(im), xlamax(im)
!
real(kind=kind_phys) wu2(im,km), thlu(im,km),
Expand All @@ -71,7 +72,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt,
parameter(g=grav)
parameter(gocp=g/cp)
parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp))
parameter(ce0=0.4,cm=1.0)
parameter(ce0=0.4,cm=1.0,cq=1.3)
parameter(qmin=1.e-8,qlmin=1.e-12)
parameter(alp=1.5,vpertmax=3.0,pgcon=0.55)
parameter(b1=0.5,f1=0.15)
Expand Down Expand Up @@ -132,6 +133,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt,
xlamue(i,k) = xlamax(i)
endif
!
xlamueq(i,k) = cq * xlamue(i,k)
xlamuem(i,k) = cm * xlamue(i,k)
endif
enddo
Expand All @@ -148,6 +150,9 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt,
!
thlu(i,k) = ((1.-tem)*thlu(i,k-1)+tem*
& (thlx(i,k-1)+thlx(i,k)))/factor
!
tem = 0.5 * xlamueq(i,k-1) * dz
factor = 1. + tem
qtu(i,k) = ((1.-tem)*qtu(i,k-1)+tem*
& (qtx(i,k-1)+qtx(i,k)))/factor
!
Expand Down Expand Up @@ -282,6 +287,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt,
xlamue(i,k) = xlamax(i)
endif
!
xlamueq(i,k) = cq * xlamue(i,k)
xlamuem(i,k) = cm * xlamue(i,k)
endif
enddo
Expand Down Expand Up @@ -384,6 +390,9 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt,
!
thlu(i,k) = ((1.-tem)*thlu(i,k-1)+tem*
& (thlx(i,k-1)+thlx(i,k)))/factor
!
tem = 0.5 * xlamueq(i,k-1) * dz
factor = 1. + tem
qtu(i,k) = ((1.-tem)*qtu(i,k-1)+tem*
& (qtx(i,k-1)+qtx(i,k)))/factor
!
Expand Down Expand Up @@ -432,7 +441,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt,
do i = 1, im
if (cnvflg(i) .and. k <= kpbl(i)) then
dz = zl(i,k) - zl(i,k-1)
tem = 0.5 * xlamue(i,k-1) * dz
tem = 0.5 * xlamueq(i,k-1) * dz
factor = 1. + tem
!
qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem*
Expand All @@ -453,7 +462,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt,
do i = 1, im
if (cnvflg(i) .and. k <= kpbl(i)) then
dz = zl(i,k) - zl(i,k-1)
tem = 0.5 * xlamue(i,k-1) * dz
tem = 0.5 * xlamueq(i,k-1) * dz
factor = 1. + tem
!
qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem*
Expand Down
23 changes: 16 additions & 7 deletions physics/mfscuq.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt,
& cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,
& thlx,thvx,thlvx,gdx,thetae,
& krad,mrad,radmin,buo,xmfd,
& tcdo,qcdo,ucdo,vcdo,xlamde,a1)
& tcdo,qcdo,ucdo,vcdo,xlamdeq,a1)
!
use machine , only : kind_phys
use funcphys , only : fpvs
Expand Down Expand Up @@ -39,15 +39,16 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt,
& buo(im,km), xmfd(im,km),
& tcdo(im,km), qcdo(im,km,ntrac1),
& ucdo(im,km), vcdo(im,km),
& xlamde(im,km-1)
& xlamdeq(im,km-1)
!
! local variables and arrays
!
!
integer i,j,indx, k, n, kk, ndc
integer krad1(im)
!
real(kind=kind_phys) dt2, dz, ce0, cm,
real(kind=kind_phys) dt2, dz, ce0,
& cm, cq,
& gocp, factor, g, tau,
& b1, f1, bb1, bb2,
& a1, a2,
Expand All @@ -62,7 +63,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt,
!
real(kind=kind_phys) wd2(im,km), thld(im,km),
& qtx(im,km), qtd(im,km),
& thlvd(im), hrad(im),
& thlvd(im), hrad(im), xlamde(im,km-1),
& xlamdem(im,km-1), ra1(im)
real(kind=kind_phys) delz(im), xlamax(im)
!
Expand All @@ -77,7 +78,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt,
parameter(g=grav)
parameter(gocp=g/cp)
parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp))
parameter(ce0=0.4,cm=1.0,pgcon=0.55)
parameter(ce0=0.4,cm=1.0,cq=1.3,pgcon=0.55)
parameter(qmin=1.e-8,qlmin=1.e-12)
parameter(b1=0.45,f1=0.15)
parameter(a2=0.5)
Expand Down Expand Up @@ -208,6 +209,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt,
xlamde(i,k) = xlamax(i)
endif
!
xlamdeq(i,k) = cq * xlamde(i,k)
xlamdem(i,k) = cm * xlamde(i,k)
endif
enddo
Expand All @@ -224,6 +226,9 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt,
!
thld(i,k) = ((1.-tem)*thld(i,k+1)+tem*
& (thlx(i,k)+thlx(i,k+1)))/factor
!
tem = 0.5 * xlamdeq(i,k) * dz
factor = 1. + tem
qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem*
& (qtx(i,k)+qtx(i,k+1)))/factor
!
Expand Down Expand Up @@ -347,6 +352,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt,
xlamde(i,k) = xlamax(i)
endif
!
xlamdeq(i,k) = cq * xlamde(i,k)
xlamdem(i,k) = cm * xlamde(i,k)
endif
enddo
Expand Down Expand Up @@ -457,6 +463,9 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt,
!
thld(i,k) = ((1.-tem)*thld(i,k+1)+tem*
& (thlx(i,k)+thlx(i,k+1)))/factor
!
tem = 0.5 * xlamdeq(i,k) * dz
factor = 1. + tem
qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem*
& (qtx(i,k)+qtx(i,k+1)))/factor
!
Expand Down Expand Up @@ -509,7 +518,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt,
if (cnvflg(i) .and. k < krad(i)) then
if(k >= mrad(i)) then
dz = zl(i,k+1) - zl(i,k)
tem = 0.5 * xlamde(i,k) * dz
tem = 0.5 * xlamdeq(i,k) * dz
factor = 1. + tem
!
qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem*
Expand All @@ -532,7 +541,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt,
if (cnvflg(i) .and. k < krad(i)) then
if(k >= mrad(i)) then
dz = zl(i,k+1) - zl(i,k)
tem = 0.5 * xlamde(i,k) * dz
tem = 0.5 * xlamdeq(i,k) * dz
factor = 1. + tem
!
qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem*
Expand Down
9 changes: 8 additions & 1 deletion physics/module_mp_thompson.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4081,7 +4081,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
do k = kte, kts, -1
vtg = 0.
if (rg(k).gt. R1) then
vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g
ygra1 = alog10(max(1.E-9, rg(k)))
zans1 = 3.0 + 2./7.*(ygra1+8.) + rand1
N0_exp = 10.**(zans1)
N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max)))
lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1
lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg

vtg = rhof(k)*av_g*cgg(6)*ogg3 * (1./lamg)**bv_g
if (temp(k).gt. T_0) then
vtgk(k) = MAX(vtg, vtrk(k))
else
Expand Down
Loading

0 comments on commit 2e8f340

Please sign in to comment.