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
|
