libsim  Versione6.3.0
volgrid6d_class_compute.F90
1 ! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2 ! authors:
3 ! Davide Cesari <dcesari@arpa.emr.it>
4 ! Paolo Patruno <ppatruno@arpa.emr.it>
5 
6 ! This program is free software; you can redistribute it and/or
7 ! modify it under the terms of the GNU General Public License as
8 ! published by the Free Software Foundation; either version 2 of
9 ! the License, or (at your option) any later version.
10 
11 ! This program is distributed in the hope that it will be useful,
12 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ! GNU General Public License for more details.
15 
16 ! You should have received a copy of the GNU General Public License
17 ! along with this program. If not, see <http://www.gnu.org/licenses/>.
18 #include "config.h"
19 
29 USE grid_id_class
31 USE simple_stat
32 IMPLICIT NONE
33 
34 CONTAINS
35 
101 SUBROUTINE volgrid6d_compute_stat_proc(this, that, stat_proc_input, stat_proc, &
102  step, start, full_steps, frac_valid, max_step, weighted, clone)
103 TYPE(volgrid6d),INTENT(inout) :: this
104 type(volgrid6d),INTENT(out) :: that
105 INTEGER,INTENT(in) :: stat_proc_input
106 INTEGER,INTENT(in) :: stat_proc
107 type(timedelta),INTENT(in) :: step
108 type(datetime),INTENT(in),OPTIONAL :: start
109 LOGICAL,INTENT(in),OPTIONAL :: full_steps
110 REAL,INTENT(in),OPTIONAL :: frac_valid
111 type(timedelta),INTENT(in),OPTIONAL :: max_step ! maximum allowed distance in time between two single valid data within a dataset, for the dataset to be eligible for statistical processing
112 LOGICAL,INTENT(in),OPTIONAL :: weighted
113 LOGICAL , INTENT(in),OPTIONAL :: clone
114 
115 INTEGER :: dtmax, dtstep
116 
117 
118 IF (stat_proc_input == 254) THEN
119  CALL l4f_category_log(this%category, l4f_info, &
120  'computing statistical processing by aggregation '//&
121  trim(to_char(stat_proc_input))//':'//trim(to_char(stat_proc)))
122 
123  CALL volgrid6d_compute_stat_proc_agg(this, that, stat_proc, &
124  step, start, max_step, clone)
125 
126 ELSE IF (stat_proc == 254) THEN
127  CALL l4f_category_log(this%category, l4f_error, &
128  'statistical processing to instantaneous data not implemented for gridded fields')
129  CALL raise_error()
130 
131 ELSE IF (stat_proc_input /= stat_proc) THEN
132  IF ((stat_proc_input == 0 .AND. stat_proc == 1) .OR. &
133  (stat_proc_input == 1 .AND. stat_proc == 0)) THEN
134  CALL l4f_category_log(this%category, l4f_info, &
135  'computing statistically processed data by integration/differentiation '// &
136  t2c(stat_proc_input)//':'//t2c(stat_proc))
137  CALL volgrid6d_compute_stat_proc_metamorph(this, that, stat_proc_input, &
138  stat_proc, clone)
139  ELSE
140  CALL l4f_category_log(this%category, l4f_error, &
141  'statistical processing '//t2c(stat_proc_input)//':'//t2c(stat_proc)// &
142  ' not implemented or does not make sense')
143  CALL raise_error()
144  ENDIF
145 
146 ELSE IF (count(this%timerange(:)%timerange == stat_proc) == 0) THEN
147  CALL l4f_category_log(this%category, l4f_warn, &
148  'no timeranges of the desired statistical processing type '//t2c(stat_proc)//' available')
149 ! return an empty volume, without signaling error
150  CALL init(that)
151  CALL volgrid6d_alloc_vol(that)
152 
153 ELSE
154 ! euristically determine whether aggregation or difference is more suitable
155  dtmax = maxval(this%timerange(:)%p2, &
156  mask=(this%timerange(:)%timerange == stat_proc))
157  CALL getval(step, asec=dtstep)
158 
159 #ifdef DEBUG
160  CALL l4f_category_log(this%category, l4f_debug, &
161  'stat_proc='//t2c(stat_proc)//' dtmax='//t2c(dtmax)//' dtstep='//t2c(dtstep))
162 #endif
163 
164  IF (dtstep < dtmax) THEN
165  CALL l4f_category_log(this%category, l4f_info, &
166  'recomputing statistically processed data by difference '// &
167  t2c(stat_proc_input)//':'//t2c(stat_proc))
168  CALL volgrid6d_recompute_stat_proc_diff(this, that, stat_proc, step, &
169  full_steps, start, clone)
170  ELSE
171  CALL l4f_category_log(this%category, l4f_info, &
172  'recomputing statistically processed data by aggregation '// &
173  t2c(stat_proc_input)//':'//t2c(stat_proc))
174  CALL volgrid6d_recompute_stat_proc_agg(this, that, stat_proc, step, start, &
175  frac_valid, clone)
176  ENDIF
177 
178 ENDIF
179 
180 END SUBROUTINE volgrid6d_compute_stat_proc
181 
182 
224 SUBROUTINE volgrid6d_recompute_stat_proc_agg(this, that, stat_proc, step, start, frac_valid, clone)
225 TYPE(volgrid6d),INTENT(inout) :: this
226 type(volgrid6d),INTENT(out) :: that
227 INTEGER,INTENT(in) :: stat_proc
228 type(timedelta),INTENT(in) :: step
229 type(datetime),INTENT(in),OPTIONAL :: start
230 REAL,INTENT(in),OPTIONAL :: frac_valid
231 LOGICAL, INTENT(in),OPTIONAL :: clone
232 
233 INTEGER :: tri
234 INTEGER i, j, n, n1, ndtr, i3, i6
235 TYPE(arrayof_ttr_mapper),POINTER :: map_ttr(:,:)
236 INTEGER,POINTER :: dtratio(:)
237 REAL :: lfrac_valid
238 LOGICAL :: lclone
239 REAL,POINTER :: voldatiin(:,:), voldatiout(:,:)
240 
241 
242 nullify(voldatiin, voldatiout)
243 tri = stat_proc
244 IF (present(frac_valid)) THEN
245  lfrac_valid = frac_valid
246 ELSE
247  lfrac_valid = 1.0
248 ENDIF
249 
250 CALL init(that)
251 ! be safe
252 CALL volgrid6d_alloc_vol(this)
253 
254 ! when volume is not decoded it is better to clone anyway to avoid
255 ! overwriting fields
256 lclone = optio_log(clone) .OR. .NOT.ASSOCIATED(this%voldati)
257 ! initialise the output volume
258 CALL init(that, griddim=this%griddim, time_definition=this%time_definition)
259 CALL volgrid6d_alloc(that, dim=this%griddim%dim, ntimerange=1, &
260  nlevel=SIZE(this%level), nvar=SIZE(this%var), ini=.false.)
261 that%level = this%level
262 that%var = this%var
263 
264 CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
265  step, this%time_definition, that%time, that%timerange, map_ttr, &
266  dtratio=dtratio, start=start)
267 
268 CALL volgrid6d_alloc_vol(that, decode=ASSOCIATED(this%voldati))
269 
270 do_otimerange: DO j = 1, SIZE(that%timerange)
271  do_otime: DO i = 1, SIZE(that%time)
272 
273  DO n1 = 1, SIZE(dtratio)
274  IF (dtratio(n1) <= 0) cycle ! safety check
275 
276  DO i6 = 1, SIZE(this%var)
277  DO i3 = 1, SIZE(this%level)
278  CALL volgrid_get_vol_2d(that, i3, i, j, i6, voldatiout)
279  ndtr = 0
280  DO n = 1, map_ttr(i,j)%arraysize
281  IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1)) THEN
282  ndtr = ndtr + 1
283  CALL volgrid_get_vol_2d(this, i3, map_ttr(i,j)%array(n)%it, &
284  map_ttr(i,j)%array(n)%itr, i6, voldatiin)
285 
286  IF (ndtr == 1) THEN
287  voldatiout = voldatiin
288  IF (lclone) THEN
289  CALL copy(this%gaid(i3, map_ttr(i,j)%array(n)%it,&
290  map_ttr(i,j)%array(n)%itr,i6), that%gaid(i3,i,j,i6))
291  ELSE
292  that%gaid(i3,i,j,i6) = this%gaid(i3, map_ttr(i,j)%array(n)%it, &
293  map_ttr(i,j)%array(n)%itr,i6)
294  ENDIF
296  ELSE ! second or more time
297  SELECT CASE(stat_proc)
298  CASE (0, 1, 4) ! average, accumulation, difference
299  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
300  voldatiout(:,:) = voldatiout(:,:) + voldatiin(:,:)
301  ELSEWHERE
302  voldatiout(:,:) = rmiss
303  END WHERE
304  CASE(2) ! maximum
305  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
306  voldatiout(:,:) = max(voldatiout(:,:), voldatiin(:,:))
307  ELSEWHERE
308  voldatiout(:,:) = rmiss
309  END WHERE
310  CASE(3) ! minimum
311  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
312  voldatiout(:,:) = min(voldatiout(:,:), voldatiin(:,:))
313  ELSEWHERE
314  voldatiout(:,:) = rmiss
315  END WHERE
316  END SELECT
317 
318  ENDIF ! first time
319  ENDIF ! dtratio(n1)
320  ENDDO ! ttr
321 
322  IF (REAL(ndtr)/REAL(dtratio(n1)) >= lfrac_valid) then ! success
323  IF (stat_proc == 0) THEN ! average
324  WHERE(c_e(voldatiout(:,:)))
325  voldatiout(:,:) = voldatiout(:,:)/ndtr
326  END WHERE
327  ENDIF
328  CALL volgrid_set_vol_2d(that, i3, i, j, i6, voldatiout)
329  ENDIF
330 
331  ENDDO ! level
332  ENDDO ! var
333  ENDDO ! dtratio
334  CALL delete(map_ttr(i,j))
335  ENDDO do_otime
336 ENDDO do_otimerange
337 
338 DEALLOCATE(dtratio, map_ttr)
339 
340 END SUBROUTINE volgrid6d_recompute_stat_proc_agg
341 
342 
366 SUBROUTINE volgrid6d_compute_stat_proc_agg(this, that, stat_proc, step, start, max_step, clone)
367 TYPE(volgrid6d),INTENT(inout) :: this
368 type(volgrid6d),INTENT(out) :: that
369 INTEGER,INTENT(in) :: stat_proc
370 type(timedelta),INTENT(in) :: step
371 type(datetime),INTENT(in),OPTIONAL :: start
372 type(timedelta),INTENT(in),OPTIONAL :: max_step
373 LOGICAL , INTENT(in),OPTIONAL :: clone
374 
375 INTEGER :: tri
376 INTEGER i, j, n, ninp, i3, i6
377 TYPE(arrayof_ttr_mapper),POINTER :: map_ttr(:,:)
378 TYPE(timedelta) :: lmax_step
379 LOGICAL :: lclone
380 REAL,POINTER :: voldatiin(:,:), voldatiout(:,:)
381 
382 
383 nullify(voldatiin, voldatiout)
384 tri = 254
385 IF (present(max_step)) THEN
386  lmax_step = max_step
387 ELSE
388  lmax_step = timedelta_max
389 ENDIF
390 
391 CALL init(that)
392 ! be safe
393 CALL volgrid6d_alloc_vol(this)
394 
395 ! when volume is not decoded it is better to clone anyway to avoid
396 ! overwriting fields
397 lclone = optio_log(clone) .OR. .NOT.ASSOCIATED(this%voldati)
398 ! initialise the output volume
399 CALL init(that, griddim=this%griddim, time_definition=this%time_definition)
400 CALL volgrid6d_alloc(that, dim=this%griddim%dim, ntimerange=1, &
401  nlevel=SIZE(this%level), nvar=SIZE(this%var), ini=.false.)
402 that%level = this%level
403 that%var = this%var
404 
405 CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
406  step, this%time_definition, that%time, that%timerange, map_ttr, start=start)
407 
408 CALL volgrid6d_alloc_vol(that, decode=ASSOCIATED(this%voldati))
409 
410 do_otimerange: DO j = 1, SIZE(that%timerange)
411  do_otime: DO i = 1, SIZE(that%time)
412  ninp = map_ttr(i,j)%arraysize
413  IF (ninp <= 0) cycle do_otime
414 
415  IF (stat_proc == 4) THEN ! check validity for difference
416  IF (map_ttr(i,j)%array(1)%extra_info /= 1 .OR. &
417  map_ttr(i,j)%array(ninp)%extra_info /= 2) THEN
418  CALL delete(map_ttr(i,j))
419  cycle do_otime
420  ENDIF
421  ELSE
422 ! check validity condition (missing values in volume are not accounted for)
423  DO n = 2, ninp
424  IF (map_ttr(i,j)%array(n)%time - map_ttr(i,j)%array(n-1)%time > &
425  lmax_step) THEN
426  CALL delete(map_ttr(i,j))
427  cycle do_otime
428  ENDIF
429  ENDDO
430  ENDIF
431 
432  DO i6 = 1, SIZE(this%var)
433  DO i3 = 1, SIZE(this%level)
434  CALL volgrid_get_vol_2d(that, i3, i, j, i6, voldatiout)
435 
436  IF (stat_proc == 4) THEN ! special treatment for difference
437  IF (lclone) THEN
438  CALL copy(this%gaid(i3, map_ttr(i,j)%array(1)%it,&
439  map_ttr(i,j)%array(1)%itr,i6), that%gaid(i3,i,j,i6))
440  ELSE
441  that%gaid(i3,i,j,i6) = this%gaid(i3, map_ttr(i,j)%array(1)%it, &
442  map_ttr(i,j)%array(1)%itr,i6)
443  ENDIF
444 ! improve the next workflow?
445  CALL volgrid_get_vol_2d(this, i3, map_ttr(i,j)%array(ninp)%it, &
446  map_ttr(i,j)%array(ninp)%itr, i6, voldatiin)
447  voldatiout = voldatiin
448  CALL volgrid_get_vol_2d(this, i3, map_ttr(i,j)%array(1)%it, &
449  map_ttr(i,j)%array(1)%itr, i6, voldatiin)
450 
451  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
452  voldatiout(:,:) = voldatiout(:,:) - voldatiin(:,:)
453  ELSEWHERE
454  voldatiout(:,:) = rmiss
455  END WHERE
456 
457  ELSE ! other stat_proc
458  DO n = 1, ninp
459  CALL volgrid_get_vol_2d(this, i3, map_ttr(i,j)%array(n)%it, &
460  map_ttr(i,j)%array(n)%itr, i6, voldatiin)
461 
462  IF (n == 1) THEN
463  voldatiout = voldatiin
464  IF (lclone) THEN
465  CALL copy(this%gaid(i3, map_ttr(i,j)%array(n)%it,&
466  map_ttr(i,j)%array(n)%itr,i6), that%gaid(i3,i,j,i6))
467  ELSE
468  that%gaid(i3,i,j,i6) = this%gaid(i3, map_ttr(i,j)%array(n)%it, &
469  map_ttr(i,j)%array(n)%itr,i6)
470  ENDIF
471 
472  ELSE ! second or more time
473  SELECT CASE(stat_proc)
474  CASE (0, 1) ! average, accumulation
475  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
476  voldatiout(:,:) = voldatiout(:,:) + voldatiin(:,:)
477  ELSEWHERE
478  voldatiout(:,:) = rmiss
479  END WHERE
480  CASE(2) ! maximum
481  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
482  voldatiout(:,:) = max(voldatiout(:,:), voldatiin(:,:))
483  ELSEWHERE
484  voldatiout(:,:) = rmiss
485  END WHERE
486  CASE(3) ! minimum
487  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
488  voldatiout(:,:) = min(voldatiout(:,:), voldatiin(:,:))
489  ELSEWHERE
490  voldatiout(:,:) = rmiss
491  END WHERE
492  END SELECT
493 
494  ENDIF ! first time
495  ENDDO
496  IF (stat_proc == 0) THEN ! average
497  WHERE(c_e(voldatiout(:,:)))
498  voldatiout(:,:) = voldatiout(:,:)/ninp
499  END WHERE
500  ENDIF
501  ENDIF
502  CALL volgrid_set_vol_2d(that, i3, i, j, i6, voldatiout)
503  ENDDO ! level
504  ENDDO ! var
505  CALL delete(map_ttr(i,j))
506  ENDDO do_otime
507 ENDDO do_otimerange
508 
509 DEALLOCATE(map_ttr)
510 
511 
512 END SUBROUTINE volgrid6d_compute_stat_proc_agg
513 
514 
539 SUBROUTINE volgrid6d_recompute_stat_proc_diff(this, that, stat_proc, step, full_steps, start, clone)
540 TYPE(volgrid6d),INTENT(inout) :: this
541 type(volgrid6d),INTENT(out) :: that
542 INTEGER,INTENT(in) :: stat_proc
543 type(timedelta),INTENT(in) :: step
544 LOGICAL,INTENT(in),OPTIONAL :: full_steps
545 type(datetime),INTENT(in),OPTIONAL :: start
546 LOGICAL,INTENT(in),OPTIONAL :: clone
547 INTEGER :: i3, i4, i6, i, j, k, l, nitr, steps
548 INTEGER,POINTER :: map_tr(:,:,:,:,:), f(:)
549 REAL,POINTER :: voldatiin1(:,:), voldatiin2(:,:), voldatiout(:,:)
550 LOGICAL,POINTER :: mask_timerange(:)
551 LOGICAL :: lclone
552 
553 
554 ! be safe
555 CALL volgrid6d_alloc_vol(this)
556 ! when volume is not decoded it is better to clone anyway to avoid
557 ! overwriting fields
558 lclone = optio_log(clone) .OR. .NOT.ASSOCIATED(this%voldati)
559 ! initialise the output volume
560 CALL init(that, griddim=this%griddim, time_definition=this%time_definition)
561 CALL volgrid6d_alloc(that, dim=this%griddim%dim, &
562  nlevel=SIZE(this%level), nvar=SIZE(this%var), ini=.false.)
563 that%level = this%level
564 that%var = this%var
565 
566 ! compute length of cumulation step in seconds
567 CALL getval(step, asec=steps)
568 
569 ! compute the statistical processing relations, output time and
570 ! timerange are defined here
571 CALL recompute_stat_proc_diff_common(this%time, this%timerange, stat_proc, step, &
572  nitr, that%time, that%timerange, map_tr, f, mask_timerange, &
573  this%time_definition, full_steps, start)
574 
575 ! complete the definition of the output volume
576 CALL volgrid6d_alloc_vol(that, decode=ASSOCIATED(this%voldati))
577 ! allocate workspace once
578 IF (.NOT.ASSOCIATED(that%voldati)) THEN
579  ALLOCATE(voldatiin1(this%griddim%dim%nx, this%griddim%dim%ny), &
580  voldatiin2(this%griddim%dim%nx, this%griddim%dim%ny), &
581  voldatiout(this%griddim%dim%nx, this%griddim%dim%ny))
582 ENDIF
583 
584 ! copy the timeranges already satisfying the requested step, if any
585 DO i = 1, SIZE(mask_timerange)
586  IF (mask_timerange(i)) THEN
587  k = firsttrue(that%timerange(:) == this%timerange(i))
588 #ifdef DEBUG
589  CALL l4f_category_log(this%category, l4f_info, &
590  'volgrid6d_recompute_stat_proc_diff, good timerange: '//t2c(i)// &
591  '->'//t2c(k))
592 #endif
593  IF (k > 0) THEN
594 
595  DO i6 = 1, SIZE(this%var)
596  DO i4 = 1, SIZE(this%time)
597  l = firsttrue(that%time(:) == this%time(i4))
598  IF (l > 0) THEN
599  DO i3 = 1, SIZE(this%level)
600  IF (c_e(this%gaid(i3,i4,i,i6))) THEN
601  IF (lclone) THEN
602  CALL copy(this%gaid(i3,i4,i,i6), that%gaid(i3,l,k,i6))
603  ELSE
604  that%gaid(i3,l,k,i6) = this%gaid(i3,i4,i,i6)
605  ENDIF
606  IF (ASSOCIATED(that%voldati)) THEN
607  that%voldati(:,:,i3,l,k,i6) = this%voldati(:,:,i3,i4,i,i6)
608  ELSE
609  CALL volgrid_get_vol_2d(this, i3, i4, i, i6, voldatiout)
610  CALL volgrid_set_vol_2d(that, i3, l, k, i6, voldatiout)
611  ENDIF
612  ENDIF
613  ENDDO
614  ENDIF
615  ENDDO
616  ENDDO
617 
618  ENDIF
619  ENDIF
620 ENDDO
621 
622 ! compute statistical processing
623 DO l = 1, SIZE(this%time)
624  DO k = 1, nitr
625  DO j = 1, SIZE(this%time)
626  DO i = 1, nitr
627  IF (c_e(map_tr(i,j,k,l,1))) THEN
628  DO i6 = 1, SIZE(this%var)
629  DO i3 = 1, SIZE(this%level)
630 
631  IF (c_e(this%gaid(i3,j,f(i),i6)) .AND. &
632  c_e(this%gaid(i3,l,f(k),i6))) THEN
633 ! take the gaid from the second time/timerange contributing to the
634 ! result (l,f(k))
635  IF (lclone) THEN
636  CALL copy(this%gaid(i3,l,f(k),i6), &
637  that%gaid(i3,map_tr(i,j,k,l,1),map_tr(i,j,k,l,2),i6))
638  ELSE
639  that%gaid(i3,map_tr(i,j,k,l,1),map_tr(i,j,k,l,2),i6) = &
640  this%gaid(i3,l,f(k),i6)
641  ENDIF
642 
643 ! get/set 2d sections API is used
644  CALL volgrid_get_vol_2d(this, i3, l, f(k), i6, voldatiin1)
645  CALL volgrid_get_vol_2d(this, i3, j, f(i), i6, voldatiin2)
646  IF (ASSOCIATED(that%voldati)) &
647  CALL volgrid_get_vol_2d(that, i3, &
648  map_tr(i,j,k,l,1), map_tr(i,j,k,l,2), i6, voldatiout)
649 
650  IF (stat_proc == 0) THEN ! average
651  WHERE(c_e(voldatiin1(:,:)) .AND. c_e(voldatiin2(:,:)))
652  voldatiout(:,:) = &
653  (voldatiin1(:,:)*this%timerange(f(k))%p2 - &
654  voldatiin2(:,:)*this%timerange(f(i))%p2)/ &
655  steps
656  ELSEWHERE
657  voldatiout(:,:) = rmiss
658  END WHERE
659  ELSE IF (stat_proc == 1 .OR. stat_proc == 4) THEN ! acc, diff
660  WHERE(c_e(voldatiin1(:,:)) .AND. c_e(voldatiin2(:,:)))
661  voldatiout(:,:) = voldatiin1(:,:) - voldatiin2(:,:)
662  ELSEWHERE
663  voldatiout(:,:) = rmiss
664  END WHERE
665  ENDIF
666 
667  CALL volgrid_set_vol_2d(that, i3, &
668  map_tr(i,j,k,l,1), map_tr(i,j,k,l,2), i6, voldatiout)
669 
670  ENDIF
671  ENDDO
672  ENDDO
673  ENDIF
674  ENDDO
675  ENDDO
676  ENDDO
677 ENDDO
678 
679 IF (.NOT.ASSOCIATED(that%voldati)) THEN
680  DEALLOCATE(voldatiin1, voldatiin2, voldatiout)
681 ENDIF
682 
683 END SUBROUTINE volgrid6d_recompute_stat_proc_diff
684 
685 
713 SUBROUTINE volgrid6d_compute_stat_proc_metamorph(this, that, stat_proc_input, stat_proc, clone)
714 TYPE(volgrid6d),INTENT(inout) :: this
715 type(volgrid6d),INTENT(out) :: that
716 INTEGER,INTENT(in) :: stat_proc_input
717 INTEGER,INTENT(in) :: stat_proc
718 LOGICAL , INTENT(in),OPTIONAL :: clone
719 
720 INTEGER i, j, n, i3, i4, i6
721 INTEGER,POINTER :: map_tr(:), map_trc(:,:), count_trc(:,:)
722 REAL,POINTER :: voldatiin(:,:), voldatiout(:,:)
723 REAL,ALLOCATABLE :: int_ratio(:)
724 LOGICAL :: lclone
725 
726 nullify(voldatiin, voldatiout)
727 
728 ! be safe
729 CALL volgrid6d_alloc_vol(this)
730 ! when volume is not decoded it is better to clone anyway to avoid
731 ! overwriting fields
732 lclone = optio_log(clone) .OR. .NOT.ASSOCIATED(this%voldati)
734 IF (.NOT.((stat_proc_input == 0 .AND. stat_proc == 1) .OR. &
735  (stat_proc_input == 1 .AND. stat_proc == 0))) THEN
736 
737  CALL l4f_category_log(this%category, l4f_warn, &
738  'compute_stat_proc_metamorph, can only be applied to average->accumulated timerange and viceversa')
739 ! return an empty volume, without signaling error
740  CALL init(that)
741  CALL volgrid6d_alloc_vol(that)
742  RETURN
743 ENDIF
744 
745 ! initialise the output volume
746 CALL init(that, griddim=this%griddim, time_definition=this%time_definition)
747 CALL volgrid6d_alloc(that, dim=this%griddim%dim, ntime=SIZE(this%time), &
748  nlevel=SIZE(this%level), nvar=SIZE(this%var), ini=.false.)
749 that%time = this%time
750 that%level = this%level
751 that%var = this%var
752 
753 CALL compute_stat_proc_metamorph_common(stat_proc_input, this%timerange, stat_proc, &
754  that%timerange, map_tr)
755 
756 ! complete the definition of the output volume
757 CALL volgrid6d_alloc_vol(that, decode=ASSOCIATED(this%voldati))
758 
759 IF (stat_proc == 0) THEN ! average -> integral
760  int_ratio = 1./REAL(that%timerange(:)%p2)
761 ELSE ! cumulation
762  int_ratio = REAL(that%timerange(:)%p2)
763 ENDIF
764 
765 DO i6 = 1, SIZE(this%var)
766  DO j = 1, SIZE(map_tr)
767  DO i4 = 1, SIZE(that%time)
768  DO i3 = 1, SIZE(this%level)
769 
770  IF (lclone) THEN
771  CALL copy(this%gaid(i3,i4,map_tr(j),i6), that%gaid(i3,i4,j,i6))
772  ELSE
773  that%gaid(i3,i4,map_tr(j),i6) = this%gaid(i3,i4,j,i6)
774  ENDIF
775  CALL volgrid_get_vol_2d(this, i3, i4, map_tr(j), i6, voldatiin)
776  CALL volgrid_get_vol_2d(that, i3, i4, j, i6, voldatiout)
777  WHERE (c_e(voldatiin))
778  voldatiout = voldatiin*int_ratio(j)
779  ELSEWHERE
780  voldatiout = rmiss
781  END WHERE
782  CALL volgrid_set_vol_2d(that, i3, i4, j, i6, voldatiout)
783  ENDDO
784  ENDDO
785  ENDDO
786 ENDDO
787 
788 
789 END SUBROUTINE volgrid6d_compute_stat_proc_metamorph
790 
791 END MODULE volgrid6d_class_compute
Classi per la gestione delle coordinate temporali.
Functions that return a trimmed CHARACTER representation of the input variable.
This module defines an abstract interface to different drivers for access to files containing gridded...
Object describing a rectangular, homogeneous gridded dataset.
Module for basic statistical computations taking into account missing data.
Definition: simple_stat.f90:25
This module defines objects and methods for managing data volumes on rectangular georeferenced grids...
Distruttori per le 2 classi.
Restituiscono il valore dell&#39;oggetto in forma di stringa stampabile.
Restituiscono il valore dell&#39;oggetto nella forma desiderata.
Costruttori per le classi datetime e timedelta.
Copy an object, creating a fully new instance.
Class for expressing a relative time interval.
Clone the object, creating a new independent instance of the object exactly equal to the starting one...
This module contains functions that are only for internal use of the library.
Extension of volgrid6d_class with methods for performing simple statistical operations on entire volu...
Emit log message for a category with specific priority.
Derived type defining a dynamically extensible array of TYPE(ttr_mapper) elements.

Generated with Doxygen.