Skip to content

Commit

Permalink
Merge branch 'GFS_DDT_removal' of https://github.com/grantfirl/ccpp-p…
Browse files Browse the repository at this point in the history 
…hysics into HEAD
  • Loading branch information
@climbfuji
climbfuji committed Oct 6, 2020
2 parents 5540bd6 + 04af628 commit 474144f
Show file tree
Hide file tree
Showing 20 changed files with 2,124 additions and 1,109 deletions.
159 changes: 80 additions & 79 deletions physics/GFS_rrtmg_post.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,43 +11,44 @@ end subroutine GFS_rrtmg_post_init
!> \section arg_table_GFS_rrtmg_post_run Argument Table
!! \htmlinclude GFS_rrtmg_post_run.html
!!
subroutine GFS_rrtmg_post_run (Model, Grid, Diag, Radtend, Statein, &
Coupling, scmpsw, im, lm, ltp, kt, kb, kd, raddt, aerodp, &
cldsa, mtopa, mbota, clouds1, cldtaulw, cldtausw, nday, &
errmsg, errflg)
subroutine GFS_rrtmg_post_run (im, km, kmp1, lm, ltp, kt, kb, kd, nspc1, &
nfxr, nday, lsswr, lslwr, lssav, fhlwr, fhswr, raddt, coszen, &
coszdg, prsi, tgrs, aerodp, cldsa, mtopa, mbota, clouds1, &
cldtaulw, cldtausw, sfcflw, sfcfsw, topflw, topfsw, scmpsw, &
fluxr, errmsg, errflg)

use machine, only: kind_phys
use GFS_typedefs, only: GFS_statein_type, &
GFS_coupling_type, &
GFS_control_type, &
GFS_grid_type, &
GFS_radtend_type, &
GFS_diag_type
use module_radiation_aerosols, only: NSPC1
use module_radsw_parameters, only: cmpfsw_type
use module_radsw_parameters, only: topfsw_type, sfcfsw_type, &
cmpfsw_type
use module_radlw_parameters, only: topflw_type, sfcflw_type
use module_radsw_parameters, only: topfsw_type, sfcfsw_type

implicit none

! Interface variables
type(GFS_control_type), intent(in) :: Model
type(GFS_grid_type), intent(in) :: Grid
type(GFS_statein_type), intent(in) :: Statein
type(GFS_coupling_type), intent(inout) :: Coupling
type(GFS_radtend_type), intent(in) :: Radtend
type(GFS_diag_type), intent(inout) :: Diag
type(cmpfsw_type), dimension(size(Grid%xlon,1)), intent(in) :: scmpsw

integer, intent(in) :: im, lm, ltp, kt, kb, kd, nday
real(kind=kind_phys), intent(in) :: raddt

real(kind=kind_phys), dimension(size(Grid%xlon,1),NSPC1), intent(in) :: aerodp
real(kind=kind_phys), dimension(size(Grid%xlon,1),5), intent(in) :: cldsa
integer, dimension(size(Grid%xlon,1),3), intent(in) :: mbota, mtopa
real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(in) :: clouds1
real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(in) :: cldtausw
real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(in) :: cldtaulw
integer, intent(in) :: im, km, kmp1, lm, ltp, kt, kb, kd, &
nspc1, nfxr, nday
logical, intent(in) :: lsswr, lslwr, lssav
real(kind=kind_phys), intent(in) :: raddt, fhlwr, fhswr

real(kind=kind_phys), dimension(im), intent(in) :: coszen, coszdg

real(kind=kind_phys), dimension(im,kmp1), intent(in) :: prsi
real(kind=kind_phys), dimension(im,km), intent(in) :: tgrs

real(kind=kind_phys), dimension(im,NSPC1), intent(in) :: aerodp
real(kind=kind_phys), dimension(im,5), intent(in) :: cldsa
integer, dimension(im,3), intent(in) :: mbota, mtopa
real(kind=kind_phys), dimension(im,lm+LTP), intent(in) :: clouds1
real(kind=kind_phys), dimension(im,lm+LTP), intent(in) :: cldtausw
real(kind=kind_phys), dimension(im,lm+LTP), intent(in) :: cldtaulw

type(sfcflw_type), dimension(im), intent(in) :: sfcflw
type(sfcfsw_type), dimension(im), intent(in) :: sfcfsw
type(cmpfsw_type), dimension(im), intent(in) :: scmpsw
type(topflw_type), dimension(im), intent(in) :: topflw
type(topfsw_type), dimension(im), intent(in) :: topfsw

