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
295 
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)
733 
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
Costruttore per la classe vol7d_level.
Distruttore per la classe vol7d_level.
Functions that return a trimmed CHARACTER representation of the input variable.
Represent level object in a pretty string.
This module contains functions that are only for internal use of the library.
copy object
This module defines an abstract interface to different drivers for access to files containing gridded...
Classi per la gestione delle coordinate temporali.
This module defines objects and methods for managing data volumes on rectangular georeferenced grids...
Restituiscono il valore dell&#39;oggetto nella forma desiderata.
Clone the object, creating a new independent instance of the object exactly equal to the starting one...
Module for basic statistical computations taking into account missing data.
Definition: simple_stat.f90:25
Extension of volgrid6d_class with methods for performing simple statistical operations on entire volu...
Emit log message for a category with specific priority.

Generated with Doxygen.