Line data Source code
1 : ! This code is part of RRTM for GCM Applications - Parallel (RRTMGP)
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, Trustees of Columbia University. All right reserved.
8 : !
9 : ! Use and duplication is permitted under the terms of the
10 : ! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause
11 : ! -------------------------------------------------------------------------------------------------
12 : !> ## Fortran class for representing gas concentrations
13 : !>
14 : !> Encapsulates a collection of volume (molar) mixing ratios (concentrations) of gases.
15 : !> Each concentration is associated with a name, normally the chemical formula.
16 : !
17 : !> Values may be provided as scalars, 1-dimensional profiles (nlay), or 2-D fields (ncol,nlay).
18 : !> `nlay` and `ncol` are determined from the input arrays; self-consistency is enforced.
19 : !> No bounds are enforced on the sum of the mixing ratios.
20 : !>
21 : !> For example:
22 : !> ```
23 : !> error_msg = gas_concs%set_vmr('h2o', values(:,:))
24 : !> error_msg = gas_concs%set_vmr('o3' , values(:) )
25 : !> error_msg = gas_concs%set_vmr('co2', value )
26 : !> ```
27 : !
28 : !> Values can be requested as profiles (valid only if there are no 2D fields present in the object)
29 : !> or as 2D fields. Values for all columns are returned although the entire collection
30 : !> can be subsetted in the column dimension
31 : !>
32 : !> Subsets can be extracted in the column dimension.
33 : !>
34 : !> Functions return strings. Non-empty strings indicate an error.
35 : !>
36 : ! -------------------------------------------------------------------------------------------------
37 :
38 : module mo_gas_concentrations
39 : use mo_rte_kind, only: wp
40 : use mo_rte_config, only: check_values
41 : use mo_rte_util_array_validation, &
42 : only: any_vals_outside
43 : implicit none
44 : integer, parameter, private :: GAS_NOT_IN_LIST = -1
45 : private
46 :
47 : type, private :: conc_field
48 : real(wp), dimension(:,:), pointer :: conc => NULL()
49 : end type conc_field
50 :
51 : type, public :: ty_gas_concs
52 : !
53 : ! Data
54 : !
55 : character(len=32), dimension(:), allocatable, public :: gas_names ! Should make this private
56 : type(conc_field), dimension(:), allocatable, private :: concs
57 : integer, private :: ncol = 0, nlay = 0
58 : contains
59 : !
60 : ! Procedures
61 : !
62 : procedure, private :: find_gas
63 : procedure, private :: set_vmr_scalar
64 : procedure, private :: set_vmr_1d
65 : procedure, private :: set_vmr_2d
66 : procedure, private :: get_vmr_1d
67 : procedure, private :: get_vmr_2d
68 : procedure, private :: get_subset_range
69 : final :: del
70 : !
71 : ! public interface
72 : !
73 : procedure, public :: init
74 : procedure, public :: reset
75 : generic, public :: set_vmr => set_vmr_scalar, &
76 : set_vmr_1d, &
77 : set_vmr_2d !! ### Set concentration values
78 : generic, public :: get_vmr => get_vmr_1d, &
79 : get_vmr_2d !! ### Get concentration values
80 : generic, public :: get_subset => get_subset_range
81 : !! ### Extract a subset of columns
82 : procedure, public :: get_num_gases
83 : procedure, public :: get_gas_names
84 : end type ty_gas_concs
85 : contains
86 : ! -------------------------------------------------------------------------------------
87 : !> ### Initialize the object
88 1136935 : function init(this, gas_names) result(error_msg)
89 : class(ty_gas_concs), intent(inout) :: this
90 : character(len=*), dimension(:), intent(in ) :: gas_names !! names of all gases which might be provided
91 : character(len=128) :: error_msg !! error string, empty when successful
92 : ! ---------
93 : integer :: i, j, ngas
94 : ! ---------
95 1136935 : error_msg = ''
96 1136935 : ngas = size(gas_names)
97 : !
98 : ! Check for no duplicate gas names, no empty names
99 : !
100 10232415 : if(any(len_trim(gas_names) == 0)) &
101 0 : error_msg = "ty_gas_concs%init(): must provide non-empty gas names"
102 :
103 9095480 : do i = 1, ngas-1
104 40929660 : do j = i+1, ngas
105 103461085 : if (lower_case(trim(gas_names(i))) == lower_case(trim(gas_names(j)))) then
106 0 : error_msg = "ty_gas_concs%init(): duplicate gas names aren't allowed"
107 63668360 : exit
108 : end if
109 : end do
110 : end do
111 1136935 : if(error_msg /= "") return
112 : !
113 : ! Allocate fixed-size arrays
114 : !
115 1136935 : call this%reset()
116 14780155 : allocate(this%gas_names(ngas), this%concs(ngas))
117 : !$acc enter data copyin(this)
118 : !$acc enter data copyin(this%concs)
119 : !$omp target enter data map(to:this%concs)
120 :
121 10232415 : this%gas_names(:) = gas_names(:)
122 : end function
123 : ! -------------------------------------------------------------------------------------
124 : !
125 : ! Set concentrations --- scalar, 1D, 2D
126 : !
127 : ! -------------------------------------------------------------------------------------
128 : !> ### Set scalar concentrations
129 0 : function set_vmr_scalar(this, gas, w) result(error_msg)
130 : ! In OpenACC context scalar w always assumed to be on the CPU
131 : class(ty_gas_concs), intent(inout) :: this
132 : character(len=*), intent(in ) :: gas !! Name of the gas being provided
133 : real(wp), intent(in ) :: w !! volume (molar) mixing ratio
134 : character(len=128) :: error_msg !! error string, empty when successful
135 : ! ---------
136 0 : real(wp), dimension(:,:), pointer :: p
137 : integer :: igas
138 : ! ---------
139 0 : error_msg = ''
140 0 : if (w < 0._wp .or. w > 1._wp) then
141 0 : error_msg = 'ty_gas_concs%set_vmr(): concentrations should be >= 0, <= 1'
142 0 : return
143 : endif
144 :
145 0 : igas = this%find_gas(gas)
146 0 : if (igas == GAS_NOT_IN_LIST) then
147 0 : error_msg = 'ty_gas_concs%set_vmr(): trying to set ' // trim(gas) // ' but name not provided at initialization'
148 0 : return
149 : end if
150 : !
151 : ! Deallocate anything existing -- could be more efficient to test if it's already the correct size
152 : !
153 : ! This cannot be made a function, because we need all the hierarchy for the correct OpenACC attach
154 0 : if (associated(this%concs(igas)%conc)) then
155 0 : if ( any(shape(this%concs(igas)%conc) /= [1, 1]) ) then
156 : !$acc exit data delete(this%concs(igas)%conc)
157 : !$omp target exit data map(release:this%concs(igas)%conc)
158 0 : deallocate(this%concs(igas)%conc)
159 0 : nullify (this%concs(igas)%conc)
160 : end if
161 : end if
162 0 : if (.not. associated(this%concs(igas)%conc)) then
163 0 : allocate(this%concs(igas)%conc(1,1))
164 : !$acc enter data create(this%concs(igas)%conc)
165 : !$omp target enter data map(alloc:this%concs(igas)%conc)
166 : end if
167 :
168 0 : p => this%concs(igas)%conc(:,:)
169 : !$acc kernels
170 : !$omp target map(to:w)
171 : #ifdef _CRAYFTN
172 : p(:,:) = w
173 : #else
174 0 : this%concs(igas)%conc(:,:) = w
175 : #endif
176 : !$acc end kernels
177 : !$omp end target
178 0 : end function set_vmr_scalar
179 : ! -------------------------------------------------------------------------------------
180 : !> ### Set 1d (function of level) concentrations
181 0 : function set_vmr_1d(this, gas, w) result(error_msg)
182 : ! In OpenACC context w assumed to be either on the CPU or on the GPU
183 : class(ty_gas_concs), intent(inout) :: this
184 : character(len=*), intent(in ) :: gas !! Name of the gas being provided
185 : real(wp), dimension(:), &
186 : intent(in ) :: w !! volume (molar) mixing ratio
187 : character(len=128) :: error_msg !! error string, empty when successful
188 : ! ---------
189 0 : real(wp), dimension(:,:), pointer :: p
190 : integer :: igas
191 : ! ---------
192 0 : error_msg = ''
193 :
194 0 : if (check_values) then
195 0 : if (any_vals_outside(w, 0._wp, 1._wp)) &
196 0 : error_msg = 'ty_gas_concs%set_vmr: concentrations should be >= 0, <= 1'
197 : end if
198 0 : if(this%nlay > 0) then
199 0 : if(size(w) /= this%nlay) error_msg = 'ty_gas_concs%set_vmr: different dimension (nlay)'
200 : else
201 0 : this%nlay = size(w)
202 : end if
203 0 : if(error_msg /= "") return
204 :
205 0 : igas = this%find_gas(gas)
206 0 : if (igas == GAS_NOT_IN_LIST) then
207 0 : error_msg = 'ty_gas_concs%set_vmr(): trying to set ' // trim(gas) // ' but name not provided at initialization'
208 0 : return
209 : end if
210 : !
211 : ! Deallocate anything existing -- could be more efficient to test if it's already the correct size
212 : !
213 : ! This cannot be made a function, because we need all the hierarchy for the correct OpenACC attach
214 0 : if (associated(this%concs(igas)%conc)) then
215 0 : if ( any(shape(this%concs(igas)%conc) /= [1, this%nlay]) ) then
216 : !$acc exit data delete(this%concs(igas)%conc)
217 : !$omp target exit data map(release:this%concs(igas)%conc)
218 0 : deallocate(this%concs(igas)%conc)
219 0 : nullify (this%concs(igas)%conc)
220 : end if
221 : end if
222 0 : if (.not. associated(this%concs(igas)%conc)) then
223 0 : allocate(this%concs(igas)%conc(1,this%nlay))
224 : !$acc enter data create(this%concs(igas)%conc)
225 : !$omp target enter data map(alloc:this%concs(igas)%conc)
226 : end if
227 :
228 0 : p => this%concs(igas)%conc(:,:)
229 : !$acc kernels copyin(w)
230 : !$omp target map(to:w)
231 : #ifdef _CRAYFTN
232 : p(1,:) = w
233 : #else
234 0 : this%concs(igas)%conc(1,:) = w
235 : #endif
236 : !$acc end kernels
237 : !$omp end target
238 :
239 : !$acc exit data delete(w)
240 0 : end function set_vmr_1d
241 : ! -------------------------------------------------------------------------------------
242 : !> ### Set 2d concentrations
243 9083192 : function set_vmr_2d(this, gas, w) result(error_msg)
244 : ! In OpenACC context w assumed to be either on the CPU or on the GPU
245 : class(ty_gas_concs), intent(inout) :: this
246 : character(len=*), intent(in ) :: gas !! Name of the gas being provided
247 : real(wp), dimension(:,:), &
248 : intent(in ) :: w !! volume (molar) mixing ratio
249 : character(len=128) :: error_msg
250 : !! error string, empty when successful
251 : ! ---------
252 9083192 : real(wp), dimension(:,:), pointer :: p
253 : integer :: igas
254 : ! ---------
255 9083192 : error_msg = ''
256 :
257 9083192 : if (check_values) then
258 9083192 : if (any_vals_outside(w, 0._wp, 1._wp)) &
259 0 : error_msg = 'ty_gas_concs%set_vmr: concentrations should be >= 0, <= 1'
260 : end if
261 :
262 9083192 : if(this%ncol > 0 .and. size(w, 1) /= this%ncol) then
263 0 : error_msg = 'ty_gas_concs%set_vmr: different dimension (ncol)'
264 : else
265 9083192 : this%ncol = size(w, 1)
266 : end if
267 :
268 9083192 : if(this%nlay > 0 .and. size(w, 2) /= this%nlay) then
269 0 : error_msg = 'ty_gas_concs%set_vmr: different dimension (nlay)'
270 : else
271 9083192 : this%nlay = size(w, 2)
272 : end if
273 9083192 : if(error_msg /= "") return
274 :
275 9083192 : igas = this%find_gas(gas)
276 9083192 : if (igas == GAS_NOT_IN_LIST) then
277 0 : error_msg = 'ty_gas_concs%set_vmr(): trying to set ' // trim(gas) // ' but name not provided at initialization'
278 0 : return
279 : end if
280 : !
281 : ! Deallocate anything existing -- could be more efficient to test if it's already the correct size
282 : !
283 : ! This cannot be made a function, because we need all the hierarchy for the correct OpenACC attach
284 9083192 : if (associated(this%concs(igas)%conc)) then
285 0 : if ( any(shape(this%concs(igas)%conc) /= [this%ncol,this%nlay]) ) then
286 : !$acc exit data delete(this%concs(igas)%conc)
287 : !$omp target exit data map(release:this%concs(igas)%conc)
288 0 : deallocate(this%concs(igas)%conc)
289 0 : nullify (this%concs(igas)%conc)
290 : end if
291 : end if
292 9083192 : if (.not. associated(this%concs(igas)%conc)) then
293 36332768 : allocate(this%concs(igas)%conc(this%ncol,this%nlay))
294 : !$acc enter data create(this%concs(igas)%conc)
295 : !$omp target enter data map(alloc:this%concs(igas)%conc)
296 : end if
297 :
298 9083192 : p => this%concs(igas)%conc(:,:)
299 : !$acc kernels copyin(w)
300 : !$omp target map(to:w)
301 : #ifdef _CRAYFTN
302 : p(:,:) = w(:,:)
303 : #else
304 14074716040 : this%concs(igas)%conc(:,:) = w(:,:)
305 : #endif
306 : !$acc end kernels
307 : !$omp end target
308 9083192 : end function set_vmr_2d
309 : ! -------------------------------------------------------------------------------------
310 : !
311 : ! Return volume mixing ratio as 1D or 2D array
312 : !
313 : ! -------------------------------------------------------------------------------------
314 : !
315 : !> ### Return volume mixing ratios as 1D array (lay depdendence only)
316 : !
317 0 : function get_vmr_1d(this, gas, array) result(error_msg)
318 : class(ty_gas_concs) :: this
319 : character(len=*), intent(in ) :: gas !! Name of the gas
320 : real(wp), dimension(:), intent(out) :: array !! Volume mixing ratio
321 : character(len=128) :: error_msg !! Error string, empty if successful
322 : ! ---------------------
323 0 : real(wp), dimension(:,:), pointer :: p
324 : integer :: igas
325 : ! ---------------------
326 0 : error_msg = ''
327 :
328 0 : igas = this%find_gas(gas)
329 0 : if (igas == GAS_NOT_IN_LIST) then
330 0 : error_msg = 'ty_gas_concs%get_vmr; gas ' // trim(gas) // ' not found'
331 0 : else if(.not. associated(this%concs(igas)%conc)) then
332 0 : error_msg = 'ty_gas_concs%get_vmr; gas ' // trim(gas) // " concentration hasn't been set"
333 0 : else if(size(this%concs(igas)%conc, 1) > 1) then ! Are we requesting a single profile when many are present?
334 0 : error_msg = 'ty_gas_concs%get_vmr; gas ' // trim(gas) // ' requesting single profile but many are available'
335 : end if
336 :
337 0 : if(this%nlay > 0 .and. this%nlay /= size(array)) then
338 0 : error_msg = 'ty_gas_concs%get_vmr; gas ' // trim(gas) // ' array is wrong size (nlay)'
339 : end if
340 0 : if(error_msg /= "") return
341 :
342 0 : p => this%concs(igas)%conc(:,:)
343 : !$acc data copyout (array) present(this)
344 : !$omp target data map(from:array)
345 0 : if(size(this%concs(igas)%conc, 2) > 1) then
346 : !$acc kernels default(none) present(p)
347 : !$omp target
348 : #ifdef _CRAYFTN
349 : array(:) = p(1,:)
350 : #else
351 0 : array(:) = this%concs(igas)%conc(1,:)
352 : #endif
353 : !$acc end kernels
354 : !$omp end target
355 : else
356 : !$acc kernels default(none) present(p)
357 : !$omp target
358 : #ifdef _CRAYFTN
359 : array(:) = p(1,1)
360 : #else
361 0 : array(:) = this%concs(igas)%conc(1,1)
362 : #endif
363 : !$acc end kernels
364 : !$omp end target
365 : end if
366 : !$acc end data
367 : !$omp end target data
368 :
369 0 : end function get_vmr_1d
370 : ! -------------------------------------------------------------------------------------
371 : !
372 : ! 2D array (col, lay)
373 : !
374 9083192 : function get_vmr_2d(this, gas, array) result(error_msg)
375 : class(ty_gas_concs) :: this
376 : character(len=*), intent(in ) :: gas !! Name of the gas
377 : real(wp), dimension(:,:), intent(out) :: array !! Volume mixing ratio
378 : character(len=128) :: error_msg !! Error string, empty if successful
379 : ! ---------------------
380 9083192 : real(wp), dimension(:,:), pointer :: p
381 : integer :: icol, ilay, igas
382 : ! ---------------------
383 9083192 : error_msg = ''
384 :
385 18166384 : igas = this%find_gas(gas)
386 9083192 : if (igas == GAS_NOT_IN_LIST) then
387 0 : error_msg = 'ty_gas_concs%get_vmr; gas ' // trim(gas) // ' not found'
388 9083192 : else if(.not. associated(this%concs(igas)%conc)) then
389 0 : error_msg = 'ty_gas_concs%get_vmr; gas ' // trim(gas) // " concentration hasn't been set"
390 : end if
391 : !
392 : ! Is the requested array the correct size?
393 : !
394 9083192 : if(this%ncol > 0 .and. this%ncol /= size(array,1)) then
395 0 : error_msg = 'ty_gas_concs%get_vmr; gas ' // trim(gas) // ' array is wrong size (ncol)'
396 : end if
397 9083192 : if(this%nlay > 0 .and. this%nlay /= size(array,2)) then
398 0 : error_msg = 'ty_gas_concs%get_vmr; gas ' // trim(gas) // ' array is wrong size (nlay)'
399 : end if
400 9083192 : if(error_msg /= "") return
401 :
402 9083192 : p => this%concs(igas)%conc(:,:)
403 : !$acc data copyout (array) present(this, this%concs)
404 : !$omp target data map(from:array)
405 9083192 : if(size(this%concs(igas)%conc, 1) > 1) then ! Concentration stored as 2D
406 : !$acc parallel loop collapse(2) default(none) present(p)
407 : !$omp target teams distribute parallel do simd
408 860867960 : do ilay = 1, size(array,2)
409 14070666904 : do icol = 1, size(array,1)
410 : #ifdef _CRAYFTN
411 : array(icol,ilay) = p(icol,ilay)
412 : #else
413 14061605136 : array(icol,ilay) = this%concs(igas)%conc(icol,ilay)
414 : #endif
415 : end do
416 : end do
417 21424 : else if(size(this%concs(igas)%conc, 2) > 1) then ! Concentration stored as 1D
418 : !$acc parallel loop collapse(2) default(none) present(p)
419 : !$omp target teams distribute parallel do simd
420 2035280 : do ilay = 1, size(array,2)
421 4049136 : do icol = 1, size(array,1)
422 : #ifdef _CRAYFTN
423 : array(icol,ilay) = p(1,ilay)
424 : #else
425 4027712 : array(icol, ilay) = this%concs(igas)%conc(1,ilay)
426 : #endif
427 : end do
428 : end do
429 : else ! Concentration stored as scalar
430 : !$acc parallel loop collapse(2) default(none) present(p)
431 : !$omp target teams distribute parallel do simd
432 0 : do ilay = 1, size(array,2)
433 0 : do icol = 1, size(array,1)
434 : #ifdef _CRAYFTN
435 : array(icol,ilay) = p(1,1)
436 : #else
437 0 : array(icol,ilay) = this%concs(igas)%conc(1,1)
438 : #endif
439 : end do
440 : end do
441 : end if
442 : !$acc end data
443 : !$omp end target data
444 :
445 9083192 : end function get_vmr_2d
446 : ! -------------------------------------------------------------------------------------
447 : !
448 : !> Extract a subset of n columns starting with column `start`
449 : !
450 : ! -------------------------------------------------------------------------------------
451 0 : function get_subset_range(this, start, n, subset) result(error_msg)
452 : class(ty_gas_concs), intent(in ) :: this
453 : integer, intent(in ) :: start, n !! Index of first column, number of columns to extract
454 : class(ty_gas_concs), intent(inout) :: subset !! Object to hold the subset of columns
455 : character(len=128) :: error_msg !! Error string, empty if successful
456 : ! ---------------------
457 0 : real(wp), dimension(:,:), pointer :: p1, p2
458 : integer :: i
459 : ! ---------------------
460 0 : error_msg = ''
461 0 : if(n <= 0) &
462 0 : error_msg = "gas_concs%get_vmr: Asking for 0 or fewer columns "
463 0 : if(start < 1 ) &
464 0 : error_msg = "gas_concs%get_vmr: Asking for columns outside range"
465 0 : if(this%ncol > 0 .and. start > this%ncol .or. start+n-1 > this%ncol ) &
466 0 : error_msg = "gas_concs%get_vmr: Asking for columns outside range"
467 0 : if(error_msg /= "") return
468 :
469 0 : call subset%reset()
470 0 : allocate(subset%gas_names(size(this%gas_names)), &
471 0 : subset%concs (size(this%concs))) ! These two arrays should be the same length
472 : !$acc enter data create(subset, subset%concs)
473 : !$omp target enter data map(alloc:subset%concs)
474 0 : subset%nlay = this%nlay
475 0 : subset%ncol = merge(n, 0, this%ncol > 0)
476 0 : subset%gas_names(:) = this%gas_names(:)
477 :
478 0 : do i = 1, size(this%gas_names)
479 : !
480 : ! Preserve scalar/1D/2D representation in subset,
481 : ! but need to ensure at least extent 1 in col dimension (ncol = 0 means no gas exploits this dimension)
482 : !
483 0 : allocate(subset%concs(i)%conc(min(max(subset%ncol,1), size(this%concs(i)%conc, 1)), &
484 0 : min( subset%nlay, size(this%concs(i)%conc, 2))))
485 0 : p1 => subset%concs(i)%conc(:,:)
486 0 : p2 => this%concs(i)%conc(:,:)
487 : !$acc enter data create(subset%concs(i)%conc)
488 : !$omp target enter data map(alloc:subset%concs(i)%conc)
489 0 : if(size(this%concs(i)%conc, 1) > 1) then ! Concentration stored as 2D
490 : !$acc kernels
491 : !$omp target
492 : #ifdef _CRAYFTN
493 : p1(:,:) = p2(start:(start+n-1),:)
494 : #else
495 0 : subset%concs(i)%conc(:,:) = this%concs(i)%conc(start:(start+n-1),:)
496 : #endif
497 : !$acc end kernels
498 : !$omp end target
499 : else
500 : !$acc kernels
501 : !$omp target
502 : #ifdef _CRAYFTN
503 : p1(:,:) = p2(:,:)
504 : #else
505 0 : subset%concs(i)%conc(:,:) = this%concs(i)%conc(:,:)
506 : #endif
507 : !$acc end kernels
508 : !$omp end target
509 : end if
510 : end do
511 :
512 0 : end function get_subset_range
513 : ! -------------------------------------------------------------------------------------
514 : !
515 : !> Free memory and reset the object to an unititialzed state
516 : !
517 : ! -------------------------------------------------------------------------------------
518 4123015 : subroutine reset(this)
519 : class(ty_gas_concs), intent(inout) :: this
520 : ! -----------------
521 : integer :: i
522 : ! -----------------
523 4123015 : this%nlay = 0
524 4123015 : this%ncol = 0
525 4123015 : if(allocated(this%gas_names)) deallocate(this%gas_names)
526 4123015 : if (allocated(this%concs)) then
527 10232415 : do i = 1, size(this%concs)
528 10232415 : if(associated(this%concs(i)%conc)) then
529 : !$acc exit data delete(this%concs(i)%conc)
530 : !$omp target exit data map(release:this%concs(i)%conc)
531 9083192 : deallocate(this%concs(i)%conc)
532 9083192 : nullify(this%concs(i)%conc)
533 : end if
534 : end do
535 : !$acc exit data delete(this%concs)
536 : !$omp target exit data map(release:this%concs)
537 1136935 : deallocate(this%concs)
538 : end if
539 4123015 : end subroutine reset
540 : ! -------------------------------------------------------------------------------------
541 : !
542 : ! Inquiry functions
543 : !
544 : ! -------------------------------------------------------------------------------------
545 : !> Inquire function - how many gases are known? (Not all concentrations need be set)
546 18166384 : pure function get_num_gases(this)
547 : class(ty_gas_concs), intent(in) :: this
548 : integer :: get_num_gases
549 :
550 18166384 : get_num_gases = size(this%gas_names)
551 : return
552 : end function get_num_gases
553 : ! -------------------------------------------------------------------------------------
554 : !> Inquire function - what are the names of the known gases? (Not all concentrations need be set)
555 9083192 : pure function get_gas_names(this)
556 : class(ty_gas_concs), intent(in) :: this
557 : character(len=32), dimension(this%get_num_gases()) :: get_gas_names !! names of the known gases
558 :
559 81748728 : get_gas_names(:) = this%gas_names(:)
560 9083192 : return
561 : end function get_gas_names
562 : ! -------------------------------------------------------------------------------------
563 : !
564 : ! Private procedures
565 : !
566 : ! -------------------------------------------------------------------------------------
567 : !> Convert string to lower case
568 354330504 : pure function lower_case( input_string ) result( output_string )
569 : character(len=*), intent(in) :: input_string
570 : character(len=len(input_string)) :: output_string
571 :
572 : ! List of character for case conversion
573 : character(len=26), parameter :: LOWER_CASE_CHARS = 'abcdefghijklmnopqrstuvwxyz'
574 : character(len=26), parameter :: UPPER_CASE_CHARS = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
575 : integer :: i, n
576 :
577 : ! Copy input string
578 354330504 : output_string = input_string
579 :
580 : ! Convert case character by character
581 1505904642 : do i = 1, len(output_string)
582 1151574138 : n = index(UPPER_CASE_CHARS, output_string(i:i))
583 1505904642 : if ( n /= 0 ) output_string(i:i) = LOWER_CASE_CHARS(n:n)
584 : end do
585 354330504 : end function
586 : ! -------------------------------------------------------------------------------------
587 : !
588 : ! find gas in list; GAS_NOT_IN_LIST if not found
589 : !
590 18166384 : function find_gas(this, gas)
591 : character(len=*), intent(in) :: gas
592 : class(ty_gas_concs), intent(in) :: this
593 : integer :: find_gas
594 : ! -----------------
595 : integer :: igas
596 : ! -----------------
597 18166384 : find_gas = GAS_NOT_IN_LIST
598 18166384 : if(.not. allocated(this%gas_names)) return
599 : ! search gases using a loop. Fortran intrinsic findloc would be faster, but only supported since gfortran 9
600 163497456 : do igas = 1, size(this%gas_names)
601 454159600 : if (lower_case(trim(this%gas_names(igas))) == lower_case(trim(gas))) then
602 308828528 : find_gas = igas
603 : end if
604 : end do
605 : end function
606 : ! -------------------------------------------------------------------------------------
607 : !> Finalization - free all memory when the object goes out of scope
608 2986080 : subroutine del(this)
609 : type(ty_gas_concs), intent(inout) :: this
610 2986080 : call this%reset()
611 : !$acc exit data delete(this)
612 2986080 : end subroutine del
613 : ! -------------------------------------------------------------------------------------
614 8958240 : end module mo_gas_concentrations
|
