LCOV - code coverage report
Current view: | top level - physics/rrtmgp/ext/rte-frontend - mo_source_functions.F90 (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 39 | 100 | 39.0 %
Date: | 2024-12-17 17:57:11 |  | Functions: | 6 | 17 | 35.3 %

              Line data    Source code
           1             : ! This code is part of Radiative Transfer for Energetics (RTE)
           2             : !
           3             : ! Contacts: Robert Pincus and Eli Mlawer
           4             : ! email:  rrtmgp@aer.com
           5             : !
           6             : ! Copyright 2015-  Atmospheric and Environmental Research,
           7             : !    Regents of the University of Colorado,
           8             : !    Trustees of Columbia University in the City of New York
           9             : ! 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             : !> Encapsulate source function arrays for longwave/lw/internal sources
          16             : !    and shortwave/sw/external source.
          17             : !
          18             : ! -------------------------------------------------------------------------------------------------
          19             : module mo_source_functions
          20             :   use mo_rte_kind,      only: wp
          21             :   use mo_optical_props, only: ty_optical_props
          22             :   implicit none
          23             :   private
          24             :   ! -------------------------------------------------------------------------------------------------
          25             :   !
          26             :   !> Type representing Planck source functions in \(W/m^2\)
          27             :   !>   computed at layer center, at layer edges using
          28             :   !>   spectral mapping in each direction separately, and at the surface
          29             :   !>
          30             :   type, extends(ty_optical_props), public :: ty_source_func_lw
          31             :     real(wp), allocatable, dimension(:,:,:) :: lay_source
          32             :         !! Planck source at layer average temperature (ncol, nlay, ngpt)
          33             :     real(wp), allocatable, dimension(:,:,:) :: lev_source_inc
          34             :         !! Planck source at layer edge in increasing ilay direction (ncol, nlay+1, ngpt)
          35             :     real(wp), allocatable, dimension(:,:,:) :: lev_source_dec
          36             :         !! Planck source at layer edge in decreasing ilay direction (ncol, nlay+1, ngpt)
          37             :     real(wp), allocatable, dimension(:,:  ) :: sfc_source
          38             :         !! Planck function at surface temperature
          39             :     real(wp), allocatable, dimension(:,:  ) :: sfc_source_Jac
          40             :         !! surface source Jacobian
          41             :   contains
          42             :     generic,   public :: alloc => alloc_lw, copy_and_alloc_lw
          43             :     procedure, private:: alloc_lw
          44             :     procedure, private:: copy_and_alloc_lw
          45             :     procedure, public :: is_allocated => is_allocated_lw
          46             :     procedure, public :: finalize     => finalize_lw
          47             :     procedure, public :: get_subset   => get_subset_range_lw
          48             :     procedure, public :: get_ncol     => get_ncol_lw
          49             :     procedure, public :: get_nlay     => get_nlay_lw
          50             :     ! validate?
          51             :   end type ty_source_func_lw
          52             :   ! -------------------------------------------------------------------------------------------------
          53             :   !
          54             :   ! Type for shortave sources: top-of-domain spectrally-resolved flux
          55             :   !   The type isn't used at this time, so it's declared as private.
          56             :   !
          57             :   type, extends(ty_optical_props), private :: ty_source_func_sw
          58             :     real(wp), allocatable, dimension(:,:  ) :: toa_source
          59             :   contains
          60             :     generic,   public :: alloc => alloc_sw, copy_and_alloc_sw
          61             :     procedure, private:: alloc_sw
          62             :     procedure, private:: copy_and_alloc_sw
          63             :     procedure, public :: is_allocated => is_allocated_sw
          64             :     procedure, public :: finalize => finalize_sw
          65             :     procedure, public :: get_subset => get_subset_range_sw
          66             :     procedure, public :: get_ncol => get_ncol_sw
          67             :     ! validate?
          68             :   end type ty_source_func_sw
          69             :   ! -------------------------------------------------------------------------------------------------
          70             : contains
          71             :   ! ------------------------------------------------------------------------------------------
          72             :   !
          73             :   !  Routines for initialization, validity checking, finalization
          74             :   !
          75             :   ! ------------------------------------------------------------------------------------------
          76             :   !
          77             :   ! Longwave
          78             :   !
          79             :   ! ------------------------------------------------------------------------------------------
          80     4476816 :   pure function is_allocated_lw(this)
          81             :     class(ty_source_func_lw), intent(in) :: this
          82             :     logical                              :: is_allocated_lw
          83             :
          84             :     is_allocated_lw = this%is_initialized() .and. &
          85     4476816 :                       allocated(this%sfc_source)
          86     4476816 :   end function is_allocated_lw
          87             :   ! --------------------------------------------------------------
          88      746136 :   function alloc_lw(this, ncol, nlay) result(err_message)
          89             :     class(ty_source_func_lw),    intent(inout) :: this
          90             :     integer,                     intent(in   ) :: ncol, nlay
          91             :     character(len = 128)                       :: err_message
          92             :
          93             :     integer :: ngpt
          94             :
          95      746136 :     err_message = ""
          96      746136 :     if(.not. this%is_initialized()) &
          97           0 :       err_message = "source_func_lw%alloc: not initialized so can't allocate"
          98     2238408 :     if(any([ncol, nlay] <= 0)) &
          99           0 :       err_message = "source_func_lw%alloc: must provide positive extents for ncol, nlay"
         100      746136 :     if (err_message /= "") return
         101             :
         102      746136 :     if(allocated(this%sfc_source))     deallocate(this%sfc_source)
         103      746136 :     if(allocated(this%sfc_source_Jac)) deallocate(this%sfc_source_Jac)
         104      746136 :     if(allocated(this%lay_source))     deallocate(this%lay_source)
         105      746136 :     if(allocated(this%lev_source_inc)) deallocate(this%lev_source_inc)
         106      746136 :     if(allocated(this%lev_source_dec)) deallocate(this%lev_source_dec)
         107             :
         108      746136 :     ngpt = this%get_ngpt()
         109           0 :     allocate(this%sfc_source    (ncol,     ngpt), this%lay_source    (ncol,nlay,ngpt), &
         110    10445904 :              this%lev_source_inc(ncol,nlay,ngpt), this%lev_source_dec(ncol,nlay,ngpt))
         111     2238408 :     allocate(this%sfc_source_Jac(ncol,     ngpt))
         112             :   end function alloc_lw
         113             :   ! --------------------------------------------------------------
         114      746136 :   function copy_and_alloc_lw(this, ncol, nlay, spectral_desc) result(err_message)
         115             :     class(ty_source_func_lw),    intent(inout) :: this
         116             :     integer,                     intent(in   ) :: ncol, nlay
         117             :     class(ty_optical_props ),    intent(in   ) :: spectral_desc
         118             :     character(len = 128)                       :: err_message
         119             :
         120      746136 :     err_message = ""
         121      746136 :     if(.not. spectral_desc%is_initialized()) then
         122           0 :       err_message = "source_func_lw%alloc: spectral_desc not initialized"
         123           0 :       return
         124             :     end if
         125      746136 :     call this%finalize()
         126      746136 :     err_message = this%init(spectral_desc)
         127      746136 :     if (err_message /= "") return
         128      746136 :     err_message = this%alloc(ncol,nlay)
         129             :   end function copy_and_alloc_lw
         130             :   ! ------------------------------------------------------------------------------------------
         131             :   !
         132             :   ! Shortwave
         133             :   !
         134             :   ! ------------------------------------------------------------------------------------------
         135           0 :   pure function is_allocated_sw(this)
         136             :     class(ty_source_func_sw), intent(in) :: this
         137             :     logical                              :: is_allocated_sw
         138             :
         139             :     is_allocated_sw = this%ty_optical_props%is_initialized() .and. &
         140           0 :                       allocated(this%toa_source)
         141           0 :   end function is_allocated_sw
         142             :   ! --------------------------------------------------------------
         143           0 :   function alloc_sw(this, ncol) result(err_message)
         144             :     class(ty_source_func_sw),    intent(inout) :: this
         145             :     integer,                     intent(in   ) :: ncol
         146             :     character(len = 128)                       :: err_message
         147             :
         148           0 :     err_message = ""
         149           0 :     if(.not. this%is_initialized()) &
         150           0 :       err_message = "source_func_sw%alloc: not initialized so can't allocate"
         151           0 :     if(ncol <= 0) &
         152           0 :       err_message = "source_func_sw%alloc: must provide positive extents for ncol"
         153           0 :     if (err_message /= "") return
         154             :
         155           0 :     if(allocated(this%toa_source)) deallocate(this%toa_source)
         156             :
         157           0 :     allocate(this%toa_source(ncol, this%get_ngpt()))
         158             :   end function alloc_sw
         159             :   ! --------------------------------------------------------------
         160           0 :   function copy_and_alloc_sw(this, ncol, spectral_desc) result(err_message)
         161             :     class(ty_source_func_sw),    intent(inout) :: this
         162             :     integer,                     intent(in   ) :: ncol
         163             :     class(ty_optical_props ),    intent(in   ) :: spectral_desc
         164             :     character(len = 128)                       :: err_message
         165             :
         166           0 :     err_message = ""
         167           0 :     if(.not. spectral_desc%is_initialized()) then
         168           0 :       err_message = "source_func_sw%alloc: spectral_desc not initialized"
         169           0 :       return
         170             :     end if
         171           0 :     err_message = this%init(spectral_desc)
         172           0 :     if(err_message /= "") return
         173           0 :     err_message = this%alloc(ncol)
         174             :   end function copy_and_alloc_sw
         175             :   ! ------------------------------------------------------------------------------------------
         176             :   !
         177             :   ! Finalization (memory deallocation)
         178             :   !
         179             :   ! ------------------------------------------------------------------------------------------
         180     2238408 :   subroutine finalize_lw(this)
         181             :     class(ty_source_func_lw),    intent(inout) :: this
         182             :
         183     2238408 :     if(allocated(this%lay_source    )) deallocate(this%lay_source)
         184     2238408 :     if(allocated(this%lev_source_inc)) deallocate(this%lev_source_inc)
         185     2238408 :     if(allocated(this%lev_source_dec)) deallocate(this%lev_source_dec)
         186     2238408 :     if(allocated(this%sfc_source    )) deallocate(this%sfc_source)
         187     2238408 :     if(allocated(this%sfc_source_Jac)) deallocate(this%sfc_source_Jac)
         188     2238408 :     call this%ty_optical_props%finalize()
         189     2238408 :   end subroutine finalize_lw
         190             :   ! --------------------------------------------------------------
         191           0 :   subroutine finalize_sw(this)
         192             :     class(ty_source_func_sw),    intent(inout) :: this
         193             :
         194           0 :     if(allocated(this%toa_source    )) deallocate(this%toa_source)
         195           0 :     call this%ty_optical_props%finalize()
         196           0 :   end subroutine finalize_sw
         197             :   ! ------------------------------------------------------------------------------------------
         198             :   !
         199             :   !  Routines for finding the problem size
         200             :   !
         201             :   ! ------------------------------------------------------------------------------------------
         202     2238408 :   pure function get_ncol_lw(this)
         203             :     class(ty_source_func_lw), intent(in) :: this
         204             :     integer :: get_ncol_lw
         205             :
         206     2238408 :     if(this%is_allocated()) then
         207     2238408 :       get_ncol_lw = size(this%lay_source,1)
         208             :     else
         209             :       get_ncol_lw = 0
         210             :     end if
         211     2238408 :   end function get_ncol_lw
         212             :   ! --------------------------------------------------------------
         213     2238408 :   pure function get_nlay_lw(this)
         214             :     class(ty_source_func_lw), intent(in) :: this
         215             :     integer :: get_nlay_lw
         216             :
         217     2238408 :     if(this%is_allocated()) then
         218     2238408 :       get_nlay_lw = size(this%lay_source,2)
         219             :     else
         220             :       get_nlay_lw = 0
         221             :     end if
         222     2238408 :   end function get_nlay_lw
         223             :   ! --------------------------------------------------------------
         224           0 :   pure function get_ncol_sw(this)
         225             :     class(ty_source_func_sw), intent(in) :: this
         226             :     integer :: get_ncol_sw
         227             :
         228           0 :     if(this%is_allocated()) then
         229           0 :       get_ncol_sw = size(this%toa_source,1)
         230             :     else
         231             :       get_ncol_sw = 0
         232             :     end if
         233           0 :   end function get_ncol_sw
         234             :   ! ------------------------------------------------------------------------------------------
         235             :   !
         236             :   !  Routines for subsetting
         237             :   !
         238             :   ! ------------------------------------------------------------------------------------------
         239           0 :   function get_subset_range_lw(full, start, n, subset) result(err_message)
         240             :     class(ty_source_func_lw), intent(inout) :: full
         241             :     integer,                  intent(in   ) :: start, n
         242             :     class(ty_source_func_lw), intent(inout) :: subset
         243             :     character(128)                          :: err_message
         244             :
         245           0 :     err_message = ""
         246           0 :     if(.not. full%is_allocated()) then
         247           0 :       err_message = "source_func_lw%subset: Asking for a subset of unallocated data"
         248           0 :       return
         249             :     end if
         250           0 :     if(start < 1 .or. start + n-1 > full%get_ncol()) &
         251           0 :        err_message = "optical_props%subset: Asking for columns outside range"
         252           0 :     if(err_message /= "") return
         253             :
         254             :     !
         255             :     ! Could check to see if subset is correctly sized, has consistent spectral discretization
         256             :     !
         257           0 :     if(subset%is_allocated()) call subset%finalize()
         258           0 :     err_message = subset%alloc(n, full%get_nlay(), full)
         259           0 :     if(err_message /= "") return
         260           0 :     subset%sfc_source    (1:n,  :) = full%sfc_source    (start:start+n-1,  :)
         261           0 :     subset%sfc_source_Jac(1:n,  :) = full%sfc_source_Jac(start:start+n-1,  :)
         262           0 :     subset%lay_source    (1:n,:,:) = full%lay_source    (start:start+n-1,:,:)
         263           0 :     subset%lev_source_inc(1:n,:,:) = full%lev_source_inc(start:start+n-1,:,:)
         264           0 :     subset%lev_source_dec(1:n,:,:) = full%lev_source_dec(start:start+n-1,:,:)
         265             :   end function get_subset_range_lw
         266             :   ! ------------------------------------------------------------------------------------------
         267           0 :   function get_subset_range_sw(full, start, n, subset) result(err_message)
         268             :     class(ty_source_func_sw), intent(inout) :: full
         269             :     integer,                  intent(in   ) :: start, n
         270             :     class(ty_source_func_sw), intent(inout) :: subset
         271             :     character(128)                          :: err_message
         272             :
         273           0 :     err_message = ""
         274           0 :     if(.not. full%is_allocated()) then
         275           0 :       err_message = "source_func_sw%subset: Asking for a subset of unallocated data"
         276           0 :       return
         277             :     end if
         278           0 :     if(start < 1 .or. start + n-1 > full%get_ncol()) &
         279           0 :        err_message = "optical_props%subset: Asking for columns outside range"
         280           0 :     if(err_message /= "") return
         281             :
         282             :     !
         283             :     ! Could check to see if subset is correctly sized, has consistent spectral discretization
         284             :     !
         285           0 :     if(subset%is_allocated()) call subset%finalize()
         286             :     ! Seems like I should be able to call "alloc" generically but the compilers are complaining
         287           0 :     err_message = subset%copy_and_alloc_sw(n, full)
         288             :
         289           0 :     subset%toa_source(1:n,  :) = full%toa_source(start:start+n-1,  :)
         290             :   end function get_subset_range_sw
         291           0 : end module mo_source_functions

Generated by: LCOV version 1.14