libsim  Versione7.1.6
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 
30 USE grid_id_class
32 USE simple_stat
33 IMPLICIT NONE
34 
35 CONTAINS
36 
102 SUBROUTINE volgrid6d_compute_stat_proc(this, that, stat_proc_input, stat_proc, &
103  step, start, full_steps, frac_valid, max_step, weighted, clone)
104 TYPE(volgrid6d),INTENT(inout) :: this
105 type(volgrid6d),INTENT(out) :: that
106 INTEGER,INTENT(in) :: stat_proc_input
107 INTEGER,INTENT(in) :: stat_proc
108 type(timedelta),INTENT(in) :: step
109 type(datetime),INTENT(in),OPTIONAL :: start
110 LOGICAL,INTENT(in),OPTIONAL :: full_steps
111 REAL,INTENT(in),OPTIONAL :: frac_valid
112 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
113 LOGICAL,INTENT(in),OPTIONAL :: weighted
114 LOGICAL , INTENT(in),OPTIONAL :: clone
115 
116 INTEGER :: dtmax, dtstep
117 
118 
119 IF (stat_proc_input == 254) THEN
120  CALL l4f_category_log(this%category, l4f_info, &
121  'computing statistical processing by aggregation '//&
122  trim(to_char(stat_proc_input))//':'//trim(to_char(stat_proc)))
123 
124  CALL volgrid6d_compute_stat_proc_agg(this, that, stat_proc, &
125  step, start, full_steps, max_step, clone)
126 
127 ELSE IF (stat_proc == 254) THEN
128  CALL l4f_category_log(this%category, l4f_error, &
129  'statistical processing to instantaneous data not implemented for gridded fields')
130  CALL raise_error()
131 
132 ELSE IF (stat_proc_input /= stat_proc) THEN
133  IF ((stat_proc_input == 0 .AND. stat_proc == 1) .OR. &
134  (stat_proc_input == 1 .AND. stat_proc == 0)) THEN
135  CALL l4f_category_log(this%category, l4f_info, &
136  'computing statistically processed data by integration/differentiation '// &
137  t2c(stat_proc_input)//':'//t2c(stat_proc))
138  CALL volgrid6d_compute_stat_proc_metamorph(this, that, stat_proc_input, &
139  stat_proc, clone)
140  ELSE
141  CALL l4f_category_log(this%category, l4f_error, &
142  'statistical processing '//t2c(stat_proc_input)//':'//t2c(stat_proc)// &
143  ' not implemented or does not make sense')
144  CALL raise_error()
145  ENDIF
146 
147 ELSE IF (count(this%timerange(:)%timerange == stat_proc) == 0) THEN
148  CALL l4f_category_log(this%category, l4f_warn, &
149  'no timeranges of the desired statistical processing type '//t2c(stat_proc)//' available')
150 ! return an empty volume, without signaling error
151  CALL init(that)
152  CALL volgrid6d_alloc_vol(that)
153 
154 ELSE
155 ! euristically determine whether aggregation or difference is more suitable
156  dtmax = maxval(this%timerange(:)%p2, &
157  mask=(this%timerange(:)%timerange == stat_proc))
158  CALL getval(step, asec=dtstep)
159 
160 #ifdef DEBUG
161  CALL l4f_category_log(this%category, l4f_debug, &
162  'stat_proc='//t2c(stat_proc)//' dtmax='//t2c(dtmax)//' dtstep='//t2c(dtstep))
163 #endif
164 
165  IF (dtstep < dtmax) THEN
166  CALL l4f_category_log(this%category, l4f_info, &
167  'recomputing statistically processed data by difference '// &
168  t2c(stat_proc_input)//':'//t2c(stat_proc))
169  CALL volgrid6d_recompute_stat_proc_diff(this, that, stat_proc, step, &
170  full_steps, start, clone)
171  ELSE
172  CALL l4f_category_log(this%category, l4f_info, &
173  'recomputing statistically processed data by aggregation '// &
174  t2c(stat_proc_input)//':'//t2c(stat_proc))
175  CALL volgrid6d_recompute_stat_proc_agg(this, that, stat_proc, step, start, &
176  full_steps, frac_valid, clone)
177  ENDIF
178 
179 ENDIF
180 
181 END SUBROUTINE volgrid6d_compute_stat_proc
182 
183 
226 SUBROUTINE volgrid6d_recompute_stat_proc_agg(this, that, stat_proc, &
227  step, start, full_steps, frac_valid, clone)
228 TYPE(volgrid6d),INTENT(inout) :: this
229 type(volgrid6d),INTENT(out) :: that
230 INTEGER,INTENT(in) :: stat_proc
231 type(timedelta),INTENT(in) :: step
232 type(datetime),INTENT(in),OPTIONAL :: start
233 LOGICAL,INTENT(in),OPTIONAL :: full_steps
234 REAL,INTENT(in),OPTIONAL :: frac_valid
235 LOGICAL, INTENT(in),OPTIONAL :: clone
236 
237 INTEGER :: tri
238 INTEGER i, j, n, n1, ndtr, i3, i6
239 TYPE(arrayof_ttr_mapper),POINTER :: map_ttr(:,:)
240 INTEGER,POINTER :: dtratio(:)
241 REAL :: lfrac_valid
242 LOGICAL :: lclone
243 REAL,POINTER :: voldatiin(:,:), voldatiout(:,:)
244 
245 
246 nullify(voldatiin, voldatiout)
247 tri = stat_proc
248 IF (present(frac_valid)) THEN
249  lfrac_valid = frac_valid
250 ELSE
251  lfrac_valid = 1.0
252 ENDIF
253 
254 CALL init(that)
255 ! be safe
256 CALL volgrid6d_alloc_vol(this)
257 
258 ! when volume is not decoded it is better to clone anyway to avoid
259 ! overwriting fields
260 lclone = optio_log(clone) .OR. .NOT.ASSOCIATED(this%voldati)
261 ! initialise the output volume
262 CALL init(that, griddim=this%griddim, time_definition=this%time_definition)
263 CALL volgrid6d_alloc(that, dim=this%griddim%dim, ntimerange=1, &
264  nlevel=SIZE(this%level), nvar=SIZE(this%var), ini=.false.)
265 that%level = this%level
266 that%var = this%var
267 
268 CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
269  step, this%time_definition, that%time, that%timerange, map_ttr, &
270  dtratio=dtratio, start=start, full_steps=full_steps)
271 
272 CALL volgrid6d_alloc_vol(that, decode=ASSOCIATED(this%voldati))
273 
274 do_otimerange: DO j = 1, SIZE(that%timerange)
275  do_otime: DO i = 1, SIZE(that%time)
276 
277  DO n1 = 1, SIZE(dtratio)
278  IF (dtratio(n1) <= 0) cycle ! safety check
279 
280  DO i6 = 1, SIZE(this%var)
281  DO i3 = 1, SIZE(this%level)
282  CALL volgrid_get_vol_2d(that, i3, i, j, i6, voldatiout)
283  ndtr = 0
284  DO n = 1, map_ttr(i,j)%arraysize
285  IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1)) THEN
286  ndtr = ndtr + 1
287  CALL volgrid_get_vol_2d(this, i3, map_ttr(i,j)%array(n)%it, &
288  map_ttr(i,j)%array(n)%itr, i6, voldatiin)
289 
290  IF (ndtr == 1) THEN
291  voldatiout = voldatiin
292  IF (lclone) THEN
293  CALL copy(this%gaid(i3, map_ttr(i,j)%array(n)%it,&
294  map_ttr(i,j)%array(n)%itr,i6), that%gaid(i3,i,j,i6))
295  ELSE
296  that%gaid(i3,i,j,i6) = this%gaid(i3, map_ttr(i,j)%array(n)%it, &
297  map_ttr(i,j)%array(n)%itr,i6)
298  ENDIF
299 
300  ELSE ! second or more time
301  SELECT CASE(stat_proc)
302  CASE (0, 200, 1, 4) ! average, vectorial mean, accumulation, difference
303  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
304  voldatiout(:,:) = voldatiout(:,:) + voldatiin(:,:)
305  ELSEWHERE
306  voldatiout(:,:) = rmiss
307  END WHERE
308  CASE(2) ! maximum
309  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
310  voldatiout(:,:) = max(voldatiout(:,:), voldatiin(:,:))
311  ELSEWHERE
312  voldatiout(:,:) = rmiss
313  END WHERE
314  CASE(3) ! minimum
315  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
316  voldatiout(:,:) = min(voldatiout(:,:), voldatiin(:,:))
317  ELSEWHERE
318  voldatiout(:,:) = rmiss
319  END WHERE
320  END SELECT
321 
322  ENDIF ! first time
323  ENDIF ! dtratio(n1)
324  ENDDO ! ttr
325 
326 #ifdef DEBUG
327  CALL l4f_log(l4f_debug, &
328  'compute_stat_proc_agg, ndtr/dtratio/frac_valid: '// &
329  t2c(ndtr)//'/'//t2c(dtratio(n1))//'/'//t2c(lfrac_valid))
330 #endif
331  IF (ndtr > 0) THEN ! why this condition was not here before?
332  IF (REAL(ndtr)/REAL(dtratio(n1)) >= lfrac_valid) then ! success
333  IF (stat_proc == 0) THEN ! average
334  WHERE(c_e(voldatiout(:,:)))
335  voldatiout(:,:) = voldatiout(:,:)/ndtr
336  END WHERE
337  ENDIF
338  CALL volgrid_set_vol_2d(that, i3, i, j, i6, voldatiout)
339 #ifdef DEBUG
340  CALL l4f_log(l4f_debug, &
341  'compute_stat_proc_agg, coding lev/t/tr/var: '// &
342  t2c(i3)//'/'//t2c(i)//'/'//t2c(j)//'/'//t2c(i6))
343 #endif
344  ELSE
345 ! must nullify the output gaid here, otherwise an incomplete field will be output
346  IF (lclone) THEN
347  CALL delete(that%gaid(i3,i,j,i6))
348  ELSE
349  CALL init(that%gaid(i3,i,j,i6)) ! grid_id lacks a nullify method
350  ENDIF
351 #ifdef DEBUG
352  CALL l4f_log(l4f_debug, &
353  'compute_stat_proc_agg, skipping lev/t/tr/var: '// &
354  t2c(i3)//'/'//t2c(i)//'/'//t2c(j)//'/'//t2c(i6))
355 #endif
356  ENDIF
357  ENDIF ! ndtr > 0
358 
359  ENDDO ! level
360  ENDDO ! var
361  ENDDO ! dtratio
362  CALL delete(map_ttr(i,j))
363  ENDDO do_otime
364 ENDDO do_otimerange
365 
366 DEALLOCATE(dtratio, map_ttr)
367 
368 END SUBROUTINE volgrid6d_recompute_stat_proc_agg
369 
370 
394 SUBROUTINE volgrid6d_compute_stat_proc_agg(this, that, stat_proc, &
395  step, start, full_steps, max_step, clone)
396 TYPE(volgrid6d),INTENT(inout) :: this
397 type(volgrid6d),INTENT(out) :: that
398 INTEGER,INTENT(in) :: stat_proc
399 type(timedelta),INTENT(in) :: step
400 type(datetime),INTENT(in),OPTIONAL :: start
401 LOGICAL,INTENT(in),OPTIONAL :: full_steps
402 type(timedelta),INTENT(in),OPTIONAL :: max_step
403 LOGICAL , INTENT(in),OPTIONAL :: clone
404 
405 INTEGER :: tri
406 INTEGER i, j, n, ninp, i3, i6
407 TYPE(arrayof_ttr_mapper),POINTER :: map_ttr(:,:)
408 TYPE(timedelta) :: lmax_step
409 LOGICAL :: lclone
410 REAL,POINTER :: voldatiin(:,:), voldatiout(:,:)
412 
413 nullify(voldatiin, voldatiout)
414 tri = 254
415 IF (present(max_step)) THEN
416  lmax_step = max_step
417 ELSE
418  lmax_step = timedelta_max
419 ENDIF
420 
421 CALL init(that)
422 ! be safe
423 CALL volgrid6d_alloc_vol(this)
424 
425 ! when volume is not decoded it is better to clone anyway to avoid
426 ! overwriting fields
427 lclone = optio_log(clone) .OR. .NOT.ASSOCIATED(this%voldati)
428 ! initialise the output volume
429 CALL init(that, griddim=this%griddim, time_definition=this%time_definition)
430 CALL volgrid6d_alloc(that, dim=this%griddim%dim, ntimerange=1, &
431  nlevel=SIZE(this%level), nvar=SIZE(this%var), ini=.false.)
432 that%level = this%level
433 that%var = this%var
434 
435 CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
436  step, this%time_definition, that%time, that%timerange, map_ttr, &
437  start=start, full_steps=full_steps)
438 
439 CALL volgrid6d_alloc_vol(that, decode=ASSOCIATED(this%voldati))
440 
441 do_otimerange: DO j = 1, SIZE(that%timerange)
442  do_otime: DO i = 1, SIZE(that%time)
443  ninp = map_ttr(i,j)%arraysize
444  IF (ninp <= 0) cycle do_otime
445 
446  IF (stat_proc == 4) THEN ! check validity for difference
447  IF (map_ttr(i,j)%array(1)%extra_info /= 1 .OR. &
448  map_ttr(i,j)%array(ninp)%extra_info /= 2) THEN
449  CALL delete(map_ttr(i,j))
450  cycle do_otime
451  ENDIF
452  ELSE
453 ! check validity condition (missing values in volume are not accounted for)
454  DO n = 2, ninp
455  IF (map_ttr(i,j)%array(n)%time - map_ttr(i,j)%array(n-1)%time > &
456  lmax_step) THEN
457  CALL delete(map_ttr(i,j))
458  cycle do_otime
459  ENDIF
460  ENDDO
461  ENDIF
462 
463  DO i6 = 1, SIZE(this%var)
464  DO i3 = 1, SIZE(this%level)
465  CALL volgrid_get_vol_2d(that, i3, i, j, i6, voldatiout)
466 
467  IF (stat_proc == 4) THEN ! special treatment for difference
468  IF (lclone) THEN
469  CALL copy(this%gaid(i3, map_ttr(i,j)%array(1)%it,&
470  map_ttr(i,j)%array(1)%itr,i6), that%gaid(i3,i,j,i6))
471  ELSE
472  that%gaid(i3,i,j,i6) = this%gaid(i3, map_ttr(i,j)%array(1)%it, &
473  map_ttr(i,j)%array(1)%itr,i6)
474  ENDIF
475 ! improve the next workflow?
476  CALL volgrid_get_vol_2d(this, i3, map_ttr(i,j)%array(ninp)%it, &
477  map_ttr(i,j)%array(ninp)%itr, i6, voldatiin)
478  voldatiout = voldatiin
479  CALL volgrid_get_vol_2d(this, i3, map_ttr(i,j)%array(1)%it, &
480  map_ttr(i,j)%array(1)%itr, i6, voldatiin)
481 
482  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
483  voldatiout(:,:) = voldatiout(:,:) - voldatiin(:,:)
484  ELSEWHERE
485  voldatiout(:,:) = rmiss
486  END WHERE
487 
488  ELSE ! other stat_proc
489  DO n = 1, ninp
490  CALL volgrid_get_vol_2d(this, i3, map_ttr(i,j)%array(n)%it, &
491  map_ttr(i,j)%array(n)%itr, i6, voldatiin)
492 
493  IF (n == 1) THEN
494  voldatiout = voldatiin
495  IF (lclone) THEN
496  CALL copy(this%gaid(i3, map_ttr(i,j)%array(n)%it,&
497  map_ttr(i,j)%array(n)%itr,i6), that%gaid(i3,i,j,i6))
498  ELSE
499  that%gaid(i3,i,j,i6) = this%gaid(i3, map_ttr(i,j)%array(n)%it, &
500  map_ttr(i,j)%array(n)%itr,i6)
501  ENDIF
502 
503  ELSE ! second or more time
504  SELECT CASE(stat_proc)
505  CASE (0, 1) ! average, accumulation
506  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
507  voldatiout(:,:) = voldatiout(:,:) + voldatiin(:,:)
508  ELSEWHERE
509  voldatiout(:,:) = rmiss
510  END WHERE
511  CASE(2) ! maximum
512  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
513  voldatiout(:,:) = max(voldatiout(:,:), voldatiin(:,:))
514  ELSEWHERE
515  voldatiout(:,:) = rmiss
516  END WHERE
517  CASE(3) ! minimum
518  WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
519  voldatiout(:,:) = min(voldatiout(:,:), voldatiin(:,:))
520  ELSEWHERE
521  voldatiout(:,:) = rmiss
522  END WHERE
523  END SELECT
524 
525  ENDIF ! first time
526  ENDDO
527  IF (stat_proc == 0) THEN ! average
528  WHERE(c_e(voldatiout(:,:)))
529  voldatiout(:,:) = voldatiout(:,:)/ninp
530  END WHERE
531  ENDIF
532  ENDIF
533  CALL volgrid_set_vol_2d(that, i3, i, j, i6, voldatiout)
534  ENDDO ! level
535  ENDDO ! var
536  CALL delete(map_ttr(i,j))
537  ENDDO do_otime
538 ENDDO do_otimerange
539 
540 DEALLOCATE(map_ttr)
541 
542 
543 END SUBROUTINE volgrid6d_compute_stat_proc_agg
544 
545 
570 SUBROUTINE volgrid6d_recompute_stat_proc_diff(this, that, stat_proc, step, full_steps, start, clone)
571 TYPE(volgrid6d),INTENT(inout) :: this
572 type(volgrid6d),INTENT(out) :: that
573 INTEGER,INTENT(in) :: stat_proc
574 type(timedelta),INTENT(in) :: step
575 LOGICAL,INTENT(in),OPTIONAL :: full_steps
576 type(datetime),INTENT(in),OPTIONAL :: start
577 LOGICAL,INTENT(in),OPTIONAL :: clone
578 INTEGER :: i3, i4, i6, i, j, k, l, nitr, steps
579 INTEGER,ALLOCATABLE :: map_tr(:,:,:,:,:), f(:), keep_tr(:,:,:)
580 REAL,POINTER :: voldatiin1(:,:), voldatiin2(:,:), voldatiout(:,:)
581 !LOGICAL,POINTER :: mask_timerange(:)
582 LOGICAL :: lclone
583 TYPE(vol7d_var),ALLOCATABLE :: varbufr(:)
584 
585 
586 ! be safe
587 CALL volgrid6d_alloc_vol(this)
588 ! when volume is not decoded it is better to clone anyway to avoid
589 ! overwriting fields
590 lclone = optio_log(clone) .OR. .NOT.ASSOCIATED(this%voldati)
591 ! initialise the output volume
592 CALL init(that, griddim=this%griddim, time_definition=this%time_definition)
593 CALL volgrid6d_alloc(that, dim=this%griddim%dim, &
594  nlevel=SIZE(this%level), nvar=SIZE(this%var), ini=.false.)
595 that%level = this%level
596 that%var = this%var
597 
598 ! compute length of cumulation step in seconds
599 CALL getval(step, asec=steps)
600 
601 ! compute the statistical processing relations, output time and
602 ! timerange are defined here
603 CALL recompute_stat_proc_diff_common(this%time, this%timerange, stat_proc, step, &
604  that%time, that%timerange, map_tr, f, keep_tr, &
605  this%time_definition, full_steps, start)
606 nitr = SIZE(f)
607 
608 ! complete the definition of the output volume
609 CALL volgrid6d_alloc_vol(that, decode=ASSOCIATED(this%voldati))
610 ! allocate workspace once
611 IF (.NOT.ASSOCIATED(that%voldati)) THEN
612  ALLOCATE(voldatiin1(this%griddim%dim%nx, this%griddim%dim%ny), &
613  voldatiin2(this%griddim%dim%nx, this%griddim%dim%ny), &
614  voldatiout(this%griddim%dim%nx, this%griddim%dim%ny))
615 ENDIF
616 
617 ! copy the timeranges already satisfying the requested step, if any
618 DO i4 = 1, SIZE(this%time)
619  DO i = 1, nitr
620  IF (c_e(keep_tr(i, i4, 2))) THEN
621  l = keep_tr(i, i4, 1)
622  k = keep_tr(i, i4, 2)
623 #ifdef DEBUG
624  CALL l4f_category_log(this%category, l4f_debug, &
625  'volgrid6d_recompute_stat_proc_diff, good timerange: '//t2c(f(i))// &
626  '->'//t2c(k))
627 #endif
628  DO i6 = 1, SIZE(this%var)
629  DO i3 = 1, SIZE(this%level)
630  IF (c_e(this%gaid(i3,i4,f(i),i6))) THEN
631  IF (lclone) THEN
632  CALL copy(this%gaid(i3,i4,f(i),i6), that%gaid(i3,l,k,i6))
633  ELSE
634  that%gaid(i3,l,k,i6) = this%gaid(i3,i4,f(i),i6)
635  ENDIF
636  IF (ASSOCIATED(that%voldati)) THEN
637  that%voldati(:,:,i3,l,k,i6) = this%voldati(:,:,i3,i4,f(i),i6)
638  ELSE
639  CALL volgrid_get_vol_2d(this, i3, i4, f(i), i6, voldatiout)
640  CALL volgrid_set_vol_2d(that, i3, l, k, i6, voldatiout)
641  ENDIF
642  ENDIF
643  ENDDO
644  ENDDO
645  ENDIF
646  ENDDO
647 ENDDO
648 
649 ! varbufr required for setting posdef, optimize with an array
650 ALLOCATE(varbufr(SIZE(this%var)))
651 DO i6 = 1, SIZE(this%var)
652  varbufr(i6) = convert(this%var(i6))
653 ENDDO
654 ! compute statistical processing
655 DO l = 1, SIZE(this%time)
656  DO k = 1, nitr
657  DO j = 1, SIZE(this%time)
658  DO i = 1, nitr
659  IF (c_e(map_tr(i,j,k,l,1))) THEN
660  DO i6 = 1, SIZE(this%var)
661  DO i3 = 1, SIZE(this%level)
662 
663  IF (c_e(this%gaid(i3,j,f(i),i6)) .AND. &
664  c_e(this%gaid(i3,l,f(k),i6))) THEN
665 ! take the gaid from the second time/timerange contributing to the
666 ! result (l,f(k))
667  IF (lclone) THEN
668  CALL copy(this%gaid(i3,l,f(k),i6), &
669  that%gaid(i3,map_tr(i,j,k,l,1),map_tr(i,j,k,l,2),i6))
670  ELSE
671  that%gaid(i3,map_tr(i,j,k,l,1),map_tr(i,j,k,l,2),i6) = &
672  this%gaid(i3,l,f(k),i6)
673  ENDIF
674 
675 ! get/set 2d sections API is used
676  CALL volgrid_get_vol_2d(this, i3, l, f(k), i6, voldatiin1)
677  CALL volgrid_get_vol_2d(this, i3, j, f(i), i6, voldatiin2)
678  IF (ASSOCIATED(that%voldati)) &
679  CALL volgrid_get_vol_2d(that, i3, &
680  map_tr(i,j,k,l,1), map_tr(i,j,k,l,2), i6, voldatiout)
681 
682  IF (stat_proc == 0) THEN ! average
683  WHERE(c_e(voldatiin1(:,:)) .AND. c_e(voldatiin2(:,:)))
684  voldatiout(:,:) = &
685  (voldatiin1(:,:)*this%timerange(f(k))%p2 - &
686  voldatiin2(:,:)*this%timerange(f(i))%p2)/ &
687  steps
688  ELSEWHERE
689  voldatiout(:,:) = rmiss
690  END WHERE
691  ELSE IF (stat_proc == 1 .OR. stat_proc == 4) THEN ! acc, diff
692  WHERE(c_e(voldatiin1(:,:)) .AND. c_e(voldatiin2(:,:)))
693  voldatiout(:,:) = voldatiin1(:,:) - voldatiin2(:,:)
694  ELSEWHERE
695  voldatiout(:,:) = rmiss
696  END WHERE
697  IF (stat_proc == 1) THEN
698  CALL vol7d_var_features_posdef_apply(varbufr(i6), voldatiout)
699  ENDIF
700  ENDIF
701 
702  CALL volgrid_set_vol_2d(that, i3, &
703  map_tr(i,j,k,l,1), map_tr(i,j,k,l,2), i6, voldatiout)
704 
705  ENDIF
706  ENDDO
707  ENDDO
708  ENDIF
709  ENDDO
710  ENDDO
711  ENDDO
712 ENDDO
713 
714 IF (.NOT.ASSOCIATED(that%voldati)) THEN
715  DEALLOCATE(voldatiin1, voldatiin2, voldatiout)
716 ENDIF
717 
718 END SUBROUTINE volgrid6d_recompute_stat_proc_diff
719 
720 
748 SUBROUTINE volgrid6d_compute_stat_proc_metamorph(this, that, stat_proc_input, stat_proc, clone)
749 TYPE(volgrid6d),INTENT(inout) :: this
750 type(volgrid6d),INTENT(out) :: that
751 INTEGER,INTENT(in) :: stat_proc_input
752 INTEGER,INTENT(in) :: stat_proc
753 LOGICAL , INTENT(in),OPTIONAL :: clone
754 
755 INTEGER :: j, i3, i4, i6
756 INTEGER,POINTER :: map_tr(:)
757 REAL,POINTER :: voldatiin(:,:), voldatiout(:,:)
758 REAL,ALLOCATABLE :: int_ratio(:)
759 LOGICAL :: lclone
760 
761 nullify(voldatiin, voldatiout)
762 
763 ! be safe
764 CALL volgrid6d_alloc_vol(this)
765 ! when volume is not decoded it is better to clone anyway to avoid
766 ! overwriting fields
767 lclone = optio_log(clone) .OR. .NOT.ASSOCIATED(this%voldati)
768 
769 IF (.NOT.((stat_proc_input == 0 .AND. stat_proc == 1) .OR. &
770  (stat_proc_input == 1 .AND. stat_proc == 0))) THEN
771 
772  CALL l4f_category_log(this%category, l4f_warn, &
773  'compute_stat_proc_metamorph, can only be applied to average->accumulated timerange and viceversa')
774 ! return an empty volume, without signaling error
775  CALL init(that)
776  CALL volgrid6d_alloc_vol(that)
777  RETURN
778 ENDIF
779 
780 ! initialise the output volume
781 CALL init(that, griddim=this%griddim, time_definition=this%time_definition)
782 CALL volgrid6d_alloc(that, dim=this%griddim%dim, ntime=SIZE(this%time), &
783  nlevel=SIZE(this%level), nvar=SIZE(this%var), ini=.false.)
784 that%time = this%time
785 that%level = this%level
786 that%var = this%var
787 
788 CALL compute_stat_proc_metamorph_common(stat_proc_input, this%timerange, stat_proc, &
789  that%timerange, map_tr)
790 
791 ! complete the definition of the output volume
792 CALL volgrid6d_alloc_vol(that, decode=ASSOCIATED(this%voldati))
793 
794 IF (stat_proc == 0) THEN ! average -> integral
795  int_ratio = 1./REAL(that%timerange(:)%p2)
796 ELSE ! cumulation
797  int_ratio = REAL(that%timerange(:)%p2)
798 ENDIF
799 
800 DO i6 = 1, SIZE(this%var)
801  DO j = 1, SIZE(map_tr)
802  DO i4 = 1, SIZE(that%time)
803  DO i3 = 1, SIZE(this%level)
804 
805  IF (lclone) THEN
806  CALL copy(this%gaid(i3,i4,map_tr(j),i6), that%gaid(i3,i4,j,i6))
807  ELSE
808  that%gaid(i3,i4,map_tr(j),i6) = this%gaid(i3,i4,j,i6)
809  ENDIF
810  CALL volgrid_get_vol_2d(this, i3, i4, map_tr(j), i6, voldatiin)
811  CALL volgrid_get_vol_2d(that, i3, i4, j, i6, voldatiout)
812  WHERE (c_e(voldatiin))
813  voldatiout = voldatiin*int_ratio(j)
814  ELSEWHERE
815  voldatiout = rmiss
816  END WHERE
817  CALL volgrid_set_vol_2d(that, i3, i4, j, i6, voldatiout)
818  ENDDO
819  ENDDO
820  ENDDO
821 ENDDO
822 
823 
824 END SUBROUTINE volgrid6d_compute_stat_proc_metamorph
825 
840 SUBROUTINE volgrid6d_compute_vert_coord_var(this, level, volgrid_lev)
841 TYPE(volgrid6d),INTENT(in) :: this
842 type(vol7d_level),INTENT(in) :: level
843 type(volgrid6d),INTENT(out) :: volgrid_lev
844 
845 INTEGER :: nlev, i, ii, iii, iiii
846 TYPE(grid_id) :: out_gaid
847 LOGICAL,ALLOCATABLE :: levmask(:)
848 TYPE(volgrid6d_var) :: lev_var
849 
850 CALL init(volgrid_lev) ! initialise to null
851 IF (.NOT.ASSOCIATED(this%gaid)) THEN
852  CALL l4f_log(l4f_error, 'volgrid6d_compute_vert_coord_var: input volume not allocated')
853  RETURN
854 ENDIF
855 ! if layer, both surfaces must be of the same type
856 IF (c_e(level%level2) .AND. level%level1 /= level%level2) THEN
857  CALL l4f_log(l4f_error, 'volgrid6d_compute_vert_coord_var: requested (mixed) layer type not valid')
858  RETURN
859 ENDIF
860 
861 ! look for valid levels to be converted to vars
862 ALLOCATE(levmask(SIZE(this%level)))
863 levmask = this%level%level1 == level%level1 .AND. &
864  this%level%level2 == level%level2 .AND. c_e(this%level%l1)
865 IF (c_e(level%level2)) levmask = levmask .AND. c_e(this%level%l2)
866 nlev = count(levmask)
867 IF (nlev == 0) THEN
868  CALL l4f_log(l4f_error, 'volgrid6d_compute_vert_coord_var: requested level type not available')
869  RETURN
870 ENDIF
871 
872 out_gaid = grid_id_new()
873 gaidloop: DO i=1 ,SIZE(this%gaid,1)
874  DO ii=1 ,SIZE(this%gaid,2)
875  DO iii=1 ,SIZE(this%gaid,3)
876  DO iiii=1 ,SIZE(this%gaid,4)
877  IF (c_e(this%gaid(i,ii,iii,iiii))) THEN ! conserve first valid gaid
878  CALL copy(this%gaid(i,ii,iii,iiii), out_gaid)
879  EXIT gaidloop
880  ENDIF
881  ENDDO
882  ENDDO
883  ENDDO
884 ENDDO gaidloop
885 
886 ! look for variable corresponding to level
887 lev_var = convert(vol7d_var_new(btable=vol7d_level_to_var(level)), &
888  grid_id_template=out_gaid)
889 IF (.NOT.c_e(lev_var)) THEN
890  CALL l4f_log(l4f_error, 'volgrid6d_compute_vert_coord_var: no variable corresponds to requested level type')
891  RETURN
892 ENDIF
893 
894 ! prepare output volume
895 CALL init(volgrid_lev, griddim=this%griddim, &
896  time_definition=this%time_definition) !, categoryappend=categoryappend)
897 CALL volgrid6d_alloc(volgrid_lev, ntime=SIZE(this%time), nlevel=nlev, &
898  ntimerange=SIZE(this%timerange), nvar=1)
899 ! fill metadata
900 volgrid_lev%time = this%time
901 volgrid_lev%level = pack(this%level, mask=levmask)
902 volgrid_lev%timerange = this%timerange
903 volgrid_lev%var(1) = lev_var
904 
905 CALL volgrid6d_alloc_vol(volgrid_lev, decode=.true.)
906 ! fill data
907 DO i = 1, nlev
908  IF (c_e(level%level2)) THEN
909  volgrid_lev%voldati(:,:,i,:,:,:) = REAL(volgrid_lev%level(i)%l1 + &
910  volgrid_lev%level(i)%l2)* &
911  vol7d_level_to_var_factor(volgrid_lev%level(i))/2.
912  ELSE
913  volgrid_lev%voldati(:,:,i,:,:,:) = REAL(volgrid_lev%level(i)%l1)* &
914  vol7d_level_to_var_factor(volgrid_lev%level(i))
915  ENDIF
916 ENDDO
917 ! fill gaid for subsequent export
918 IF (c_e(out_gaid)) THEN
919  DO i=1 ,SIZE(volgrid_lev%gaid,1)
920  DO ii=1 ,SIZE(volgrid_lev%gaid,2)
921  DO iii=1 ,SIZE(volgrid_lev%gaid,3)
922  DO iiii=1 ,SIZE(volgrid_lev%gaid,4)
923  CALL copy(out_gaid, volgrid_lev%gaid(i,ii,iii,iiii))
924  ENDDO
925  ENDDO
926  ENDDO
927  ENDDO
928  CALL delete(out_gaid)
929 ENDIF
930 
931 END SUBROUTINE volgrid6d_compute_vert_coord_var
932 
Classi per la gestione delle coordinate temporali.
Functions that return a trimmed CHARACTER representation of the input variable.
Derived type associated to a block/message/record/band of gridded data coming from a file-like object...
Definition of a physical variable in grib coding style.
This module defines an abstract interface to different drivers for access to files containing gridded...
Object describing a rectangular, homogeneous gridded dataset.
Apply the conversion function this to values.
Return the conversion factor for multiplying the level value when converting to variable.
Convert a level type to a physical variable.
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.
Class for managing physical variables in a grib 1/2 fashion.
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.
Definisce una variabile meteorologica osservata o un suo attributo.
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.