LCOV - code coverage report
Current view: | top level - physics/rrtmgp/ext/extensions - mo_fluxes_byband.F90 (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 44 | 65 | 67.7 %
Date: | 2024-12-17 22:39:59 |  | Functions: | 4 | 6 | 66.7 %

              Line data    Source code
           1             : ! This code is part of
           2             : ! RRTM for GCM Applications - Parallel (RRTMGP)
           3             : !
           4             : ! Eli Mlawer and Robert Pincus
           5             : ! Andre Wehe and Jennifer Delamere
           6             : ! email:  rrtmgp@aer.com
           7             : !
           8             : ! Copyright 2015,  Atmospheric and Environmental Research and
           9             : ! Regents of the University of Colorado.  All right reserved.
          10             : !
          11             : ! Use and duplication is permitted under the terms of the
          12             : !    BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause
          13             : !
          14             : !
          15             : ! This module is for packaging output quantities from RRTMGP based on spectral flux profiles
          16             : !    This implementation provides band-by-band flux profiles
          17             : !
          18             : module mo_fluxes_byband
          19             :   use mo_rte_kind,      only: wp
          20             :   use mo_rte_config,    only: check_extents
          21             :   use mo_rte_util_array_validation, &
          22             :                         only: extents_are
          23             :   use mo_fluxes,        only: ty_fluxes, ty_fluxes_broadband
          24             :   use mo_optical_props, only: ty_optical_props
          25             :   implicit none
          26             :
          27             :   ! Output from radiation calculations
          28             :   !   Data components are pointers so results can be written directly into memory
          29             :   !   reduce() function accepts spectral flux profiles
          30             :   type, extends(ty_fluxes_broadband) :: ty_fluxes_byband
          31             :     real(wp), dimension(:,:,:), pointer :: bnd_flux_up => NULL(), & ! Band-by-band fluxes
          32             :                                            bnd_flux_dn => NULL()    ! (ncol, nlev, nband)
          33             :     real(wp), dimension(:,:,:), pointer :: bnd_flux_net => NULL()   ! Net (down - up)
          34             :     real(wp), dimension(:,:,:), pointer :: bnd_flux_dn_dir => NULL() ! Direct flux down
          35             :   contains
          36             :     procedure :: reduce => reduce_byband
          37             :     procedure :: are_desired => are_desired_byband
          38             :   end type ty_fluxes_byband
          39             :
          40             :   interface net_byband
          41             :     module procedure net_byband_full, net_byband_precalc
          42             :   end interface net_byband
          43             :
          44             : contains
          45             :   ! --------------------------------------------------------------------------------------
          46     1135399 :   function reduce_byband(this, gpt_flux_up, gpt_flux_dn, spectral_disc, top_at_1, gpt_flux_dn_dir) result(error_msg)
          47             :     class(ty_fluxes_byband),           intent(inout) :: this
          48             :     real(kind=wp), dimension(:,:,:),   intent(in   ) :: gpt_flux_up ! Fluxes by gpoint [W/m2](ncol, nlay+1, ngpt)
          49             :     real(kind=wp), dimension(:,:,:),   intent(in   ) :: gpt_flux_dn ! Fluxes by gpoint [W/m2](ncol, nlay+1, ngpt)
          50             :     class(ty_optical_props),           intent(in   ) :: spectral_disc  !< derived type with spectral information
          51             :     logical,                           intent(in   ) :: top_at_1
          52             :     real(kind=wp), dimension(:,:,:), optional, &
          53             :                                        intent(in   ) :: gpt_flux_dn_dir! Direct flux down
          54             :     character(len=128)                               :: error_msg
          55             :     ! ------
          56             :     integer :: ncol, nlev, ngpt, nbnd
          57     2270798 :     integer, dimension(2, spectral_disc%get_nband()) :: band_lims
          58             :     ! ------
          59     1135399 :     ncol = size(gpt_flux_up, DIM=1)
          60     1135399 :     nlev = size(gpt_flux_up, DIM=2)
          61     1135399 :     ngpt = spectral_disc%get_ngpt()
          62     1135399 :     nbnd = spectral_disc%get_nband()
          63    53298973 :     band_lims(:,:) = spectral_disc%get_band_lims_gpoint()
          64             :
          65             :     ! Compute broadband fluxes
          66             :     !   This also checks that input arrays are consistently sized
          67             :     !
          68     1881535 :     error_msg = this%ty_fluxes_broadband%reduce(gpt_flux_up, gpt_flux_dn, spectral_disc, top_at_1, gpt_flux_dn_dir)
          69     1135399 :     if(error_msg /= '') return
          70             :
          71     1135399 :     if(size(gpt_flux_up, 3) /= ngpt) then
          72           0 :       error_msg = "reduce: spectral discretization and g-point flux arrays have differing number of g-points"
          73           0 :       return
          74             :     end if
          75             :
          76             :     ! Check sizes of output arrays
          77     1135399 :     if(check_extents) then
          78     1135399 :       if(associated(this%bnd_flux_up)) then
          79      389263 :         if(.not. extents_are(this%bnd_flux_up, ncol, nlev, nbnd)) &
          80           0 :           error_msg = "reduce: bnd_flux_up array incorrectly sized (can't compute net flux either)"
          81             :       end if
          82     1135399 :       if(associated(this%bnd_flux_dn)) then
          83      389263 :         if(.not. extents_are(this%bnd_flux_dn, ncol, nlev, nbnd)) &
          84           0 :           error_msg = "reduce: bnd_flux_dn array incorrectly sized (can't compute net flux either)"
          85             :       end if
          86     1135399 :       if(associated(this%bnd_flux_dn_dir)) then
          87      389263 :         if(.not. extents_are(this%bnd_flux_dn_dir, ncol, nlev, nbnd)) &
          88           0 :           error_msg = "reduce: bnd_flux_dn_dir array incorrectly sized"
          89             :       end if
          90     1135399 :       if(associated(this%bnd_flux_net)) then
          91      389263 :         if(.not. extents_are(this%bnd_flux_net, ncol, nlev, nbnd)) &
          92           0 :           error_msg = "reduce: bnd_flux_net array incorrectly sized (can't compute net flux either)"
          93             :       end if
          94     1135399 :       if(error_msg /= "") return
          95             :     end if
          96             :     !
          97             :     ! Self-consistency -- shouldn't be asking for direct beam flux if it isn't supplied
          98     1135399 :     if(associated(this%bnd_flux_dn_dir) .and. .not. present(gpt_flux_dn_dir)) then
          99           0 :       error_msg = "reduce: requesting bnd_flux_dn_dir but direct flux hasn't been supplied"
         100           0 :       return
         101             :     end if
         102             :
         103             :     ! -------
         104             :     !$acc enter data copyin(band_lims)
         105             :     !$omp target enter data map(to:band_lims)
         106             :     ! Band-by-band fluxes
         107             :     ! Up flux
         108     1135399 :     if(associated(this%bnd_flux_up)) then
         109      389263 :       call sum_byband(ncol, nlev, ngpt, nbnd, band_lims, gpt_flux_up,     this%bnd_flux_up    )
         110             :     end if
         111             :
         112             :     ! -------
         113             :     ! Down flux
         114     1135399 :     if(associated(this%bnd_flux_dn)) then
         115      389263 :       call sum_byband(ncol, nlev, ngpt, nbnd, band_lims, gpt_flux_dn,     this%bnd_flux_dn    )
         116             :     end if
         117             :
         118     1135399 :     if(associated(this%bnd_flux_dn_dir)) then
         119      389263 :       call sum_byband(ncol, nlev, ngpt, nbnd, band_lims, gpt_flux_dn_dir, this%bnd_flux_dn_dir)
         120             :     end if
         121             :
         122             :     ! -------
         123             :     ! Net flux
         124             :     !
         125     1135399 :     if(associated(this%bnd_flux_net)) then
         126             :       !
         127             :       !  Reuse down and up results if possible
         128             :       !
         129      389263 :       if(associated(this%bnd_flux_dn) .and. associated(this%bnd_flux_up)) then
         130      389263 :         call net_byband(ncol, nlev,       nbnd,                             this%bnd_flux_dn, this%bnd_flux_up, this%bnd_flux_net)
         131             :       else
         132           0 :         call net_byband(ncol, nlev, ngpt, nbnd, band_lims, gpt_flux_dn, gpt_flux_up, this%bnd_flux_net)
         133             :       end if
         134             :     end if
         135             :     !$acc exit data delete(band_lims)
         136             :     !$omp target exit data map(release:band_lims)
         137             :   end function reduce_byband
         138             :   ! --------------------------------------------------------------------------------------
         139             :   ! Are any fluxes desired from this set of g-point fluxes? We can tell because memory will
         140             :   !   be allocated for output
         141             :   !
         142     1135399 :   function are_desired_byband(this)
         143             :     class(ty_fluxes_byband), intent(in   ) :: this
         144             :     logical                                :: are_desired_byband
         145             :
         146             :     are_desired_byband = any([associated(this%bnd_flux_up),     &
         147             :                               associated(this%bnd_flux_dn),     &
         148             :                               associated(this%bnd_flux_dn_dir), &
         149             :                               associated(this%bnd_flux_net),    &
         150     4119943 :                               this%ty_fluxes_broadband%are_desired()])
         151     1135399 :   end function are_desired_byband
         152             :
         153             :   ! ----------------------------------------------------------------------------
         154             :   ! Kernels (private to this module)
         155             :   ! ----------------------------------------------------------------------------
         156             :   !
         157             :   ! Spectral reduction over all points
         158             :   !
         159     1167789 :   subroutine sum_byband(ncol, nlev, ngpt, nbnd, band_lims, spectral_flux, byband_flux) bind (C)
         160             :     integer,                               intent(in ) :: ncol, nlev, ngpt, nbnd
         161             :     integer,  dimension(2,          nbnd), intent(in ) :: band_lims
         162             :     real(wp), dimension(ncol, nlev, ngpt), intent(in ) :: spectral_flux
         163             :     real(wp), dimension(ncol, nlev, nbnd), intent(out) :: byband_flux
         164             :
         165             :     integer :: icol, ilev, igpt, ibnd
         166             :     !$acc parallel loop collapse(3) copyin(spectral_flux, band_lims) copyout(byband_flux)
         167             :     !$omp target teams distribute parallel do collapse(3) map(to:spectral_flux, band_lims) map(from:byband_flux)
         168    17516835 :     do ibnd = 1, nbnd
         169  1570676205 :       do ilev = 1, nlev
         170 24936145416 :         do icol = 1, ncol
         171 23366637000 :           byband_flux(icol, ilev, ibnd) =  spectral_flux(icol, ilev, band_lims(1, ibnd))
         172 >18848*10^7 :           do igpt = band_lims(1,ibnd)+1, band_lims(2,ibnd)
         173             :             byband_flux(icol, ilev, ibnd) = byband_flux(icol, ilev, ibnd) + &
         174 >18693*10^7 :                                             spectral_flux(icol, ilev, igpt)
         175             :           end do
         176             :         end do
         177             :       end do
         178             :     enddo
         179     1167789 :   end subroutine sum_byband
         180             :   ! ----------------------------------------------------------------------------
         181             :   !
         182             :   ! Net flux: Spectral reduction over all points
         183             :   !
         184           0 :   subroutine net_byband_full(ncol, nlev, ngpt, nbnd, band_lims, spectral_flux_dn, spectral_flux_up, byband_flux_net) bind (C)
         185             :     integer,                               intent(in ) :: ncol, nlev, ngpt, nbnd
         186             :     integer,  dimension(2,          nbnd), intent(in ) :: band_lims
         187             :     real(wp), dimension(ncol, nlev, ngpt), intent(in ) :: spectral_flux_dn, spectral_flux_up
         188             :     real(wp), dimension(ncol, nlev, nbnd), intent(out) :: byband_flux_net
         189             :
         190             :     integer :: icol, ilev, igpt, ibnd
         191             :
         192             :     !$acc parallel loop collapse(3) copyin(spectral_flux_dn, spectral_flux_up, band_lims) copyout(byband_flux_net)
         193             :     !$omp target teams distribute parallel do collapse(3) map(to:spectral_flux_dn, spectral_flux_up, band_lims) map(from:byband_flux_net)
         194           0 :     do ibnd = 1, nbnd
         195           0 :       do ilev = 1, nlev
         196           0 :         do icol = 1, ncol
         197           0 :           igpt = band_lims(1,ibnd)
         198           0 :           byband_flux_net(icol, ilev, ibnd) = spectral_flux_dn(icol, ilev, igpt) - &
         199           0 :                                               spectral_flux_up(icol, ilev, igpt)
         200           0 :           do igpt = band_lims(1,ibnd)+1, band_lims(2,ibnd)
         201             :             byband_flux_net(icol, ilev, ibnd) = byband_flux_net(icol, ilev, ibnd) + &
         202           0 :                                                 spectral_flux_dn(icol, ilev, igpt) - &
         203           0 :                                                 spectral_flux_up(icol, ilev, igpt)
         204             :           end do
         205             :         end do
         206             :       end do
         207             :     end do
         208           0 :   end subroutine net_byband_full
         209             :   ! ----------------------------------------------------------------------------
         210      389263 :   subroutine net_byband_precalc(ncol, nlev, nbnd, byband_flux_dn, byband_flux_up, byband_flux_net) bind (C)
         211             :     integer,                               intent(in ) :: ncol, nlev, nbnd
         212             :     real(wp), dimension(ncol, nlev, nbnd), intent(in ) :: byband_flux_dn, byband_flux_up
         213             :     real(wp), dimension(ncol, nlev, nbnd), intent(out) :: byband_flux_net
         214             :
         215  8312437735 :     byband_flux_net(1:ncol,1:nlev,1:nbnd) = byband_flux_dn(1:ncol,1:nlev,1:nbnd) - byband_flux_up(1:ncol,1:nlev,1:nbnd)
         216      389263 :   end subroutine net_byband_precalc
         217             :   ! ----------------------------------------------------------------------------
         218             :
         219           0 : end module mo_fluxes_byband

Generated by: LCOV version 1.14