106 SUBROUTINE vol7d_compute_stat_proc(this, that, stat_proc_input, stat_proc, &
107 step, start, full_steps, frac_valid, max_step, weighted, other)
108 TYPE(vol7d),
INTENT(inout) :: this
109 TYPE(vol7d),
INTENT(out) :: that
110 INTEGER,
INTENT(in) :: stat_proc_input
111 INTEGER,
INTENT(in) :: stat_proc
112 TYPE(timedelta),
INTENT(in) :: step
113 TYPE(datetime),
INTENT(in),
OPTIONAL :: start
114 LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
115 REAL,
INTENT(in),
OPTIONAL :: frac_valid
116 TYPE(timedelta),
INTENT(in),
OPTIONAL :: max_step
117 LOGICAL,
INTENT(in),
OPTIONAL :: weighted
118 TYPE(vol7d),
INTENT(inout),
OPTIONAL :: other
120 TYPE(vol7d) :: that1, that2, other1
123 IF (stat_proc_input == 254)
THEN
124 CALL l4f_log(l4f_info,
'computing statistical processing by aggregation '//&
127 CALL vol7d_compute_stat_proc_agg(this, that, stat_proc, &
128 step, start, full_steps, max_step, weighted, other)
130 ELSE IF (stat_proc == 254)
THEN
131 CALL l4f_log(l4f_info, &
132 'computing instantaneous data from statistically processed '//&
136 CALL getval(step, asec=steps)
138 IF (any(this%timerange(:)%p2 == steps))
THEN
139 CALL vol7d_decompute_stat_proc(this, that, step, other, stat_proc_input)
141 IF (any(this%timerange(:)%p2 == steps/2))
THEN
143 CALL vol7d_recompute_stat_proc_agg(this, that1, stat_proc_input, &
144 step, full_steps=.false., frac_valid=1.0)
145 CALL vol7d_recompute_stat_proc_agg(this, that2, stat_proc_input, &
146 step, start=that1%time(1)+step/2, full_steps=.false., frac_valid=1.0)
148 CALL vol7d_append(that1, that2,
sort=.true., lanasimple=.true.)
150 CALL vol7d_decompute_stat_proc(that1, that, step, other, stat_proc_input)
158 ELSE IF (stat_proc_input == stat_proc .OR. &
159 (stat_proc == 0 .OR. stat_proc == 2 .OR. stat_proc == 3))
THEN
161 CALL l4f_log(l4f_info, &
162 'recomputing statistically processed data by aggregation and difference '//&
165 IF (
PRESENT(other))
THEN
166 CALL vol7d_recompute_stat_proc_agg(this, that1, stat_proc, &
167 step, start, full_steps, frac_valid, &
168 other=other, stat_proc_input=stat_proc_input)
169 CALL vol7d_recompute_stat_proc_diff(this, that2, stat_proc, &
170 step, full_steps, start, other=other1)
171 CALL vol7d_merge(other, other1,
sort=.true.)
173 CALL vol7d_recompute_stat_proc_agg(this, that1, stat_proc, &
174 step, start, full_steps, frac_valid, stat_proc_input=stat_proc_input)
175 CALL vol7d_recompute_stat_proc_diff(this, that2, stat_proc, step, full_steps, &
179 CALL vol7d_merge(that1, that2,
sort=.true., bestdata=.true.)
183 IF ((stat_proc_input == 0 .AND. stat_proc == 1) .OR. &
184 (stat_proc_input == 1 .AND. stat_proc == 0))
THEN
185 CALL l4f_log(l4f_info, &
186 'computing statistically processed data by integration/differentiation '// &
187 t2c(stat_proc_input)//
':'//
t2c(stat_proc))
188 CALL vol7d_compute_stat_proc_metamorph(this, that, stat_proc_input, &
191 CALL l4f_log(l4f_error, &
192 'statistical processing '//
t2c(stat_proc_input)//
':'//
t2c(stat_proc)// &
193 ' not implemented or does not make sense')
198 END SUBROUTINE vol7d_compute_stat_proc
246 SUBROUTINE vol7d_recompute_stat_proc_agg(this, that, stat_proc, &
247 step, start, full_steps, frac_valid, other, stat_proc_input)
248 TYPE(vol7d),
INTENT(inout) :: this
249 TYPE(vol7d),
INTENT(out) :: that
250 INTEGER,
INTENT(in) :: stat_proc
251 TYPE(timedelta),
INTENT(in) :: step
252 TYPE(datetime),
INTENT(in),
OPTIONAL :: start
253 LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
254 REAL,
INTENT(in),
OPTIONAL :: frac_valid
255 TYPE(vol7d),
INTENT(inout),
OPTIONAL :: other
256 INTEGER,
INTENT(in),
OPTIONAL :: stat_proc_input
259 INTEGER :: i, j, n, n1, ndtr, i1, i3, i5, i6
260 INTEGER :: linshape(1)
261 REAL :: lfrac_valid, frac_c, frac_m
262 LOGICAL,
ALLOCATABLE :: ttr_mask(:,:)
263 TYPE(arrayof_ttr_mapper),
POINTER :: map_ttr(:,:)
264 INTEGER,
POINTER :: dtratio(:)
267 IF (
PRESENT(stat_proc_input))
THEN
268 tri = stat_proc_input
272 IF (
PRESENT(frac_valid))
THEN
273 lfrac_valid = frac_valid
279 CALL vol7d_alloc_vol(this)
283 CALL vol7d_smart_sort(this, lsort_time=.true.)
284 CALL vol7d_reform(this, miss=.false.,
sort=.false., unique=.true.)
286 CALL init(that, time_definition=this%time_definition)
287 CALL vol7d_alloc(that, nana=
SIZE(this%ana), nlevel=
SIZE(this%level), &
288 nnetwork=
SIZE(this%network))
289 IF (
ASSOCIATED(this%dativar%r))
THEN
290 CALL vol7d_alloc(that, ndativarr=
SIZE(this%dativar%r))
291 that%dativar%r = this%dativar%r
293 IF (
ASSOCIATED(this%dativar%d))
THEN
294 CALL vol7d_alloc(that, ndativard=
SIZE(this%dativar%d))
295 that%dativar%d = this%dativar%d
298 that%level = this%level
299 that%network = this%network
302 CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
303 step, this%time_definition, that%time, that%timerange, map_ttr, dtratio, &
305 CALL vol7d_alloc_vol(that)
307 ALLOCATE(ttr_mask(
SIZE(this%time),
SIZE(this%timerange)))
308 linshape = (/
SIZE(ttr_mask)/)
310 IF (
ASSOCIATED(this%voldatir))
THEN
311 DO j = 1,
SIZE(that%timerange)
312 DO i = 1,
SIZE(that%time)
314 DO i1 = 1,
SIZE(this%ana)
315 DO i3 = 1,
SIZE(this%level)
316 DO i6 = 1,
SIZE(this%network)
317 DO i5 = 1,
SIZE(this%dativar%r)
320 DO n1 =
SIZE(dtratio), 1, -1
321 IF (dtratio(n1) <= 0) cycle
323 DO n = 1, map_ttr(i,j)%arraysize
324 IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1))
THEN
325 IF (
c_e(this%voldatir(i1,map_ttr(i,j)%array(n)%it,i3, &
326 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
327 ttr_mask(map_ttr(i,j)%array(n)%it, &
328 map_ttr(i,j)%array(n)%itr) = .true.
333 ndtr = count(ttr_mask)
334 frac_c = real(ndtr)/real(dtratio(n1))
336 IF (ndtr > 0 .AND. frac_c >= max(lfrac_valid, frac_m))
THEN
338 SELECT CASE(stat_proc)
340 that%voldatir(i1,i,i3,j,i5,i6) = &
341 sum(this%voldatir(i1,:,i3,:,i5,i6), &
344 that%voldatir(i1,i,i3,j,i5,i6) = &
345 sum(this%voldatir(i1,:,i3,:,i5,i6), &
348 that%voldatir(i1,i,i3,j,i5,i6) = &
349 maxval(this%voldatir(i1,:,i3,:,i5,i6), &
352 that%voldatir(i1,i,i3,j,i5,i6) = &
353 minval(this%voldatir(i1,:,i3,:,i5,i6), &
356 that%voldatir(i1,i,i3,j,i5,i6) = &
358 reshape(this%voldatir(i1,:,i3,:,i5,i6), shape=linshape), &
359 mask=reshape(ttr_mask, shape=linshape))
373 IF (
ASSOCIATED(this%voldatid))
THEN
374 DO j = 1,
SIZE(that%timerange)
375 DO i = 1,
SIZE(that%time)
377 DO i1 = 1,
SIZE(this%ana)
378 DO i3 = 1,
SIZE(this%level)
379 DO i6 = 1,
SIZE(this%network)
380 DO i5 = 1,
SIZE(this%dativar%d)
383 DO n1 =
SIZE(dtratio), 1, -1
384 IF (dtratio(n1) <= 0) cycle
386 DO n = 1, map_ttr(i,j)%arraysize
387 IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1))
THEN
388 IF (
c_e(this%voldatid(i1,map_ttr(i,j)%array(n)%it,i3, &
389 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
390 ttr_mask(map_ttr(i,j)%array(n)%it, &
391 map_ttr(i,j)%array(n)%itr) = .true.
396 ndtr = count(ttr_mask)
397 frac_c = real(ndtr)/real(dtratio(n1))
399 IF (ndtr > 0 .AND. frac_c >= max(lfrac_valid, frac_m))
THEN
401 SELECT CASE(stat_proc)
403 that%voldatid(i1,i,i3,j,i5,i6) = &
404 sum(this%voldatid(i1,:,i3,:,i5,i6), &
407 that%voldatid(i1,i,i3,j,i5,i6) = &
408 sum(this%voldatid(i1,:,i3,:,i5,i6), &
411 that%voldatid(i1,i,i3,j,i5,i6) = &
412 maxval(this%voldatid(i1,:,i3,:,i5,i6), &
415 that%voldatid(i1,i,i3,j,i5,i6) = &
416 minval(this%voldatid(i1,:,i3,:,i5,i6), &
419 that%voldatid(i1,i,i3,j,i5,i6) = &
421 reshape(this%voldatid(i1,:,i3,:,i5,i6), shape=linshape), &
422 mask=reshape(ttr_mask, shape=linshape))
442 SUBROUTINE makeother()
443 IF (
PRESENT(other))
THEN
444 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
445 ltimerange=(this%timerange(:)%timerange /= tri .OR. this%timerange(:)%p2 == imiss &
446 .OR. this%timerange(:)%p2 == 0))
448 END SUBROUTINE makeother
450 END SUBROUTINE vol7d_recompute_stat_proc_agg
484 SUBROUTINE vol7d_compute_stat_proc_agg(this, that, stat_proc, &
485 step, start, full_steps, max_step, weighted, other)
486 TYPE(
vol7d),
INTENT(inout) :: this
487 TYPE(
vol7d),
INTENT(out) :: that
488 INTEGER,
INTENT(in) :: stat_proc
490 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
491 LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
492 TYPE(
timedelta),
INTENT(in),
OPTIONAL :: max_step
493 LOGICAL,
INTENT(in),
OPTIONAL :: weighted
494 TYPE(
vol7d),
INTENT(inout),
OPTIONAL :: other
497 TYPE(
vol7d) :: v7dtmp
499 INTEGER :: i, j, n, ninp, ndtr, i1, i3, i5, i6, vartype, maxsize
500 TYPE(
timedelta) :: lmax_step, act_max_step
501 TYPE(
datetime) :: pstart, pend, reftime
503 REAL,
ALLOCATABLE :: tmpvolr(:)
504 DOUBLE PRECISION,
ALLOCATABLE :: tmpvold(:), weights(:)
505 LOGICAL,
ALLOCATABLE :: lin_mask(:)
507 CHARACTER(len=8) :: env_var
509 IF (
PRESENT(max_step))
THEN
512 lmax_step = timedelta_max
514 lweighted = optio_log(weighted)
518 CALL getenv(
'LIBSIM_CLIMAT_BEHAVIOR', env_var)
519 lweighted = lweighted .AND. len_trim(env_var) == 0
521 lweighted = lweighted .AND. stat_proc == 0
524 CALL vol7d_alloc_vol(this)
528 CALL vol7d_smart_sort(this, lsort_time=.true.)
529 CALL vol7d_reform(this, miss=.false.,
sort=.false., unique=.true.)
531 CALL vol7d_copy(this, v7dtmp, ltime=(/.false./), ltimerange=(/.false./))
534 CALL init(that, time_definition=this%time_definition)
536 CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
537 step, this%time_definition, that%time, that%timerange, map_ttr, start=start, &
538 full_steps=full_steps)
540 CALL vol7d_merge(that, v7dtmp)
542 maxsize = maxval(map_ttr(:,:)%arraysize)
543 ALLOCATE(tmpvolr(maxsize), tmpvold(maxsize), lin_mask(maxsize), weights(maxsize))
544 do_otimerange:
DO j = 1,
SIZE(that%timerange)
545 do_otime:
DO i = 1,
SIZE(that%time)
546 ninp = map_ttr(i,j)%arraysize
547 IF (ninp <= 0) cycle do_otime
549 CALL time_timerange_get_period(that%time(i), that%timerange(j), &
550 that%time_definition, pstart, pend, reftime)
552 IF (
ASSOCIATED(this%voldatir))
THEN
553 DO i1 = 1,
SIZE(this%ana)
554 DO i3 = 1,
SIZE(this%level)
555 DO i6 = 1,
SIZE(this%network)
556 DO i5 = 1,
SIZE(this%dativar%r)
558 IF (stat_proc == 4)
THEN
560 IF (map_ttr(i,j)%array(1)%extra_info == 1 .AND. &
561 map_ttr(i,j)%array(ninp)%extra_info == 2)
THEN
562 IF (
c_e(this%voldatir(i1,map_ttr(i,j)%array(1)%it,i3, &
563 map_ttr(i,j)%array(1)%itr,i5,i6)) .AND. &
564 c_e(this%voldatir(i1,map_ttr(i,j)%array(ninp)%it,i3, &
565 map_ttr(i,j)%array(ninp)%itr,i5,i6)))
THEN
566 that%voldatir(i1,i,i3,j,i5,i6) = &
567 this%voldatir(i1,map_ttr(i,j)%array(ninp)%it,i3, &
568 map_ttr(i,j)%array(ninp)%itr,i5,i6) - &
569 this%voldatir(i1,map_ttr(i,j)%array(1)%it,i3, &
570 map_ttr(i,j)%array(1)%itr,i5,i6)
577 vartype = vol7d_vartype(this%dativar%r(i5))
581 IF (
c_e(this%voldatir(i1,map_ttr(i,j)%array(n)%it,i3, &
582 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
584 tmpvolr(ndtr) = this%voldatir(i1,map_ttr(i,j)%array(n)%it,i3, &
585 map_ttr(i,j)%array(n)%itr,i5,i6)
591 CALL compute_stat_proc_agg_sw(map_ttr(i,j)%array(1:ninp)%time, &
592 pstart, pend, lin_mask(1:ninp), act_max_step, weights)
594 CALL compute_stat_proc_agg_sw(map_ttr(i,j)%array(1:ninp)%time, &
595 pstart, pend, lin_mask(1:ninp), act_max_step)
597 IF (act_max_step > lmax_step) cycle
599 SELECT CASE(stat_proc)
602 that%voldatir(i1,i,i3,j,i5,i6) = &
603 sum(real(weights(1:ndtr))*tmpvolr(1:ndtr))
605 that%voldatir(i1,i,i3,j,i5,i6) = &
606 sum(tmpvolr(1:ndtr))/ndtr
609 that%voldatir(i1,i,i3,j,i5,i6) = &
610 maxval(tmpvolr(1:ndtr))
612 that%voldatir(i1,i,i3,j,i5,i6) = &
613 minval(tmpvolr(1:ndtr))
615 that%voldatir(i1,i,i3,j,i5,i6) = &
619 IF (vartype == var_dir360)
THEN
622 WHERE (tmpvolr(1:ndtr) == 0.0)
623 tmpvolr(1:ndtr) = rmiss
624 ELSE WHERE (tmpvolr(1:ndtr) < 22.5 .AND. tmpvolr(1:ndtr) > 0.0)
625 tmpvolr(1:ndtr) = tmpvolr(1:ndtr) + 360.
627 that%voldatir(i1,i,i3,j,i5,i6) = &
638 IF (
ASSOCIATED(this%voldatid))
THEN
639 DO i1 = 1,
SIZE(this%ana)
640 DO i3 = 1,
SIZE(this%level)
641 DO i6 = 1,
SIZE(this%network)
642 DO i5 = 1,
SIZE(this%dativar%d)
644 IF (stat_proc == 4)
THEN
646 IF (map_ttr(i,j)%array(1)%extra_info == 1 .AND. &
647 map_ttr(i,j)%array(ninp)%extra_info == 2)
THEN
648 IF (
c_e(this%voldatid(i1,map_ttr(i,j)%array(1)%it,i3, &
649 map_ttr(i,j)%array(1)%itr,i5,i6)) .AND. &
650 c_e(this%voldatid(i1,map_ttr(i,j)%array(ninp)%it,i3, &
651 map_ttr(i,j)%array(ninp)%itr,i5,i6)))
THEN
652 that%voldatid(i1,i,i3,j,i5,i6) = &
653 this%voldatid(i1,map_ttr(i,j)%array(ninp)%it,i3, &
654 map_ttr(i,j)%array(ninp)%itr,i5,i6) - &
655 this%voldatid(i1,map_ttr(i,j)%array(1)%it,i3, &
656 map_ttr(i,j)%array(1)%itr,i5,i6)
663 vartype = vol7d_vartype(this%dativar%d(i5))
667 IF (
c_e(this%voldatid(i1,map_ttr(i,j)%array(n)%it,i3, &
668 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
670 tmpvold(ndtr) = this%voldatid(i1,map_ttr(i,j)%array(n)%it,i3, &
671 map_ttr(i,j)%array(n)%itr,i5,i6)
677 CALL compute_stat_proc_agg_sw(map_ttr(i,j)%array(1:ninp)%time, &
678 pstart, pend, lin_mask(1:ninp), act_max_step, weights)
680 CALL compute_stat_proc_agg_sw(map_ttr(i,j)%array(1:ninp)%time, &
681 pstart, pend, lin_mask(1:ninp), act_max_step)
683 IF (act_max_step > lmax_step) cycle
685 SELECT CASE(stat_proc)
688 that%voldatid(i1,i,i3,j,i5,i6) = &
689 sum(real(weights(1:ndtr))*tmpvold(1:ndtr))
691 that%voldatid(i1,i,i3,j,i5,i6) = &
692 sum(tmpvold(1:ndtr))/ndtr
695 that%voldatid(i1,i,i3,j,i5,i6) = &
696 maxval(tmpvold(1:ndtr))
698 that%voldatid(i1,i,i3,j,i5,i6) = &
699 minval(tmpvold(1:ndtr))
701 that%voldatid(i1,i,i3,j,i5,i6) = &
705 IF (vartype == var_dir360)
THEN
708 WHERE (tmpvold(1:ndtr) == 0.0d0)
709 tmpvold(1:ndtr) = dmiss
710 ELSE WHERE (tmpvold(1:ndtr) < 22.5d0 .AND. tmpvold(1:ndtr) > 0.0d0)
711 tmpvold(1:ndtr) = tmpvold(1:ndtr) + 360.0d0
713 that%voldatid(i1,i,i3,j,i5,i6) = &
729 DEALLOCATE(tmpvolr, tmpvold, lin_mask, weights)
731 IF (
PRESENT(other))
THEN
732 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
733 ltimerange=(this%timerange(:)%timerange /= tri))
736 END SUBROUTINE vol7d_compute_stat_proc_agg
754 SUBROUTINE vol7d_decompute_stat_proc(this, that, step, other, stat_proc_input)
755 TYPE(
vol7d),
INTENT(inout) :: this
756 TYPE(
vol7d),
INTENT(out) :: that
758 TYPE(
vol7d),
INTENT(inout),
OPTIONAL :: other
759 INTEGER,
INTENT(in),
OPTIONAL :: stat_proc_input
761 INTEGER :: i, tri, steps
764 IF (
PRESENT(stat_proc_input))
THEN
765 tri = stat_proc_input
770 CALL vol7d_alloc_vol(this)
773 CALL getval(step, asec=steps)
776 CALL vol7d_copy(this, that, miss=.false.,
sort=.false., unique=.false., &
777 ltimerange=(this%timerange(:)%timerange == tri .AND. &
778 this%timerange(:)%p1 == 0 .AND. this%timerange(:)%p2 == steps))
781 that%timerange(:)%timerange = 254
782 that%timerange(:)%p2 = 0
783 DO i = 1,
SIZE(that%time(:))
784 that%time(i) = that%time(i) - step/2
787 IF (
PRESENT(other))
THEN
788 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
789 ltimerange=(this%timerange(:)%timerange /= tri .OR. &
790 this%timerange(:)%p1 /= 0 .OR. this%timerange(:)%p2 /= steps))
793 END SUBROUTINE vol7d_decompute_stat_proc
822 SUBROUTINE vol7d_recompute_stat_proc_diff(this, that, stat_proc, step, full_steps, start, other)
823 TYPE(
vol7d),
INTENT(inout) :: this
824 TYPE(
vol7d),
INTENT(out) :: that
825 INTEGER,
INTENT(in) :: stat_proc
827 LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
828 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
829 TYPE(
vol7d),
INTENT(out),
OPTIONAL :: other
831 INTEGER :: i1, i3, i5, i6, i, j, k, l, nitr, steps
832 INTEGER,
ALLOCATABLE :: map_tr(:,:,:,:,:), f(:), keep_tr(:,:,:)
833 LOGICAL,
ALLOCATABLE :: mask_timerange(:)
834 LOGICAL,
ALLOCATABLE :: mask_time(:)
835 TYPE(
vol7d) :: v7dtmp
839 CALL vol7d_alloc_vol(this)
841 CALL init(that, time_definition=this%time_definition)
844 CALL getval(step, asec=steps)
848 CALL recompute_stat_proc_diff_common(this%time, this%timerange, stat_proc, step, &
849 that%time, that%timerange, map_tr, f, keep_tr, &
850 this%time_definition, full_steps, start)
854 CALL vol7d_alloc(that, nana=0, nlevel=0, nnetwork=0)
855 CALL vol7d_alloc_vol(that)
857 ALLOCATE(mask_time(
SIZE(this%time)), mask_timerange(
SIZE(this%timerange)))
858 DO l = 1,
SIZE(this%time)
859 mask_time(l) = any(this%time(l) == that%time(:))
861 DO l = 1,
SIZE(this%timerange)
862 mask_timerange(l) = any(this%timerange(l) == that%timerange(:))
868 CALL vol7d_copy(this, v7dtmp, miss=.false.,
sort=.false., unique=.false., &
869 ltimerange=mask_timerange(:), ltime=mask_time(:))
871 CALL vol7d_merge(that, v7dtmp, lanasimple=.true., llevelsimple=.true.)
874 IF (
ASSOCIATED(this%voldatir))
THEN
875 DO l = 1,
SIZE(this%time)
877 DO j = 1,
SIZE(this%time)
879 IF (
c_e(map_tr(i,j,k,l,1)))
THEN
880 DO i6 = 1,
SIZE(this%network)
881 DO i5 = 1,
SIZE(this%dativar%r)
882 DO i3 = 1,
SIZE(this%level)
883 DO i1 = 1,
SIZE(this%ana)
884 IF (
c_e(this%voldatir(i1,l,i3,f(k),i5,i6)) .AND. &
885 c_e(this%voldatir(i1,j,i3,f(i),i5,i6)))
THEN
887 IF (stat_proc == 0)
THEN
889 i1,map_tr(i,j,k,l,1),i3,map_tr(i,j,k,l,2),i5,i6) = &
890 (this%voldatir(i1,l,i3,f(k),i5,i6)*this%timerange(f(k))%p2 - &
891 this%voldatir(i1,j,i3,f(i),i5,i6)*this%timerange(f(i))%p2)/ &
893 ELSE IF (stat_proc == 1 .OR. stat_proc == 4)
THEN
895 i1,map_tr(i,j,k,l,1),i3,map_tr(i,j,k,l,2),i5,i6) = &
896 this%voldatir(i1,l,i3,f(k),i5,i6) - &
897 this%voldatir(i1,j,i3,f(i),i5,i6)
912 IF (
ASSOCIATED(this%voldatid))
THEN
913 DO l = 1,
SIZE(this%time)
915 DO j = 1,
SIZE(this%time)
917 IF (
c_e(map_tr(i,j,k,l,1)))
THEN
918 DO i6 = 1,
SIZE(this%network)
919 DO i5 = 1,
SIZE(this%dativar%d)
920 DO i3 = 1,
SIZE(this%level)
921 DO i1 = 1,
SIZE(this%ana)
922 IF (
c_e(this%voldatid(i1,l,i3,f(k),i5,i6)) .AND. &
923 c_e(this%voldatid(i1,j,i3,f(i),i5,i6)))
THEN
927 IF (stat_proc == 0)
THEN
929 i1,map_tr(i,j,k,l,1),i3,map_tr(i,j,k,l,2),i5,i6) = &
930 (this%voldatid(i1,l,i3,f(k),i5,i6)*this%timerange(f(k))%p2 - &
931 this%voldatid(i1,j,i3,f(i),i5,i6)*this%timerange(f(i))%p2)/ &
933 ELSE IF (stat_proc == 1 .OR. stat_proc == 4)
THEN
935 i1,map_tr(i,j,k,l,1),i3,map_tr(i,j,k,l,2),i5,i6) = &
936 this%voldatid(i1,l,i3,f(k),i5,i6) - &
937 this%voldatid(i1,j,i3,f(i),i5,i6)
956 CALL vol7d_smart_sort(that, lsort_time=.true., lsort_timerange=.true.)
958 CALL makeother(.true.)
962 SUBROUTINE makeother(filter)
963 LOGICAL,
INTENT(in) :: filter
964 IF (
PRESENT(other))
THEN
966 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
967 ltimerange=(this%timerange(:)%timerange /= stat_proc))
969 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false.)
972 END SUBROUTINE makeother
974 END SUBROUTINE vol7d_recompute_stat_proc_diff
1004 SUBROUTINE vol7d_compute_stat_proc_metamorph(this, that, stat_proc_input, stat_proc)
1005 TYPE(
vol7d),
INTENT(inout) :: this
1006 TYPE(
vol7d),
INTENT(out) :: that
1007 INTEGER,
INTENT(in) :: stat_proc_input
1008 INTEGER,
INTENT(in) :: stat_proc
1011 LOGICAL,
ALLOCATABLE :: tr_mask(:)
1012 REAL,
ALLOCATABLE :: int_ratio(:)
1013 DOUBLE PRECISION,
ALLOCATABLE :: int_ratiod(:)
1015 IF (.NOT.((stat_proc_input == 0 .AND. stat_proc == 1) .OR. &
1016 (stat_proc_input == 1 .AND. stat_proc == 0)))
THEN
1018 CALL l4f_log(l4f_warn, &
1019 'compute_stat_proc_metamorph, can only be applied to average->accumulated timerange and viceversa')
1022 CALL vol7d_alloc_vol(that)
1027 CALL vol7d_alloc_vol(this)
1030 tr_mask = this%timerange(:)%timerange == stat_proc_input .AND. this%timerange(:)%p2 /= imiss &
1031 .AND. this%timerange(:)%p2 /= 0
1034 IF (count(tr_mask) == 0)
THEN
1035 CALL l4f_log(l4f_warn, &
1036 'vol7d_compute, no timeranges suitable for statistical processing by metamorphosis')
1043 CALL vol7d_copy(this, that, ltimerange=tr_mask)
1044 that%timerange(:)%timerange = stat_proc
1046 ALLOCATE(int_ratio(
SIZE(that%timerange)), int_ratiod(
SIZE(that%timerange)))
1048 IF (stat_proc == 0)
THEN
1049 int_ratio = 1./real(that%timerange(:)%p2)
1050 int_ratiod = 1./dble(that%timerange(:)%p2)
1052 int_ratio = real(that%timerange(:)%p2)
1053 int_ratiod = dble(that%timerange(:)%p2)
1056 IF (
ASSOCIATED(that%voldatir))
THEN
1057 DO j = 1,
SIZE(that%timerange)
1058 WHERE(
c_e(that%voldatir(:,:,:,j,:,:)))
1059 that%voldatir(:,:,:,j,:,:) = that%voldatir(:,:,:,j,:,:)*int_ratio(j)
1061 that%voldatir(:,:,:,j,:,:) = rmiss
1066 IF (
ASSOCIATED(that%voldatid))
THEN
1067 DO j = 1,
SIZE(that%timerange)
1068 WHERE(
c_e(that%voldatid(:,:,:,j,:,:)))
1069 that%voldatid(:,:,:,j,:,:) = that%voldatid(:,:,:,j,:,:)*int_ratiod(j)
1071 that%voldatid(:,:,:,j,:,:) = rmiss
1077 END SUBROUTINE vol7d_compute_stat_proc_metamorph
1080 SUBROUTINE vol7d_recompute_stat_proc_agg_multiv(this, that, &
1081 step, start, frac_valid, multiv_proc)
1082 TYPE(
vol7d),
INTENT(inout) :: this
1083 TYPE(
vol7d),
INTENT(out) :: that
1086 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1087 REAL,
INTENT(in),
OPTIONAL :: frac_valid
1090 INTEGER,
INTENT(in) :: multiv_proc
1093 INTEGER :: i, j, n, n1, ndtr, i1, i3, i5, i6
1094 INTEGER :: linshape(1)
1095 REAL :: lfrac_valid, frac_c, frac_m
1096 LOGICAL,
ALLOCATABLE :: ttr_mask(:,:)
1098 INTEGER,
POINTER :: dtratio(:)
1099 INTEGER :: stat_proc_input, stat_proc
1101 SELECT CASE(multiv_proc)
1103 stat_proc_input = 205
1107 tri = stat_proc_input
1108 IF (
PRESENT(frac_valid))
THEN
1109 lfrac_valid = frac_valid
1115 CALL vol7d_alloc_vol(this)
1119 CALL vol7d_smart_sort(this, lsort_time=.true.)
1120 CALL vol7d_reform(this, miss=.false.,
sort=.false., unique=.true.)
1122 CALL init(that, time_definition=this%time_definition)
1123 CALL vol7d_alloc(that, nana=
SIZE(this%ana), nlevel=
SIZE(this%level), &
1124 nnetwork=
SIZE(this%network))
1125 IF (
ASSOCIATED(this%dativar%r))
THEN
1126 CALL vol7d_alloc(that, ndativarr=
SIZE(this%dativar%r))
1127 that%dativar%r = this%dativar%r
1129 IF (
ASSOCIATED(this%dativar%d))
THEN
1130 CALL vol7d_alloc(that, ndativard=
SIZE(this%dativar%d))
1131 that%dativar%d = this%dativar%d
1134 that%level = this%level
1135 that%network = this%network
1138 CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
1139 step, this%time_definition, that%time, that%timerange, map_ttr, &
1140 dtratio=dtratio, start=start)
1141 CALL vol7d_alloc_vol(that)
1143 ALLOCATE(ttr_mask(
SIZE(this%time),
SIZE(this%timerange)))
1144 linshape = (/
SIZE(ttr_mask)/)
1146 IF (
ASSOCIATED(this%voldatir))
THEN
1147 DO j = 1,
SIZE(that%timerange)
1148 DO i = 1,
SIZE(that%time)
1150 DO i1 = 1,
SIZE(this%ana)
1151 DO i3 = 1,
SIZE(this%level)
1152 DO i6 = 1,
SIZE(this%network)
1153 DO i5 = 1,
SIZE(this%dativar%r)
1156 DO n1 =
SIZE(dtratio), 1, -1
1157 IF (dtratio(n1) <= 0) cycle
1159 DO n = 1, map_ttr(i,j)%arraysize
1160 IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1))
THEN
1161 IF (
c_e(this%voldatir(i1,map_ttr(i,j)%array(n)%it,i3, &
1162 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
1163 ttr_mask(map_ttr(i,j)%array(n)%it, &
1164 map_ttr(i,j)%array(n)%itr) = .true.
1169 ndtr = count(ttr_mask)
1170 frac_c = real(ndtr)/real(dtratio(n1))
1172 IF (ndtr > 0 .AND. frac_c >= max(lfrac_valid, frac_m))
THEN
1174 SELECT CASE(multiv_proc)
1176 that%voldatir(i1,i,i3,j,i5,i6) = &
1177 sum(this%voldatir(i1,:,i3,:,i5,i6), &
1187 CALL delete(map_ttr(i,j))
1192 IF (
ASSOCIATED(this%voldatid))
THEN
1193 DO j = 1,
SIZE(that%timerange)
1194 DO i = 1,
SIZE(that%time)
1196 DO i1 = 1,
SIZE(this%ana)
1197 DO i3 = 1,
SIZE(this%level)
1198 DO i6 = 1,
SIZE(this%network)
1199 DO i5 = 1,
SIZE(this%dativar%d)
1202 DO n1 =
SIZE(dtratio), 1, -1
1203 IF (dtratio(n1) <= 0) cycle
1205 DO n = 1, map_ttr(i,j)%arraysize
1206 IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1))
THEN
1207 IF (
c_e(this%voldatid(i1,map_ttr(i,j)%array(n)%it,i3, &
1208 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
1209 ttr_mask(map_ttr(i,j)%array(n)%it, &
1210 map_ttr(i,j)%array(n)%itr) = .true.
1215 ndtr = count(ttr_mask)
1216 frac_c = real(ndtr)/real(dtratio(n1))
1218 IF (ndtr > 0 .AND. frac_c >= max(lfrac_valid, frac_m))
THEN
1220 SELECT CASE(stat_proc)
1222 that%voldatid(i1,i,i3,j,i5,i6) = &
1223 sum(this%voldatid(i1,:,i3,:,i5,i6), &
1226 that%voldatid(i1,i,i3,j,i5,i6) = &
1227 sum(this%voldatid(i1,:,i3,:,i5,i6), &
1230 that%voldatid(i1,i,i3,j,i5,i6) = &
1231 maxval(this%voldatid(i1,:,i3,:,i5,i6), &
1234 that%voldatid(i1,i,i3,j,i5,i6) = &
1235 minval(this%voldatid(i1,:,i3,:,i5,i6), &
1238 that%voldatid(i1,i,i3,j,i5,i6) = &
1240 reshape(this%voldatid(i1,:,i3,:,i5,i6), shape=linshape), &
1241 mask=reshape(ttr_mask, shape=linshape))
1250 CALL delete(map_ttr(i,j))
1255 DEALLOCATE(ttr_mask)
1257 END SUBROUTINE vol7d_recompute_stat_proc_agg_multiv
1275 SUBROUTINE vol7d_fill_time(this, that, step, start, stopp, cyclicdt)
1276 TYPE(
vol7d),
INTENT(inout) :: this
1277 TYPE(
vol7d),
INTENT(inout) :: that
1279 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1280 TYPE(
datetime),
INTENT(in),
OPTIONAL :: stopp
1284 TYPE(
datetime) :: counter, lstart, lstop
1285 INTEGER :: i, naddtime
1287 CALL safe_start_stop(this, lstart, lstop, start, stopp)
1288 IF (.NOT.
c_e(lstart) .OR. .NOT.
c_e(lstop) .OR. .NOT.
c_e(step))
RETURN
1290 lcyclicdt=cyclicdatetime_miss
1291 if (
present(cyclicdt))
then
1292 if(
c_e(cyclicdt)) lcyclicdt=cyclicdt
1295 CALL l4f_log(l4f_info,
'vol7d_fill_time: time interval '//trim(
to_char(lstart))// &
1303 naddcount:
DO WHILE(counter <= lstop)
1304 DO WHILE(i <=
SIZE(this%time))
1305 IF (counter < this%time(i))
THEN
1308 ELSE IF (counter == this%time(i) .OR. .NOT. counter == lcyclicdt)
THEN
1309 counter = counter + step
1314 naddtime = naddtime + 1
1315 counter = counter + step
1328 IF (naddtime > 0)
THEN
1331 CALL vol7d_alloc(that, ntime=naddtime)
1332 CALL vol7d_alloc_vol(that)
1338 naddadd:
DO WHILE(counter <= lstop)
1339 DO WHILE(i <=
SIZE(this%time))
1340 IF (counter < this%time(i))
THEN
1343 ELSE IF (counter == this%time(i) .OR. .NOT. counter == lcyclicdt)
THEN
1344 counter = counter + step
1349 naddtime = naddtime + 1
1350 that%time(naddtime) = counter
1351 counter = counter + step
1354 CALL vol7d_append(that, this,
sort=.true.)
1359 CALL vol7d_copy(this, that,
sort=.true.)
1363 END SUBROUTINE vol7d_fill_time
1377 SUBROUTINE vol7d_filter_time(this, that, step, start, stopp, cyclicdt)
1378 TYPE(
vol7d),
INTENT(inout) :: this
1379 TYPE(
vol7d),
INTENT(inout) :: that
1380 TYPE(
timedelta),
INTENT(in),
optional :: step
1381 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1382 TYPE(
datetime),
INTENT(in),
OPTIONAL :: stopp
1386 LOGICAL,
ALLOCATABLE :: time_mask(:)
1388 CALL safe_start_stop(this, lstart, lstop, start, stopp)
1389 IF (.NOT.
c_e(lstart) .OR. .NOT.
c_e(lstop))
RETURN
1391 CALL l4f_log(l4f_info,
'vol7d_filter_time: time interval '//trim(
to_char(lstart))// &
1394 ALLOCATE(time_mask(
SIZE(this%time)))
1396 time_mask = this%time >= lstart .AND. this%time <= lstop
1398 IF (
PRESENT(cyclicdt))
THEN
1399 IF (
c_e(cyclicdt))
THEN
1400 time_mask = time_mask .AND. this%time == cyclicdt
1404 IF (
PRESENT(step))
THEN
1406 time_mask = time_mask .AND.
mod(this%time - lstart, step) == timedelta_0
1410 CALL vol7d_copy(this,that, ltime=time_mask)
1412 DEALLOCATE(time_mask)
1414 END SUBROUTINE vol7d_filter_time
1420 SUBROUTINE vol7d_fill_data(this, step, start, stopp, tolerance)
1421 TYPE(
vol7d),
INTENT(inout) :: this
1423 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1424 TYPE(
datetime),
INTENT(in),
OPTIONAL :: stopp
1425 TYPE(
timedelta),
INTENT(in),
optional :: tolerance
1428 integer :: indana , indtime ,indlevel ,indtimerange ,inddativarr, indnetwork, iindtime
1429 type(
timedelta) :: deltato,deltat, ltolerance
1431 CALL safe_start_stop(this, lstart, lstop, start, stopp)
1432 IF (.NOT.
c_e(lstart) .OR. .NOT.
c_e(lstop))
RETURN
1434 CALL l4f_log(l4f_info,
'vol7d_fill_data: time interval '//trim(
to_char(lstart))// &
1440 if (
present(tolerance))
then
1441 if (
c_e(tolerance)) ltolerance=tolerance
1445 do indtime=1,
size(this%time)
1447 IF (this%time(indtime) < lstart .OR. this%time(indtime) > lstop .OR. &
1448 mod(this%time(indtime) - lstart, step) /= timedelta_0) cycle
1449 do indtimerange=1,
size(this%timerange)
1450 if (this%timerange(indtimerange)%timerange /= 254) cycle
1451 do indnetwork=1,
size(this%network)
1452 do inddativarr=1,
size(this%dativar%r)
1453 do indlevel=1,
size(this%level)
1454 do indana=1,
size(this%ana)
1457 if (.not.
c_e(this%voldatir(indana, indtime, indlevel, indtimerange, inddativarr, indnetwork)))
then
1458 deltato=timedelta_miss
1462 do iindtime=indtime+1,
size(this%time)
1464 if (
c_e(this%voldatir (indana, iindtime, indlevel, indtimerange, inddativarr, indnetwork )))
then
1465 deltat=this%time(iindtime)-this%time(indtime)
1467 if (deltat >= ltolerance)
exit
1469 if (deltat < deltato)
then
1470 this%voldatir(indana, indtime, indlevel, indtimerange, inddativarr, indnetwork) = &
1471 this%voldatir(indana, iindtime, indlevel, indtimerange, inddativarr, indnetwork)
1477 do iindtime=indtime-1,1,-1
1479 if (
c_e(this%voldatir (indana, iindtime, indlevel, indtimerange, inddativarr, indnetwork )))
then
1480 if (iindtime < indtime)
then
1481 deltat=this%time(indtime)-this%time(iindtime)
1482 else if (iindtime > indtime)
then
1483 deltat=this%time(iindtime)-this%time(indtime)
1488 if (deltat >= ltolerance)
exit
1490 if (deltat < deltato)
then
1491 this%voldatir(indana, indtime, indlevel, indtimerange, inddativarr, indnetwork) = &
1492 this%voldatir(indana, iindtime, indlevel, indtimerange, inddativarr, indnetwork)
1506 END SUBROUTINE vol7d_fill_data
1512 SUBROUTINE safe_start_stop(this, lstart, lstop, start, stopp)
1513 TYPE(
vol7d),
INTENT(inout) :: this
1514 TYPE(
datetime),
INTENT(out) :: lstart
1515 TYPE(
datetime),
INTENT(out) :: lstop
1516 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1517 TYPE(
datetime),
INTENT(in),
OPTIONAL :: stopp
1519 lstart = datetime_miss
1520 lstop = datetime_miss
1522 CALL vol7d_alloc_vol(this)
1523 IF (
SIZE(this%time) == 0)
RETURN
1524 CALL vol7d_smart_sort(this, lsort_time=.true.)
1526 IF (
PRESENT(start))
THEN
1527 IF (
c_e(start))
THEN
1530 lstart = this%time(1)
1533 lstart = this%time(1)
1535 IF (
PRESENT(stopp))
THEN
1536 IF (
c_e(stopp))
THEN
1539 lstop = this%time(
SIZE(this%time))
1542 lstop = this%time(
SIZE(this%time))
1545 END SUBROUTINE safe_start_stop
1554 SUBROUTINE vol7d_normalize_vcoord(this,that,ana,time,timerange,network)
1555 TYPE(
vol7d),
INTENT(INOUT) :: this
1556 TYPE(
vol7d),
INTENT(OUT) :: that
1557 integer,
intent(in) :: time,ana,timerange,network
1559 character(len=1) :: type
1561 TYPE(vol7d_var) :: var
1562 LOGICAL,
allocatable :: ltime(:),ltimerange(:),lana(:),lnetwork(:)
1563 logical,
allocatable :: maschera(:)
1566 allocate(ltime(
size(this%time)))
1567 allocate(ltimerange(
size(this%timerange)))
1568 allocate(lana(
size(this%ana)))
1569 allocate(lnetwork(
size(this%network)))
1577 ltimerange(timerange)=.true.
1579 lnetwork(network)=.true.
1581 call vol7d_copy(this, that,unique=.true.,&
1582 ltime=ltime,ltimerange=ltimerange,lana=lana,lnetwork=lnetwork )
1584 call init(var, btable=
"B10004")
1587 ind =
index(that%dativar, var, type=type)
1589 allocate(maschera(
size(that%level)))
1592 (that%level%level1 == 105.and.that%level%level2 == 105) .or. &
1593 (that%level%level1 == 103 .and. that%level%level2 == imiss ) .or. &
1594 (that%level%level1 == 102 .and. that%level%level2 == imiss )) &
1595 .and.
c_e(that%voldatic(1,1,:,1,ind,1))
1603 that%level%level1 = 100
1604 that%level%l1 = int(
realdat(that%voldatid(1,1,:,1,ind,1),that%dativar%d(ind)))
1605 that%level%l1 = int(that%voldatid(1,1,:,1,ind,1))
1606 that%level%level2 = imiss
1607 that%level%l2 = imiss
1613 that%level%level1 = 100
1614 that%level%l1 = int(
realdat(that%voldatir(1,1,:,1,ind,1),that%dativar%r(ind)))
1615 that%level%level2 = imiss
1616 that%level%l2 = imiss
1622 that%level%level1 = 100
1623 that%level%l1 = int(
realdat(that%voldatii(1,1,:,1,ind,1),that%dativar%i(ind)))
1624 that%level%level2 = imiss
1625 that%level%l2 = imiss
1631 that%level%level1 = 100
1632 that%level%l1 = int(
realdat(that%voldatib(1,1,:,1,ind,1),that%dativar%b(ind)))
1633 that%level%level2 = imiss
1634 that%level%l2 = imiss
1640 that%level%level1 = 100
1641 that%level%l1 = int(
realdat(that%voldatic(1,1,:,1,ind,1),that%dativar%c(ind)))
1642 that%level%level2 = imiss
1643 that%level%l2 = imiss
1649 deallocate(ltimerange)
1651 deallocate(lnetwork)
1653 END SUBROUTINE vol7d_normalize_vcoord
Distruttori per le 2 classi.
Restituiscono il valore dell'oggetto nella forma desiderata.
Costruttori per le classi datetime e timedelta.
Operatore di resto della divisione.
Functions that return a trimmed CHARACTER representation of the input variable.
Restituiscono il valore dell'oggetto in forma di stringa stampabile.
Compute the mode of the random variable provided taking into account missing data.
Compute the standard deviation of the random variable provided, taking into account missing data.
Classi per la gestione delle coordinate temporali.
Module for basic statistical computations taking into account missing data.
This module contains functions that are only for internal use of the library.
Extension of vol7d_class with methods for performing simple statistical operations on entire volumes ...
Classe per la gestione di un volume completo di dati osservati.
Class for expressing a cyclic datetime.
Class for expressing an absolute time value.
Class for expressing a relative time interval.
Derived type defining a dynamically extensible array of TYPE(ttr_mapper) elements.
Definisce un oggetto contenente i volumi anagrafica e dati e tutti i descrittori delle loro dimension...