real(kind=kind_phys), dimension(im,nfxr), intent(inout) :: fluxr

character(len=*), intent(out) :: errmsg
integer, intent(out) :: errflg
Expand All @@ -60,7 +61,7 @@ subroutine GFS_rrtmg_post_run (Model, Grid, Diag, Radtend, Statein, &
errmsg = ''
errflg = 0

if (.not. (Model%lsswr .or. Model%lslwr)) return
if (.not. (lsswr .or. lslwr)) return

!> - For time averaged output quantities (including total-sky and
!! clear-sky SW and LW fluxes at TOA and surface; conventional
Expand All @@ -70,77 +71,77 @@ subroutine GFS_rrtmg_post_run (Model, Grid, Diag, Radtend, Statein, &

! --- ... collect the fluxr data for wrtsfc

if (Model%lssav) then
if (Model%lsswr) then
if (lssav) then
if (lsswr) then
do i=1,im
! Diag%fluxr(i,34) = Diag%fluxr(i,34) + Model%fhswr*aerodp(i,1) ! total aod at 550nm
! Diag%fluxr(i,35) = Diag%fluxr(i,35) + Model%fhswr*aerodp(i,2) ! DU aod at 550nm
! Diag%fluxr(i,36) = Diag%fluxr(i,36) + Model%fhswr*aerodp(i,3) ! BC aod at 550nm
! Diag%fluxr(i,37) = Diag%fluxr(i,37) + Model%fhswr*aerodp(i,4) ! OC aod at 550nm
! Diag%fluxr(i,38) = Diag%fluxr(i,38) + Model%fhswr*aerodp(i,5) ! SU aod at 550nm
! Diag%fluxr(i,39) = Diag%fluxr(i,39) + Model%fhswr*aerodp(i,6) ! SS aod at 550nm
Diag%fluxr(i,34) = aerodp(i,1) ! total aod at 550nm
Diag%fluxr(i,35) = aerodp(i,2) ! DU aod at 550nm
Diag%fluxr(i,36) = aerodp(i,3) ! BC aod at 550nm
Diag%fluxr(i,37) = aerodp(i,4) ! OC aod at 550nm
Diag%fluxr(i,38) = aerodp(i,5) ! SU aod at 550nm
Diag%fluxr(i,39) = aerodp(i,6) ! SS aod at 550nm
! fluxr(i,34) = fluxr(i,34) + fhswr*aerodp(i,1) ! total aod at 550nm
! fluxr(i,35) = fluxr(i,35) + fhswr*aerodp(i,2) ! DU aod at 550nm
! fluxr(i,36) = fluxr(i,36) + fhswr*aerodp(i,3) ! BC aod at 550nm
! fluxr(i,37) = fluxr(i,37) + fhswr*aerodp(i,4) ! OC aod at 550nm
! fluxr(i,38) = fluxr(i,38) + fhswr*aerodp(i,5) ! SU aod at 550nm
! fluxr(i,39) = fluxr(i,39) + fhswr*aerodp(i,6) ! SS aod at 550nm
fluxr(i,34) = aerodp(i,1) ! total aod at 550nm
fluxr(i,35) = aerodp(i,2) ! DU aod at 550nm
fluxr(i,36) = aerodp(i,3) ! BC aod at 550nm
fluxr(i,37) = aerodp(i,4) ! OC aod at 550nm
fluxr(i,38) = aerodp(i,5) ! SU aod at 550nm
fluxr(i,39) = aerodp(i,6) ! SS aod at 550nm
enddo
endif

! --- save lw toa and sfc fluxes
if (Model%lslwr) then
if (lslwr) then
do i=1,im
! --- lw total-sky fluxes
Diag%fluxr(i,1 ) = Diag%fluxr(i,1 ) + Model%fhlwr * Diag%topflw(i)%upfxc ! total sky top lw up
Diag%fluxr(i,19) = Diag%fluxr(i,19) + Model%fhlwr * Radtend%sfcflw(i)%dnfxc ! total sky sfc lw dn
Diag%fluxr(i,20) = Diag%fluxr(i,20) + Model%fhlwr * Radtend%sfcflw(i)%upfxc ! total sky sfc lw up
fluxr(i,1 ) = fluxr(i,1 ) + fhlwr * topflw(i)%upfxc ! total sky top lw up
fluxr(i,19) = fluxr(i,19) + fhlwr * sfcflw(i)%dnfxc ! total sky sfc lw dn
fluxr(i,20) = fluxr(i,20) + fhlwr * sfcflw(i)%upfxc ! total sky sfc lw up
! --- lw clear-sky fluxes
Diag%fluxr(i,28) = Diag%fluxr(i,28) + Model%fhlwr * Diag%topflw(i)%upfx0 ! clear sky top lw up
Diag%fluxr(i,30) = Diag%fluxr(i,30) + Model%fhlwr * Radtend%sfcflw(i)%dnfx0 ! clear sky sfc lw dn
Diag%fluxr(i,33) = Diag%fluxr(i,33) + Model%fhlwr * Radtend%sfcflw(i)%upfx0 ! clear sky sfc lw up
fluxr(i,28) = fluxr(i,28) + fhlwr * topflw(i)%upfx0 ! clear sky top lw up
fluxr(i,30) = fluxr(i,30) + fhlwr * sfcflw(i)%dnfx0 ! clear sky sfc lw dn
fluxr(i,33) = fluxr(i,33) + fhlwr * sfcflw(i)%upfx0 ! clear sky sfc lw up
enddo
endif

! --- save sw toa and sfc fluxes with proper diurnal sw wgt. coszen=mean cosz over daylight
! part of sw calling interval, while coszdg= mean cosz over entire interval
if (Model%lsswr) then
if (lsswr) then
do i = 1, IM
if (Radtend%coszen(i) > 0.) then
if (coszen(i) > 0.) then
! --- sw total-sky fluxes
! -------------------
tem0d = Model%fhswr * Radtend%coszdg(i) / Radtend%coszen(i)
Diag%fluxr(i,2 ) = Diag%fluxr(i,2) + Diag%topfsw(i)%upfxc * tem0d ! total sky top sw up
Diag%fluxr(i,3 ) = Diag%fluxr(i,3) + Radtend%sfcfsw(i)%upfxc * tem0d ! total sky sfc sw up
Diag%fluxr(i,4 ) = Diag%fluxr(i,4) + Radtend%sfcfsw(i)%dnfxc * tem0d ! total sky sfc sw dn
tem0d = fhswr * coszdg(i) / coszen(i)
fluxr(i,2 ) = fluxr(i,2) + topfsw(i)%upfxc * tem0d ! total sky top sw up
fluxr(i,3 ) = fluxr(i,3) + sfcfsw(i)%upfxc * tem0d ! total sky sfc sw up
fluxr(i,4 ) = fluxr(i,4) + sfcfsw(i)%dnfxc * tem0d ! total sky sfc sw dn
! --- sw uv-b fluxes
! --------------
Diag%fluxr(i,21) = Diag%fluxr(i,21) + scmpsw(i)%uvbfc * tem0d ! total sky uv-b sw dn
Diag%fluxr(i,22) = Diag%fluxr(i,22) + scmpsw(i)%uvbf0 * tem0d ! clear sky uv-b sw dn
fluxr(i,21) = fluxr(i,21) + scmpsw(i)%uvbfc * tem0d ! total sky uv-b sw dn
fluxr(i,22) = fluxr(i,22) + scmpsw(i)%uvbf0 * tem0d ! clear sky uv-b sw dn
! --- sw toa incoming fluxes
! ----------------------
Diag%fluxr(i,23) = Diag%fluxr(i,23) + Diag%topfsw(i)%dnfxc * tem0d ! top sw dn
fluxr(i,23) = fluxr(i,23) + topfsw(i)%dnfxc * tem0d ! top sw dn
! --- sw sfc flux components
! ----------------------
Diag%fluxr(i,24) = Diag%fluxr(i,24) + scmpsw(i)%visbm * tem0d ! uv/vis beam sw dn
Diag%fluxr(i,25) = Diag%fluxr(i,25) + scmpsw(i)%visdf * tem0d ! uv/vis diff sw dn
Diag%fluxr(i,26) = Diag%fluxr(i,26) + scmpsw(i)%nirbm * tem0d ! nir beam sw dn
Diag%fluxr(i,27) = Diag%fluxr(i,27) + scmpsw(i)%nirdf * tem0d ! nir diff sw dn
fluxr(i,24) = fluxr(i,24) + scmpsw(i)%visbm * tem0d ! uv/vis beam sw dn
fluxr(i,25) = fluxr(i,25) + scmpsw(i)%visdf * tem0d ! uv/vis diff sw dn
fluxr(i,26) = fluxr(i,26) + scmpsw(i)%nirbm * tem0d ! nir beam sw dn
fluxr(i,27) = fluxr(i,27) + scmpsw(i)%nirdf * tem0d ! nir diff sw dn
! --- sw clear-sky fluxes
! -------------------
Diag%fluxr(i,29) = Diag%fluxr(i,29) + Diag%topfsw(i)%upfx0 * tem0d ! clear sky top sw up
Diag%fluxr(i,31) = Diag%fluxr(i,31) + Radtend%sfcfsw(i)%upfx0 * tem0d ! clear sky sfc sw up
Diag%fluxr(i,32) = Diag%fluxr(i,32) + Radtend%sfcfsw(i)%dnfx0 * tem0d ! clear sky sfc sw dn
fluxr(i,29) = fluxr(i,29) + topfsw(i)%upfx0 * tem0d ! clear sky top sw up
fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d ! clear sky sfc sw up
fluxr(i,32) = fluxr(i,32) + sfcfsw(i)%dnfx0 * tem0d ! clear sky sfc sw dn
endif
enddo
endif

! --- save total and boundary layer clouds

if (Model%lsswr .or. Model%lslwr) then
if (lsswr .or. lslwr) then
do i=1,im
Diag%fluxr(i,17) = Diag%fluxr(i,17) + raddt * cldsa(i,4)
Diag%fluxr(i,18) = Diag%fluxr(i,18) + raddt * cldsa(i,5)
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
Expand All @@ -152,15 +153,15 @@ subroutine GFS_rrtmg_post_run (Model, Grid, Diag, Radtend, Statein, &
tem0d = raddt * cldsa(i,j)
itop = mtopa(i,j) - kd
ibtc = mbota(i,j) - kd
Diag%fluxr(i, 8-j) = Diag%fluxr(i, 8-j) + tem0d
Diag%fluxr(i,11-j) = Diag%fluxr(i,11-j) + tem0d * Statein%prsi(i,itop+kt)
Diag%fluxr(i,14-j) = Diag%fluxr(i,14-j) + tem0d * Statein%prsi(i,ibtc+kb)
Diag%fluxr(i,17-j) = Diag%fluxr(i,17-j) + tem0d * Statein%tgrs(i,itop)
fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d
fluxr(i,11-j) = fluxr(i,11-j) + tem0d * prsi(i,itop+kt)
fluxr(i,14-j) = fluxr(i,14-j) + tem0d * prsi(i,ibtc+kb)
fluxr(i,17-j) = fluxr(i,17-j) + tem0d * tgrs(i,itop)
enddo
enddo

! Anning adds optical depth and emissivity output
if (Model%lsswr .and. (nday > 0)) then
if (lsswr .and. (nday > 0)) then
do j = 1, 3
do i = 1, IM
tem0d = raddt * cldsa(i,j)
Expand All @@ -170,12 +171,12 @@ subroutine GFS_rrtmg_post_run (Model, Grid, Diag, Radtend, Statein, &
do k=ibtc,itop
tem1 = tem1 + cldtausw(i,k) ! approx .55 um channel
enddo
Diag%fluxr(i,43-j) = Diag%fluxr(i,43-j) + tem0d * tem1
fluxr(i,43-j) = fluxr(i,43-j) + tem0d * tem1
enddo
enddo
endif

if (Model%lslwr) then
if (lslwr) then
do j = 1, 3
do i = 1, IM
tem0d = raddt * cldsa(i,j)
Expand All @@ -185,7 +186,7 @@ subroutine GFS_rrtmg_post_run (Model, Grid, Diag, Radtend, Statein, &
do k=ibtc,itop
tem2 = tem2 + cldtaulw(i,k) ! approx 10. um channel
enddo
Diag%fluxr(i,46-j) = Diag%fluxr(i,46-j) + tem0d * (1.0-exp(-tem2))
fluxr(i,46-j) = fluxr(i,46-j) + tem0d * (1.0-exp(-tem2))
enddo
enddo
endif
Expand Down
Loading

0 comments on commit 474144f

Please sign in to comment.