LCOV - code coverage report
Current view: top level - MPR - mo_upscaling_operators.f90 (source / functions) Hit Total Coverage
Test: mHM coverage Lines: 58 97 59.8 %
Date: 2024-04-30 08:53:32 Functions: 3 5 60.0 %

          Line data    Source code
       1             : !> \file mo_upscaling_operators.f90
       2             : !> \brief \copybrief mo_upscaling_operators
       3             : !> \details \copydetails mo_upscaling_operators
       4             : 
       5             : !> \brief Module containing upscaling operators.
       6             : !> \details This module provides the routines for upscaling_operators.
       7             : !> \authors Giovanni Dalmasso, Rohini Kumar
       8             : !> \date Dec 2012
       9             : !> \copyright Copyright 2005-\today, the mHM Developers, Luis Samaniego, Sabine Attinger: All rights reserved.
      10             : !! mHM is released under the LGPLv3+ license \license_note
      11             : !> \ingroup f_mpr
      12             : module mo_upscaling_operators
      13             : 
      14             :   ! This module contains the functions for upscaling grid L0_fineScale_2D_data.
      15             : 
      16             :   ! Written  Giovanni Dalmasso, Rohini Kumar, Dec 2012
      17             : 
      18             :   use mo_kind, only : i4, dp
      19             : 
      20             :   implicit none
      21             : 
      22             :   private
      23             : 
      24             :   public :: majority_statistics       ! upscale grid L0_fineScale_2D_data based on a majority statistics
      25             :   public :: L0_fractionalCover_in_Lx  ! fractional coverage of a given class of L0 fields in Lx field (Lx = L1 or L11)
      26             :   public :: upscale_arithmetic_mean   ! upscale grid L0_fineScale_2D_data based on a ARITHMETIC MEAN
      27             :   public :: upscale_harmonic_mean     ! upscale grid L0_fineScale_2D_data based on a HARMONIC MEAN
      28             :   public :: upscale_geometric_mean    ! upscale grid L0_fineScale_2D_data based on a GEOMETRIC MEAN
      29             : 
      30             : contains
      31             : 
      32             :   ! ----------------------------------------------------------------------------
      33             : 
      34             :   !    NAME
      35             :   !        majority_statistics
      36             : 
      37             :   !    PURPOSE
      38             :   !>       \brief majority statistics
      39             : 
      40             :   !>       \details upscale grid L0_fineScale_2D_data based on a majority statistics
      41             : 
      42             :   !    INTENT(IN)
      43             :   !>       \param[in] "integer(i4) :: nClass"                                number of classes
      44             :   !>       \param[in] "integer(i4), dimension(:) :: L1_upper_rowId_cell"     upper row boundary (level-0) of a level-1
      45             :   !>       cell
      46             :   !>       \param[in] "integer(i4), dimension(:) :: L1_lower_rowId_cell"     lower row boundary (level-0) of a level-1
      47             :   !>       cell
      48             :   !>       \param[in] "integer(i4), dimension(:) :: L1_left_colonId_cell"    left colon boundary (level-0) of a level-1
      49             :   !>       cell
      50             :   !>       \param[in] "integer(i4), dimension(:) :: L1_right_colonId_cell"   right colon boundary (level-0) of a level-1
      51             :   !>       cell
      52             :   !>       \param[in] "integer(i4), dimension(:, :) :: L0_fineScale_2D_data" high resolution data
      53             : 
      54             :   !    RETURN
      55             :   !>       \return integer(i4) :: majority_statistics(:) — Upscaled variable based on majority.
      56             : 
      57             :   !    HISTORY
      58             :   !>       \authors Giovanni Dalmasso, Rohini Kumar
      59             : 
      60             :   !>       \date Dec 2012
      61             : 
      62             :   ! Modifications:
      63             :   ! Robert Schweppe Jun 2018 - refactoring and reformatting
      64             : 
      65           0 :   function majority_statistics(nClass, L1_upper_rowId_cell, L1_lower_rowId_cell, L1_left_colonId_cell, &
      66           0 :                               L1_right_colonId_cell, L0_fineScale_2D_data)
      67             :     implicit none
      68             : 
      69             :     ! number of classes
      70             :     integer(i4), intent(in) :: nClass
      71             : 
      72             :     ! upper row boundary (level-0) of a level-1 cell
      73             :     integer(i4), dimension(:), intent(in) :: L1_upper_rowId_cell
      74             : 
      75             :     ! lower row boundary (level-0) of a level-1 cell
      76             :     integer(i4), dimension(:), intent(in) :: L1_lower_rowId_cell
      77             : 
      78             :     ! left colon boundary (level-0) of a level-1 cell
      79             :     integer(i4), dimension(:), intent(in) :: L1_left_colonId_cell
      80             : 
      81             :     ! right colon boundary (level-0) of a level-1 cell
      82             :     integer(i4), dimension(:), intent(in) :: L1_right_colonId_cell
      83             : 
      84             :     ! high resolution data
      85             :     integer(i4), dimension(:, :), intent(in) :: L0_fineScale_2D_data
      86             : 
      87             :     integer(i4), dimension(size(L1_upper_rowId_cell, 1)) :: majority_statistics
      88             : 
      89             :     integer(i4) :: L1_nCells
      90             : 
      91             :     integer(i4) :: iu, id, jl, jr
      92             : 
      93             :     integer(i4) :: nC
      94             : 
      95             :     integer(i4) :: max_val
      96             : 
      97             :     integer(i4) :: kk, ll
      98             : 
      99             : 
     100           0 :     L1_nCells = size(majority_statistics, 1)
     101             : 
     102           0 :     do kk = 1, L1_nCells
     103           0 :       iu = L1_upper_rowId_cell(kk)
     104           0 :       id = L1_lower_rowId_cell(kk)
     105           0 :       jl = L1_left_colonId_cell(kk)
     106           0 :       jr = L1_right_colonId_cell(kk)
     107             : 
     108           0 :       max_val = -9999
     109           0 :       do ll = 1, nClass
     110           0 :         nC = count(L0_fineScale_2D_data(iu : id, jl : jr) == ll)
     111           0 :         if(nC > max_val) then
     112           0 :           majority_statistics(kk) = ll
     113           0 :           max_val = nC
     114             :         end if
     115             :       end do
     116             :     end do
     117             : 
     118           0 :   end function majority_statistics
     119             : 
     120             :   ! ------------------------------------------------------------------
     121             : 
     122             :   !    NAME
     123             :   !        L0_fractionalCover_in_Lx
     124             : 
     125             :   !    PURPOSE
     126             :   !>       \brief fractional coverage of a given class of L0 fields in Lx field (Lx = L1 or L11)
     127             : 
     128             :   !>       \details Fractional coverage of a given class of L0 fields in Lx field (Lx = L1 or L11).
     129             :   !>       For example, this routine can be used for calculating the karstic fraction.
     130             : 
     131             :   !    INTENT(IN)
     132             :   !>       \param[in] "integer(i4), dimension(:) :: dataIn0"           input fields at finer scale
     133             :   !>       \param[in] "integer(i4) :: classId"                         class id for which fraction has to be estimated
     134             :   !>       \param[in] "logical, dimension(:, :) :: mask0"              finer scale L0 mask
     135             :   !>       \param[in] "integer(i4), dimension(:) :: L0upBound_inLx"    row start at finer L0 scale
     136             :   !>       \param[in] "integer(i4), dimension(:) :: L0downBound_inLx"  row end   at finer L0 scale
     137             :   !>       \param[in] "integer(i4), dimension(:) :: L0leftBound_inLx"  col start at finer L0 scale
     138             :   !>       \param[in] "integer(i4), dimension(:) :: L0rightBound_inLx" col end   at finer L0 scale
     139             :   !>       \param[in] "integer(i4), dimension(:) :: nTCells0_inLx"     total number of valid L0 cells in a given Lx cell
     140             : 
     141             :   !    RETURN
     142             :   !>       \return real(dp) :: L0_fractionalCover_in_Lx(:) — packed 1D fraction coverage (Lx) of given class id
     143             : 
     144             :   !    HISTORY
     145             :   !>       \authors Rohini Kumar
     146             : 
     147             :   !>       \date Feb 2013
     148             : 
     149             :   ! Modifications:
     150             :   ! Robert Schweppe Jun 2018 - refactoring and reformatting
     151             : 
     152        2484 :   function L0_fractionalCover_in_Lx(dataIn0, classId, mask0, L0upBound_inLx, L0downBound_inLx, L0leftBound_inLx, &
     153       48132 :                                    L0rightBound_inLx, nTCells0_inLx) result(frac_cover_Lx)
     154             : 
     155           0 :     use mo_common_constants, only : nodata_i4
     156             : 
     157             :     implicit none
     158             : 
     159             :     ! input fields at finer scale
     160             :     integer(i4), dimension(:), intent(in) :: dataIn0
     161             : 
     162             :     ! class id for which fraction has to be estimated
     163             :     integer(i4), intent(in) :: classId
     164             : 
     165             :     ! finer scale L0 mask
     166             :     logical, dimension(:, :), intent(in) :: mask0
     167             : 
     168             :     ! row start at finer L0 scale
     169             :     integer(i4), dimension(:), intent(in) :: L0upBound_inLx
     170             : 
     171             :     ! row end   at finer L0 scale
     172             :     integer(i4), dimension(:), intent(in) :: L0downBound_inLx
     173             : 
     174             :     ! col start at finer L0 scale
     175             :     integer(i4), dimension(:), intent(in) :: L0leftBound_inLx
     176             : 
     177             :     ! col end   at finer L0 scale
     178             :     integer(i4), dimension(:), intent(in) :: L0rightBound_inLx
     179             : 
     180             :     ! total number of valid L0 cells in a given Lx cell
     181             :     integer(i4), dimension(:), intent(in) :: nTCells0_inLx
     182             : 
     183             :     real(dp), dimension(size(L0upBound_inLx, 1)) :: frac_cover_Lx
     184             : 
     185             :     integer(i4) :: kk, iu, id, jl, jr, nT
     186             : 
     187             :     integer(i4) :: nrows0, ncols0
     188             : 
     189        1242 :     integer(i4), dimension(:, :), allocatable :: dummy_Matrix
     190             : 
     191        1242 :     integer(i4), dimension(:, :), allocatable :: nodata_val
     192             : 
     193             :     integer(i4) :: nCells1
     194             : 
     195             : 
     196             :     ! estimate number of cells
     197        1242 :     nCells1 = size(L0upBound_inLx, 1)
     198             : 
     199             :     ! get nrows and ncols
     200        1242 :     nrows0 = size(mask0, 1)
     201        1242 :     ncols0 = size(mask0, 2)
     202             : 
     203             :     !unpack input data from 1D to 2D
     204        4968 :     allocate(dummy_Matrix(nrows0, ncols0))
     205        3726 :     allocate(nodata_val(nrows0, ncols0))
     206   154258362 :     nodata_val(:, :) = nodata_i4
     207        1242 :     dummy_Matrix(:, :) = unpack(dataIn0(:), mask0(:, :), nodata_val(:, :))
     208             : 
     209             :     ! initalize return variable
     210       46890 :     frac_cover_Lx(:) = 0.0_dp
     211             : 
     212             :     ! start calculation
     213       46890 :     do kk = 1, nCells1
     214       45648 :       iu = L0upBound_inLx(kk)
     215       45648 :       id = L0downBound_inLx(kk)
     216       45648 :       jl = L0leftBound_inLx(kk)
     217       45648 :       jr = L0rightBound_inLx(kk)
     218       45648 :       nT = nTCells0_inLx(kk)
     219             : 
     220    98244522 :       frac_cover_Lx(kk) = real(count(dummy_Matrix(iu : id, jl : jr) == classId), dp) / real(nT, dp)
     221             : 
     222             :     end do
     223             : 
     224             :     ! free space
     225        1242 :     deallocate(dummy_Matrix, nodata_val)
     226             : 
     227        1242 :   end function L0_fractionalCover_in_Lx
     228             : 
     229             :   ! ----------------------------------------------------------------------------
     230             : 
     231             :   !    NAME
     232             :   !        upscale_arithmetic_mean
     233             : 
     234             :   !    PURPOSE
     235             :   !>       \brief aritmetic mean
     236             : 
     237             :   !>       \details upscaling of level-0 grid data to level-1 using aritmetic mean
     238             : 
     239             :   !    INTENT(IN)
     240             :   !>       \param[in] "integer(i4), dimension(:) :: nL0_cells_in_L1_cell"  number of level-0 cells within a level-1 cell
     241             :   !>       \param[in] "integer(i4), dimension(:) :: L1_upper_rowId_cell"   upper row boundary (level-0) of a level-1
     242             :   !>       cell
     243             :   !>       \param[in] "integer(i4), dimension(:) :: L1_lower_rowId_cell"   lower row boundary (level-0) of a level-1
     244             :   !>       cell
     245             :   !>       \param[in] "integer(i4), dimension(:) :: L1_left_colonId_cell"  left colon boundary (level-0) of a level-1
     246             :   !>       cell
     247             :   !>       \param[in] "integer(i4), dimension(:) :: L1_right_colonId_cell" right colon boundary (level-0) of a level-1
     248             :   !>       cell
     249             :   !>       \param[in] "integer(i4), dimension(:) :: L0_cellId"             cell ID at level-0
     250             :   !>       \param[in] "logical, dimension(:, :) :: mask0"                  mask at level 0
     251             :   !>       \param[in] "real(dp) :: nodata_value"                           no data value
     252             :   !>       \param[in] "real(dp), dimension(:) :: L0_fineScale_data"        high resolution data
     253             : 
     254             :   !    RETURN
     255             :   !>       \return real(dp) :: upscale_arithmetic_mean(:) — Upscaled variable from L0 to L1 using arithmetic mean
     256             : 
     257             :   !    HISTORY
     258             :   !>       \authors Giovanni Dalmasso, Rohini Kumar
     259             : 
     260             :   !>       \date Dec 2012
     261             : 
     262             :   ! Modifications:
     263             :   ! Stephan Thober Feb 2013 - changed dimension of L0 input from 2d to 1d
     264             :   ! Robert Schweppe Jun 2018 - refactoring and reformatting
     265             : 
     266       16857 :   function upscale_arithmetic_mean(nL0_cells_in_L1_cell, L1_upper_rowId_cell, L1_lower_rowId_cell, L1_left_colonId_cell, &
     267       10410 :                                   L1_right_colonId_cell, L0_cellId, mask0, nodata_value, L0_fineScale_data)
     268             :     implicit none
     269             : 
     270             :     ! number of level-0 cells within a level-1 cell
     271             :     integer(i4), dimension(:), intent(in) :: nL0_cells_in_L1_cell
     272             : 
     273             :     ! upper row boundary (level-0) of a level-1 cell
     274             :     integer(i4), dimension(:), intent(in) :: L1_upper_rowId_cell
     275             : 
     276             :     ! lower row boundary (level-0) of a level-1 cell
     277             :     integer(i4), dimension(:), intent(in) :: L1_lower_rowId_cell
     278             : 
     279             :     ! left colon boundary (level-0) of a level-1 cell
     280             :     integer(i4), dimension(:), intent(in) :: L1_left_colonId_cell
     281             : 
     282             :     ! right colon boundary (level-0) of a level-1 cell
     283             :     integer(i4), dimension(:), intent(in) :: L1_right_colonId_cell
     284             : 
     285             :     ! cell ID at level-0
     286             :     integer(i4), dimension(:), intent(in) :: L0_cellId
     287             : 
     288             :     ! mask at level 0
     289             :     logical, dimension(:, :), intent(in) :: mask0
     290             : 
     291             :     ! no data value
     292             :     real(dp), intent(in) :: nodata_value
     293             : 
     294             :     ! high resolution data
     295             :     real(dp), dimension(:), intent(in) :: L0_fineScale_data
     296             : 
     297             :     real(dp), dimension(size(nL0_cells_in_L1_cell, 1)) :: upscale_arithmetic_mean
     298             : 
     299             :     integer(i4) :: L1_nCells
     300             : 
     301             :     integer(i4) :: iu, id, jl, jr
     302             : 
     303             :     integer(i4) :: kk
     304             : 
     305        5205 :     integer(i4), dimension(size(mask0, 1), size(mask0, 2)) :: nodata_2d
     306             : 
     307        5205 :     integer(i4), dimension(size(mask0, 1), size(mask0, 2)) :: L0_cellId_2d
     308             : 
     309   646627866 :     real(dp), dimension(size(mask0, 1), size(mask0, 2)) :: L0_fineScale_2D_data
     310             : 
     311             : 
     312             :     ! allocation and initialisation
     313      195855 :     upscale_arithmetic_mean(:) = 0.0_dp
     314   646622661 :     nodata_2d = int(nodata_value, i4)
     315        5205 :     L0_cellId_2d = unpack(L0_cellId, mask0, nodata_2d)
     316        5205 :     L0_fineScale_2D_data = unpack(L0_fineScale_data, mask0, nodata_value)
     317             : 
     318        5205 :     L1_nCells = size(upscale_arithmetic_mean, 1)
     319             : 
     320      195855 :     do kk = 1, L1_nCells
     321      190650 :       iu = L1_upper_rowId_cell(kk)
     322      190650 :       id = L1_lower_rowId_cell(kk)
     323      190650 :       jl = L1_left_colonId_cell(kk)
     324      190650 :       jr = L1_right_colonId_cell(kk)
     325      190650 :       upscale_arithmetic_mean(kk) = sum(L0_fineScale_2D_data(iu : id, jl : jr), L0_cellId_2d(iu : id, jl : jr) /= &
     326   412129449 :               int(nodata_value, i4)) / real(nL0_cells_in_L1_cell(kk), dp)
     327             :     end do
     328             : 
     329        5205 :   end function upscale_arithmetic_mean
     330             : 
     331             :   ! ----------------------------------------------------------------------------
     332             : 
     333             :   !    NAME
     334             :   !        upscale_harmonic_mean
     335             : 
     336             :   !    PURPOSE
     337             :   !>       \brief harmonic mean
     338             : 
     339             :   !>       \details upscaling of level-0 grid data to level-1 using harmonic mean
     340             : 
     341             :   !    INTENT(IN)
     342             :   !>       \param[in] "integer(i4), dimension(:) :: nL0_cells_in_L1_cell"  number of level-0 cells within a level-1 cell
     343             :   !>       \param[in] "integer(i4), dimension(:) :: L1_upper_rowId_cell"   upper row boundary (level-0) of a level-1
     344             :   !>       cell
     345             :   !>       \param[in] "integer(i4), dimension(:) :: L1_lower_rowId_cell"   lower row boundary (level-0) of a level-1
     346             :   !>       cell
     347             :   !>       \param[in] "integer(i4), dimension(:) :: L1_left_colonId_cell"  left colon boundary (level-0) of a level-1
     348             :   !>       cell
     349             :   !>       \param[in] "integer(i4), dimension(:) :: L1_right_colonId_cell" right colon boundary (level-0) of a level-1
     350             :   !>       cell
     351             :   !>       \param[in] "integer(i4), dimension(:) :: L0_cellId"             cell ID at level-0
     352             :   !>       \param[in] "logical, dimension(:, :) :: mask0"                  mask at Level 0
     353             :   !>       \param[in] "real(dp) :: nodata_value"                           no data value
     354             :   !>       \param[in] "real(dp), dimension(:) :: L0_fineScale_data"        high resolution data
     355             : 
     356             :   !    RETURN
     357             :   !>       \return real(dp) :: upscale_harmonic_mean(:) — Upscaled variable from L0 to L1 using harmonic mean
     358             : 
     359             :   !    HISTORY
     360             :   !>       \authors Giovanni Dalmasso, Rohini Kumar
     361             : 
     362             :   !>       \date Dec 2012
     363             : 
     364             :   ! Modifications:
     365             :   ! Stephan Thober Jan 2013 - change example calling sequence
     366             :   ! Stephan Thober Feb 2013 - added Level 0 mask
     367             :   ! Robert Schweppe Jun 2018 - refactoring and reformatting
     368             : 
     369       25221 :   function upscale_harmonic_mean(nL0_cells_in_L1_cell, L1_upper_rowId_cell, L1_lower_rowId_cell, L1_left_colonId_cell, &
     370       13344 :                                 L1_right_colonId_cell, L0_cellId, mask0, nodata_value, L0_fineScale_data)
     371             :     implicit none
     372             : 
     373             :     ! number of level-0 cells within a level-1 cell
     374             :     integer(i4), dimension(:), intent(in) :: nL0_cells_in_L1_cell
     375             : 
     376             :     ! upper row boundary (level-0) of a level-1 cell
     377             :     integer(i4), dimension(:), intent(in) :: L1_upper_rowId_cell
     378             : 
     379             :     ! lower row boundary (level-0) of a level-1 cell
     380             :     integer(i4), dimension(:), intent(in) :: L1_lower_rowId_cell
     381             : 
     382             :     ! left colon boundary (level-0) of a level-1 cell
     383             :     integer(i4), dimension(:), intent(in) :: L1_left_colonId_cell
     384             : 
     385             :     ! right colon boundary (level-0) of a level-1 cell
     386             :     integer(i4), dimension(:), intent(in) :: L1_right_colonId_cell
     387             : 
     388             :     ! cell ID at level-0
     389             :     integer(i4), dimension(:), intent(in) :: L0_cellId
     390             : 
     391             :     ! mask at Level 0
     392             :     logical, dimension(:, :), intent(in) :: mask0
     393             : 
     394             :     ! no data value
     395             :     real(dp), intent(in) :: nodata_value
     396             : 
     397             :     ! high resolution data
     398             :     real(dp), dimension(:), intent(in) :: L0_fineScale_data
     399             : 
     400             :     real(dp), dimension(size(nL0_cells_in_L1_cell, 1)) :: upscale_harmonic_mean
     401             : 
     402             :     integer(i4) :: L1_nCells
     403             : 
     404             :     integer(i4) :: iu, id, jl, jr
     405             : 
     406             :     integer(i4) :: kk
     407             : 
     408        6672 :     integer(i4), dimension(size(mask0, 1), size(mask0, 2)) :: nodata_2d
     409             : 
     410        6672 :     integer(i4), dimension(size(mask0, 1), size(mask0, 2)) :: L0_cellId_2d
     411             : 
     412   828710688 :     real(dp), dimension(size(mask0, 1), size(mask0, 2)) :: L0_fineScale_2D_data
     413             : 
     414             : 
     415             :     ! allocation and initialisation
     416      251760 :     upscale_harmonic_mean(:) = 0.0_dp
     417   828704016 :     nodata_2d = int(nodata_value, i4)
     418        6672 :     L0_cellId_2d = unpack(L0_cellId, mask0, nodata_2d)
     419        6672 :     L0_fineScale_2D_data = unpack(L0_fineScale_data, mask0, nodata_value)
     420             : 
     421        6672 :     L1_nCells = size(upscale_harmonic_mean, 1)
     422             : 
     423      251760 :     do kk = 1, L1_nCells
     424      245088 :       iu = L1_upper_rowId_cell(kk)
     425      245088 :       id = L1_lower_rowId_cell(kk)
     426      245088 :       jl = L1_left_colonId_cell(kk)
     427      245088 :       jr = L1_right_colonId_cell(kk)
     428      245088 :       upscale_harmonic_mean(kk) = real(nL0_cells_in_L1_cell(kk), dp) &
     429   528056016 :               / sum(1.0_dp / L0_fineScale_2D_data(iu : id, jl : jr), L0_cellId_2d(iu : id, jl : jr) /= int(nodata_value, i4))
     430             :     end do
     431             : 
     432        6672 :   end function upscale_harmonic_mean
     433             : 
     434             :   ! ----------------------------------------------------------------------------
     435             : 
     436             :   !    NAME
     437             :   !        upscale_geometric_mean
     438             : 
     439             :   !    PURPOSE
     440             :   !>       \brief geometric mean
     441             : 
     442             :   !>       \details upscaling of level-0 grid data to level-1 using geometric mean
     443             : 
     444             :   !    INTENT(IN)
     445             :   !>       \param[in] "integer(i4), dimension(:) :: L1_upper_rowId_cell"   upper row boundary (level-0) of a level-1
     446             :   !>       cell
     447             :   !>       \param[in] "integer(i4), dimension(:) :: L1_lower_rowId_cell"   lower row boundary (level-0) of a level-1
     448             :   !>       cell
     449             :   !>       \param[in] "integer(i4), dimension(:) :: L1_left_colonId_cell"  left colon boundary (level-0) of a level-1
     450             :   !>       cell
     451             :   !>       \param[in] "integer(i4), dimension(:) :: L1_right_colonId_cell" right colon boundary (level-0) of a level-1
     452             :   !>       cell
     453             :   !>       \param[in] "logical, dimension(:, :) :: mask0"                  mask at level 0
     454             :   !>       \param[in] "real(dp) :: nodata_value"                           no data value
     455             :   !>       \param[in] "real(dp), dimension(:) :: L0_fineScale_data"        high resolution data
     456             : 
     457             :   !    RETURN
     458             :   !>       \return real(dp) :: upscale_geometric_mean(:) — Upscaled variable from L0 to L1 using geometric mean
     459             : 
     460             :   !    HISTORY
     461             :   !>       \authors Giovanni Dalmasso, Rohini Kumar
     462             : 
     463             :   !>       \date Dec 2012
     464             : 
     465             :   ! Modifications:
     466             :   ! Rohini Kumar Jun 2016 - fixed bug
     467             :   ! Robert Schweppe Jun 2018 - refactoring and reformatting
     468             : 
     469           0 :   function upscale_geometric_mean(L1_upper_rowId_cell, L1_lower_rowId_cell, L1_left_colonId_cell, L1_right_colonId_cell, &
     470           0 :                                  mask0, nodata_value, L0_fineScale_data)
     471             : 
     472        6672 :     use mo_utils, only : ne
     473             : 
     474             :     implicit none
     475             : 
     476             :     ! upper row boundary (level-0) of a level-1 cell
     477             :     integer(i4), dimension(:), intent(in) :: L1_upper_rowId_cell
     478             : 
     479             :     ! lower row boundary (level-0) of a level-1 cell
     480             :     integer(i4), dimension(:), intent(in) :: L1_lower_rowId_cell
     481             : 
     482             :     ! left colon boundary (level-0) of a level-1 cell
     483             :     integer(i4), dimension(:), intent(in) :: L1_left_colonId_cell
     484             : 
     485             :     ! right colon boundary (level-0) of a level-1 cell
     486             :     integer(i4), dimension(:), intent(in) :: L1_right_colonId_cell
     487             : 
     488             :     ! mask at level 0
     489             :     logical, dimension(:, :), intent(in) :: mask0
     490             : 
     491             :     ! no data value
     492             :     real(dp), intent(in) :: nodata_value
     493             : 
     494             :     ! high resolution data
     495             :     real(dp), dimension(:), intent(in) :: L0_fineScale_data
     496             : 
     497             :     real(dp), dimension(size(L1_upper_rowId_cell, 1)) :: upscale_geometric_mean
     498             : 
     499             :     integer(i4) :: iu, id, jl, jr
     500             : 
     501             :     integer(i4) :: kk
     502             : 
     503             :     integer(i4) :: nCells_L0_in_L1
     504             : 
     505           0 :     real(dp), dimension(size(mask0, 1), size(mask0, 2)) :: L0_fineScale_2D_data
     506             : 
     507           0 :     real(dp), dimension(size(mask0, 1), size(mask0, 2)) :: nodata_2d
     508             : 
     509           0 :     real(dp), dimension(:), allocatable :: dummy_V
     510             : 
     511             : 
     512             :     ! allocation and initialisation
     513           0 :     upscale_geometric_mean(:) = nodata_value
     514           0 :     nodata_2d = nodata_value
     515           0 :     L0_fineScale_2D_data = unpack(L0_fineScale_data, mask0, nodata_2d)
     516             : 
     517           0 :     do kk = 1, size(upscale_geometric_mean, 1)
     518           0 :       iu = L1_upper_rowId_cell(kk)
     519           0 :       id = L1_lower_rowId_cell(kk)
     520           0 :       jl = L1_left_colonId_cell(kk)
     521           0 :       jr = L1_right_colonId_cell(kk)
     522           0 :       nCells_L0_in_L1 = count(NE(L0_fineScale_2D_data(iu : id, jl : jr), nodata_value))
     523           0 :       allocate(dummy_V(nCells_L0_in_L1))
     524           0 :       dummy_V(:) = PACK(L0_fineScale_2D_data(iu : id, jl : jr), MASK = (NE(L0_fineScale_2D_data(iu : id, jl : jr), nodata_value)))
     525           0 :       upscale_geometric_mean(kk) = PRODUCT(dummy_V(:))
     526           0 :       if(NE(upscale_geometric_mean(kk), 0.0_dp)) then
     527           0 :         upscale_geometric_mean(kk) = upscale_geometric_mean(kk)**(1.0_dp / real(nCells_L0_in_L1, dp))
     528             :       else
     529           0 :         upscale_geometric_mean(kk) = 0.0_dp
     530             :       end if
     531           0 :       deallocate(dummy_V)
     532             :       !!
     533             :     end do
     534             : 
     535           0 :   end function upscale_geometric_mean
     536             : 
     537             : 
     538             :   ! ----------------------------------------------------------------------------
     539             : 
     540             :   !    NAME
     541             :   !        upscale_p_norm
     542             : 
     543             :   !    PURPOSE
     544             :   !>       \brief aritmetic mean
     545             : 
     546             :   !>       \details upscaling of level-0 grid data to level-1 using aritmetic mean
     547             : 
     548             :   !    INTENT(IN)
     549             :   !>       \param[in] "integer(i4), dimension(:) :: nL0_cells_in_L1_cell"  number of level-0 cells within a level-1 cell
     550             :   !>       \param[in] "integer(i4), dimension(:) :: L1_upper_rowId_cell"   upper row boundary (level-0) of a level-1
     551             :   !>       cell
     552             :   !>       \param[in] "integer(i4), dimension(:) :: L1_lower_rowId_cell"   lower row boundary (level-0) of a level-1
     553             :   !>       cell
     554             :   !>       \param[in] "integer(i4), dimension(:) :: L1_left_colonId_cell"  left colon boundary (level-0) of a level-1
     555             :   !>       cell
     556             :   !>       \param[in] "integer(i4), dimension(:) :: L1_right_colonId_cell" right colon boundary (level-0) of a level-1
     557             :   !>       cell
     558             :   !>       \param[in] "integer(i4), dimension(:) :: L0_cellId"             cell ID at level-0
     559             :   !>       \param[in] "logical, dimension(:, :) :: mask0"                  mask at level 0
     560             :   !>       \param[in] "real(dp) :: nodata_value"                           no data value
     561             :   !>       \param[in] "real(dp) :: p_norm"                                 p_norm value
     562             :   !>       \param[in] "real(dp), dimension(:) :: L0_fineScale_data"        high resolution data
     563             : 
     564             :   !    RETURN
     565             :   !>       \return real(dp) :: upscale_arithmetic_mean(:) — Upscaled variable from L0 to L1 using arithmetic mean
     566             : 
     567             :   !    HISTORY
     568             :   !>       \authors Giovanni Dalmasso, Rohini Kumar
     569             : 
     570             :   !>       \date Dec 2012
     571             : 
     572             :   ! Modifications:
     573             :   ! Stephan Thober Feb 2013 - changed dimension of L0 input from 2d to 1d
     574             :   ! Robert Schweppe Jun 2018 - refactoring and reformatting
     575             : 
     576             :   function upscale_p_norm(nL0_cells_in_L1_cell, L1_upper_rowId_cell, L1_lower_rowId_cell, L1_left_colonId_cell, &
     577             :                          L1_right_colonId_cell, L0_cellId, mask0, nodata_value, p_norm, L0_fineScale_data)
     578             : 
     579           0 :     use mo_utils, only : ne
     580             : 
     581             :     implicit none
     582             : 
     583             :     ! number of level-0 cells within a level-1 cell
     584             :     integer(i4), dimension(:), intent(in) :: nL0_cells_in_L1_cell
     585             : 
     586             :     ! upper row boundary (level-0) of a level-1 cell
     587             :     integer(i4), dimension(:), intent(in) :: L1_upper_rowId_cell
     588             : 
     589             :     ! lower row boundary (level-0) of a level-1 cell
     590             :     integer(i4), dimension(:), intent(in) :: L1_lower_rowId_cell
     591             : 
     592             :     ! left colon boundary (level-0) of a level-1 cell
     593             :     integer(i4), dimension(:), intent(in) :: L1_left_colonId_cell
     594             : 
     595             :     ! right colon boundary (level-0) of a level-1 cell
     596             :     integer(i4), dimension(:), intent(in) :: L1_right_colonId_cell
     597             : 
     598             :     ! cell ID at level-0
     599             :     integer(i4), dimension(:), intent(in) :: L0_cellId
     600             : 
     601             :     ! mask at level 0
     602             :     logical, dimension(:, :), intent(in) :: mask0
     603             : 
     604             :     ! no data value
     605             :     real(dp), intent(in) :: nodata_value
     606             : 
     607             :     ! p_norm value
     608             :     real(dp), intent(in) :: p_norm
     609             : 
     610             :     ! high resolution data
     611             :     real(dp), dimension(:), intent(in) :: L0_fineScale_data
     612             : 
     613             :     real(dp), dimension(size(nL0_cells_in_L1_cell, 1)) :: upscale_p_norm
     614             : 
     615             :     integer(i4) :: L1_nCells
     616             : 
     617             :     integer(i4) :: iu, id, jl, jr
     618             : 
     619             :     integer(i4) :: kk
     620             : 
     621             :     integer(i4), dimension(size(mask0, 1), size(mask0, 2)) :: nodata_2d
     622             : 
     623             :     integer(i4), dimension(size(mask0, 1), size(mask0, 2)) :: L0_cellId_2d
     624             : 
     625             :     real(dp), dimension(size(mask0, 1), size(mask0, 2)) :: L0_fineScale_2D_data
     626             : 
     627             : 
     628             :     ! allocation and initialisation
     629             :     upscale_p_norm(:) = 0.0_dp
     630             :     nodata_2d = int(nodata_value, i4)
     631             :     L0_cellId_2d = unpack(L0_cellId, mask0, nodata_2d)
     632             :     L0_fineScale_2D_data = unpack(L0_fineScale_data, mask0, nodata_value)
     633             : 
     634             :     L1_nCells = size(upscale_p_norm, 1)
     635             : 
     636             :     if (ne(p_norm, 0.0_dp)) then
     637             :       ! geometric mean special case
     638             :       do kk = 1, L1_nCells
     639             :         iu = L1_upper_rowId_cell(kk)
     640             :         id = L1_lower_rowId_cell(kk)
     641             :         jl = L1_left_colonId_cell(kk)
     642             :         jr = L1_right_colonId_cell(kk)
     643             :         upscale_p_norm(kk) = product(L0_fineScale_2D_data(iu : id, jl : jr) ** p_norm, L0_cellId_2d(iu : id, jl : jr) /= &
     644             :                 int(nodata_value, i4))  ** (1.0_dp / real(nL0_cells_in_L1_cell(kk), dp))
     645             :       end do
     646             :     else
     647             :       ! all other cases
     648             :       do kk = 1, L1_nCells
     649             :         iu = L1_upper_rowId_cell(kk)
     650             :         id = L1_lower_rowId_cell(kk)
     651             :         jl = L1_left_colonId_cell(kk)
     652             :         jr = L1_right_colonId_cell(kk)
     653             :         upscale_p_norm(kk) = sum(L0_fineScale_2D_data(iu : id, jl : jr) ** p_norm, L0_cellId_2d(iu : id, jl : jr) /= &
     654             :                 int(nodata_value, i4)) / real(nL0_cells_in_L1_cell(kk), dp) ** (1.0_dp / p_norm)
     655             :       end do
     656             :     end if
     657             : 
     658             :   end function upscale_p_norm
     659             : 
     660             : 
     661             : end module mo_upscaling_operators

Generated by: LCOV version 1.16