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
|
