21 #define DEBUG_REDUCT .false.
25 subroutine do_time_none_ (data_out, data_in, mask, is_masked, bounds_in, bounds_out, missing_value)
26 real(FMS_TRM_KIND_),
intent(inout) :: data_out(:,:,:,:,:)
27 real(FMS_TRM_KIND_),
intent(in) :: data_in(:,:,:,:)
28 logical,
intent(in) :: mask(:,:,:,:)
29 logical,
intent(in) :: is_masked
30 type(fmsDiagIbounds_type),
intent(in) :: bounds_in
32 type(fmsDiagIbounds_type),
intent(in) :: bounds_out
34 real(FMS_TRM_KIND_),
intent(in) :: missing_value
36 integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in
38 integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out
41 is_out = bounds_out%get_imin()
42 ie_out = bounds_out%get_imax()
43 js_out = bounds_out%get_jmin()
44 je_out = bounds_out%get_jmax()
45 ks_out = bounds_out%get_kmin()
46 ke_out = bounds_out%get_kmax()
48 is_in = bounds_in%get_imin()
49 ie_in = bounds_in%get_imax()
50 js_in = bounds_in%get_jmin()
51 je_in = bounds_in%get_jmax()
52 ks_in = bounds_in%get_kmin()
53 ke_in = bounds_in%get_kmax()
56 where (mask(is_in:ie_in, js_in:je_in, ks_in:ke_in, :))
57 data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = &
58 data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)
60 data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = missing_value
63 data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = &
64 data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)
67 end subroutine do_time_none_
70 subroutine do_time_min_ (data_out, data_in, mask, is_masked, bounds_in, bounds_out, missing_value)
71 real(FMS_TRM_KIND_),
intent(inout) :: data_out(:,:,:,:,:)
72 real(FMS_TRM_KIND_),
intent(in) :: data_in(:,:,:,:)
73 logical,
intent(in) :: mask(:,:,:,:)
74 logical,
intent(in) :: is_masked
75 type(fmsDiagIbounds_type),
intent(in) :: bounds_in
77 type(fmsDiagIbounds_type),
intent(in) :: bounds_out
79 real(FMS_TRM_KIND_),
intent(in) :: missing_value
81 integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in
83 integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out
88 is_out = bounds_out%get_imin()
89 ie_out = bounds_out%get_imax()
90 js_out = bounds_out%get_jmin()
91 je_out = bounds_out%get_jmax()
92 ks_out = bounds_out%get_kmin()
93 ke_out = bounds_out%get_kmax()
95 is_in = bounds_in%get_imin()
96 ie_in = bounds_in%get_imax()
97 js_in = bounds_in%get_jmin()
98 je_in = bounds_in%get_jmax()
99 ks_in = bounds_in%get_kmin()
100 ke_in = bounds_in%get_kmax()
105 do l = 0,
size(data_out, 4) - 1
106 do k = 0, ke_out - ks_out
107 do j = 0, je_out - js_out
108 do i = 0, ie_out - is_out
109 if (mask(is_in + i, js_in + j, ks_in + k, l + 1))
then
110 if (data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) .gt. &
111 data_in(is_in + i, js_in + j, ks_in + k, l + 1) )
then
112 data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = &
113 data_in(is_in +i, js_in + j, ks_in + k, l + 1)
116 data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = missing_value
123 do l = 0,
size(data_out, 4) - 1
124 do k = 0, ke_out - ks_out
125 do j = 0, je_out - js_out
126 do i = 0, ie_out - is_out
127 if (data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) .gt. &
128 data_in(is_in + i, js_in + j, ks_in + k, l + 1) )
then
129 data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = &
130 data_in(is_in +i, js_in + j, ks_in + k, l + 1)
138 end subroutine do_time_min_
141 subroutine do_time_max_ (data_out, data_in, mask, is_masked, bounds_in, bounds_out, missing_value)
142 real(FMS_TRM_KIND_),
intent(inout) :: data_out(:,:,:,:,:)
143 real(FMS_TRM_KIND_),
intent(in) :: data_in(:,:,:,:)
144 logical,
intent(in) :: mask(:,:,:,:)
145 logical,
intent(in) :: is_masked
146 type(fmsDiagIbounds_type),
intent(in) :: bounds_in
148 type(fmsDiagIbounds_type),
intent(in) :: bounds_out
150 real(FMS_TRM_KIND_),
intent(in) :: missing_value
152 integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in
154 integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out
157 integer :: i, j, k, l
159 is_out = bounds_out%get_imin()
160 ie_out = bounds_out%get_imax()
161 js_out = bounds_out%get_jmin()
162 je_out = bounds_out%get_jmax()
163 ks_out = bounds_out%get_kmin()
164 ke_out = bounds_out%get_kmax()
166 is_in = bounds_in%get_imin()
167 ie_in = bounds_in%get_imax()
168 js_in = bounds_in%get_jmin()
169 je_in = bounds_in%get_jmax()
170 ks_in = bounds_in%get_kmin()
171 ke_in = bounds_in%get_kmax()
176 do l = 0,
size(data_out, 4) - 1
177 do k = 0, ke_out - ks_out
178 do j = 0, je_out - js_out
179 do i = 0, ie_out - is_out
180 if (mask(is_in + i, js_in + j, ks_in + k, l + 1))
then
181 if (data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) .lt. &
182 data_in(is_in + i, js_in + j, ks_in + k, l + 1) )
then
183 data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = &
184 data_in(is_in +i, js_in + j, ks_in + k, l + 1)
187 data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = missing_value
194 do l = 0,
size(data_out, 4) - 1
195 do k = 0, ke_out - ks_out
196 do j = 0, je_out - js_out
197 do i = 0, ie_out - is_out
198 if (data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) .lt. &
199 data_in(is_in + i, js_in + j, ks_in + k, l + 1) )
then
200 data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = &
201 data_in(is_in +i, js_in + j, ks_in + k, l + 1)
208 end subroutine do_time_max_
216 subroutine do_time_sum_update_(data_out, weight_sum, data_in, mask, is_masked, mask_variant, bounds_in, bounds_out, &
217 missing_value, diurnal_section, weight, pow)
218 real(FMS_TRM_KIND_),
intent(inout) :: data_out(:,:,:,:,:)
219 real(r8_kind),
intent(inout) :: weight_sum(:,:,:,:)
220 real(FMS_TRM_KIND_),
intent(in) :: data_in(:,:,:,:)
221 logical,
intent(in) :: mask(:,:,:,:)
222 logical,
intent(in) :: is_masked
223 logical,
intent(in) :: mask_variant
224 type(fmsDiagIbounds_type),
intent(in) :: bounds_in
226 type(fmsDiagIbounds_type),
intent(in) :: bounds_out
228 real(FMS_TRM_KIND_),
intent(in) :: missing_value
229 integer,
intent(in) :: diurnal_section
232 real(r8_kind),
optional,
intent(in) :: weight
234 integer ,
optional,
intent(in) :: pow
237 real(FMS_TRM_KIND_) :: weight_scale
238 integer,
parameter :: kindl = fms_trm_kind_
242 if(
present(weight))
then
243 weight_scale = real(weight, kind=kindl)
245 weight_scale = 1.0_kindl
248 if(diurnal_section .lt. 0)
then
251 diurnal = diurnal_section
255 if (mask_variant)
then
257 call sum_mask_variant(data_out, data_in, weight_sum, bounds_in, bounds_out, mask, diurnal, weight_scale, pow)
259 call sum_mask(data_out, data_in, weight_sum, bounds_in, bounds_out, mask, diurnal, &
260 missing_value, weight_scale, pow)
263 call sum_no_mask(data_out, data_in, weight_sum, bounds_in, bounds_out, diurnal, weight_scale, pow)
265 end subroutine do_time_sum_update_
267 subroutine sum_mask_(data_out, data_in, weight_sum, bounds_in, bounds_out, mask, diurnal, missing_value, &
269 real(FMS_TRM_KIND_),
intent(inout) :: data_out(:,:,:,:,:)
270 real(FMS_TRM_KIND_),
intent(in) :: data_in(:,:,:,:)
271 real(r8_kind),
intent(inout) :: weight_sum(:,:,:,:)
272 type(fmsDiagIbounds_type),
intent(in) :: bounds_in
274 type(fmsDiagIbounds_type),
intent(in) :: bounds_out
276 logical,
intent(in) :: mask(:,:,:,:)
277 integer,
intent(in) :: diurnal
279 real(FMS_TRM_KIND_),
intent(in) :: missing_value
280 real(FMS_TRM_KIND_),
intent(in) :: weight_scale
281 integer ,
optional,
intent(in) :: pow
284 integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in
286 integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out
289 integer :: i, j, k, l
291 is_out = bounds_out%get_imin()
292 ie_out = bounds_out%get_imax()
293 js_out = bounds_out%get_jmin()
294 je_out = bounds_out%get_jmax()
295 ks_out = bounds_out%get_kmin()
296 ke_out = bounds_out%get_kmax()
298 is_in = bounds_in%get_imin()
299 ie_in = bounds_in%get_imax()
300 js_in = bounds_in%get_jmin()
301 je_in = bounds_in%get_jmax()
302 ks_in = bounds_in%get_kmin()
303 ke_in = bounds_in%get_kmax()
305 weight_sum = weight_sum + weight_scale
306 if (
present(pow))
then
307 do k = 0, ke_out - ks_out
308 do j = 0, je_out - js_out
309 do i = 0, ie_out - is_out
310 where (mask(is_in + i, js_in + j, ks_in + k, :))
311 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = &
312 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) &
313 + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_scale) ** pow
315 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = missing_value
321 do k = 0, ke_out - ks_out
322 do j = 0, je_out - js_out
323 do i = 0, ie_out - is_out
324 where (mask(is_in + i, js_in + j, ks_in + k, :))
325 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = &
326 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) &
327 + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_scale)
329 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = missing_value
335 end subroutine sum_mask_
337 subroutine sum_mask_variant_(data_out, data_in, weight_sum, bounds_in, bounds_out, mask, diurnal, weight_scale, pow)
338 real(FMS_TRM_KIND_),
intent(inout) :: data_out(:,:,:,:,:)
339 real(FMS_TRM_KIND_),
intent(in) :: data_in(:,:,:,:)
340 real(r8_kind),
intent(inout) :: weight_sum(:,:,:,:)
341 type(fmsDiagIbounds_type),
intent(in) :: bounds_in
343 type(fmsDiagIbounds_type),
intent(in) :: bounds_out
345 logical,
intent(in) :: mask(:,:,:,:)
346 integer,
intent(in) :: diurnal
348 real(FMS_TRM_KIND_),
intent(in) :: weight_scale
349 integer ,
optional,
intent(in) :: pow
352 integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in
354 integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out
357 integer :: i, j, k, l
359 is_out = bounds_out%get_imin()
360 ie_out = bounds_out%get_imax()
361 js_out = bounds_out%get_jmin()
362 je_out = bounds_out%get_jmax()
363 ks_out = bounds_out%get_kmin()
364 ke_out = bounds_out%get_kmax()
366 is_in = bounds_in%get_imin()
367 ie_in = bounds_in%get_imax()
368 js_in = bounds_in%get_jmin()
369 je_in = bounds_in%get_jmax()
370 ks_in = bounds_in%get_kmin()
371 ke_in = bounds_in%get_kmax()
373 if (
present(pow))
then
374 do k = 0, ke_out - ks_out
375 do j = 0, je_out - js_out
376 do i = 0, ie_out - is_out
377 where (mask(is_in + i, js_in + j, ks_in + k, :))
378 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = &
379 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) &
380 + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_scale) ** pow
383 weight_sum(is_out + i, js_out + j, ks_out + k, :) = &
384 weight_sum(is_out + i, js_out + j, ks_out + k, :) + weight_scale
390 do k = 0, ke_out - ks_out
391 do j = 0, je_out - js_out
392 do i = 0, ie_out - is_out
393 where (mask(is_in + i, js_in + j, ks_in + k, :))
394 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = &
395 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) &
396 + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_scale)
399 weight_sum(is_out + i, js_out + j, ks_out + k, :) = &
400 weight_sum(is_out + i, js_out + j, ks_out + k, :) + weight_scale
406 end subroutine sum_mask_variant_
408 subroutine sum_no_mask_(data_out, data_in, weight_sum, bounds_in, bounds_out, diurnal, weight_scale, pow)
409 real(FMS_TRM_KIND_),
intent(inout) :: data_out(:,:,:,:,:)
410 real(FMS_TRM_KIND_),
intent(in) :: data_in(:,:,:,:)
411 real(r8_kind),
intent(inout) :: weight_sum(:,:,:,:)
412 type(fmsDiagIbounds_type),
intent(in) :: bounds_in
414 type(fmsDiagIbounds_type),
intent(in) :: bounds_out
416 integer,
intent(in) :: diurnal
418 real(FMS_TRM_KIND_),
intent(in) :: weight_scale
419 integer ,
optional,
intent(in) :: pow
422 integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in
424 integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out
426 integer :: i, j, k, l
428 is_out = bounds_out%get_imin()
429 ie_out = bounds_out%get_imax()
430 js_out = bounds_out%get_jmin()
431 je_out = bounds_out%get_jmax()
432 ks_out = bounds_out%get_kmin()
433 ke_out = bounds_out%get_kmax()
435 is_in = bounds_in%get_imin()
436 ie_in = bounds_in%get_imax()
437 js_in = bounds_in%get_jmin()
438 je_in = bounds_in%get_jmax()
439 ks_in = bounds_in%get_kmin()
440 ke_in = bounds_in%get_kmax()
442 weight_sum = weight_sum + weight_scale
444 if (
present(pow))
then
445 do k = 0, ke_out - ks_out
446 do j = 0, je_out - js_out
447 do i = 0, ie_out - is_out
448 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = &
449 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) &
450 + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_scale) ** pow
455 do k = 0, ke_out - ks_out
456 do j = 0, je_out - js_out
457 do i = 0, ie_out - is_out
458 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = &
459 data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) &
460 + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_scale)
465 end subroutine sum_no_mask_
470 subroutine sum_update_done_(out_buffer_data, weight_sum, reduction_method, missing_val, has_mask, mask_variant, &
472 real(FMS_TRM_KIND_),
intent(inout) :: out_buffer_data(:,:,:,:,:)
474 real(r8_kind),
intent(in) :: weight_sum(:,:,:,:)
476 integer,
intent(in) :: reduction_method
478 real(FMS_TRM_KIND_),
intent(in) :: missing_val
479 logical,
intent(in) :: has_mask
480 logical,
intent(in) :: mask_variant
481 integer,
optional,
intent(in) :: n_diurnal_samples
482 integer,
allocatable :: wsum(:,:,:,:)
487 integer :: i, j, k, l
489 allocate(wsum(
size(weight_sum,1),
size(weight_sum,3),
size(weight_sum,3),
size(weight_sum,4)))
493 if(reduction_method .eq. time_diurnal)
then
494 if(.not.
present(n_diurnal_samples))
call mpp_error(fatal, &
495 "SUM_UPDATE_DONE_ :: reduction method is diurnal but no sample size was given")
496 wsum = weight_sum / n_diurnal_samples
502 if (.not. mask_variant)
then
504 where(out_buffer_data(:,:,:,:,:) .ne. missing_val)
505 out_buffer_data(:,:,:,:,:) = out_buffer_data(:,:,:,:,:) &
510 do l = 1,
size(out_buffer_data, 4)
511 do k = 1,
size(out_buffer_data, 3)
512 do j = 1,
size(out_buffer_data, 2)
513 do i = 1,
size(out_buffer_data, 1)
514 if (wsum(i, j, k, l) .gt. 0)
then
515 out_buffer_data(i,j,k,l,:) = out_buffer_data(i,j,k,l,:)/ wsum(i,j,k,l)
518 out_buffer_data(i,j,k,l,:) = missing_val
527 out_buffer_data(:,:,:,:,:) = out_buffer_data(:,:,:,:,:) &
531 if(reduction_method .eq. time_rms .and. has_mask)
then
532 where(out_buffer_data(:,:,:,:,1) .ne. missing_val)
533 out_buffer_data(:,:,:,:,1) = sqrt(out_buffer_data(:,:,:,:,1))
535 else if(reduction_method .eq. time_rms)
then
536 out_buffer_data(:,:,:,:,1) = sqrt(out_buffer_data(:,:,:,:,1))