LCOV - code coverage report
Current view: | top level - physics/rrtmgp/ext/gas-optics - mo_gas_concentrations.F90 (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 81 | 183 | 44.3 %
Date: | 2024-12-17 17:57:11 |  | Functions: | 10 | 15 | 66.7 %

              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

Generated by: LCOV version 1.14