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, 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)
178 CALL vol7d_merge(that1, that2,
sort=.true.)
182 IF ((stat_proc_input == 0 .AND. stat_proc == 1) .OR. &
183 (stat_proc_input == 1 .AND. stat_proc == 0))
THEN
184 CALL l4f_log(l4f_info, &
185 'computing statistically processed data by integration/differentiation '// &
186 t2c(stat_proc_input)//
':'//
t2c(stat_proc))
187 CALL vol7d_compute_stat_proc_metamorph(this, that, stat_proc_input, &
190 CALL l4f_log(l4f_error, &
191 'statistical processing '//
t2c(stat_proc_input)//
':'//
t2c(stat_proc)// &
192 ' not implemented or does not make sense')
197 END SUBROUTINE vol7d_compute_stat_proc
245 SUBROUTINE vol7d_recompute_stat_proc_agg(this, that, stat_proc, &
246 step, start, full_steps, frac_valid, other, stat_proc_input)
247 TYPE(vol7d),
INTENT(inout) :: this
248 TYPE(vol7d),
INTENT(out) :: that
249 INTEGER,
INTENT(in) :: stat_proc
250 TYPE(timedelta),
INTENT(in) :: step
251 TYPE(datetime),
INTENT(in),
OPTIONAL :: start
252 LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
253 REAL,
INTENT(in),
OPTIONAL :: frac_valid
254 TYPE(vol7d),
INTENT(inout),
OPTIONAL :: other
255 INTEGER,
INTENT(in),
OPTIONAL :: stat_proc_input
258 INTEGER :: i, j, n, n1, ndtr, i1, i3, i5, i6
259 INTEGER :: linshape(1)
260 REAL :: lfrac_valid, frac_c, frac_m
261 LOGICAL,
ALLOCATABLE :: ttr_mask(:,:)
262 TYPE(arrayof_ttr_mapper),
POINTER :: map_ttr(:,:)
263 INTEGER,
POINTER :: dtratio(:)
266 IF (
PRESENT(stat_proc_input))
THEN
267 tri = stat_proc_input
271 IF (
PRESENT(frac_valid))
THEN
272 lfrac_valid = frac_valid
278 CALL vol7d_alloc_vol(this)
282 CALL vol7d_smart_sort(this, lsort_time=.true.)
283 CALL vol7d_reform(this, miss=.false.,
sort=.false., unique=.true.)
285 CALL init(that, time_definition=this%time_definition)
286 CALL vol7d_alloc(that, nana=
SIZE(this%ana), nlevel=
SIZE(this%level), &
287 nnetwork=
SIZE(this%network))
288 IF (
ASSOCIATED(this%dativar%r))
THEN
289 CALL vol7d_alloc(that, ndativarr=
SIZE(this%dativar%r))
290 that%dativar%r = this%dativar%r
292 IF (
ASSOCIATED(this%dativar%d))
THEN
293 CALL vol7d_alloc(that, ndativard=
SIZE(this%dativar%d))
294 that%dativar%d = this%dativar%d
297 that%level = this%level
298 that%network = this%network
301 CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
302 step, this%time_definition, that%time, that%timerange, map_ttr, dtratio, &
304 CALL vol7d_alloc_vol(that)
306 ALLOCATE(ttr_mask(
SIZE(this%time),
SIZE(this%timerange)))
307 linshape = (/
SIZE(ttr_mask)/)
309 IF (
ASSOCIATED(this%voldatir))
THEN
310 DO j = 1,
SIZE(that%timerange)
311 DO i = 1,
SIZE(that%time)
313 DO i1 = 1,
SIZE(this%ana)
314 DO i3 = 1,
SIZE(this%level)
315 DO i6 = 1,
SIZE(this%network)
316 DO i5 = 1,
SIZE(this%dativar%r)
319 DO n1 =
SIZE(dtratio), 1, -1
320 IF (dtratio(n1) <= 0) cycle
322 DO n = 1, map_ttr(i,j)%arraysize
323 IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1))
THEN
324 IF (
c_e(this%voldatir(i1,map_ttr(i,j)%array(n)%it,i3, &
325 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
326 ttr_mask(map_ttr(i,j)%array(n)%it, &
327 map_ttr(i,j)%array(n)%itr) = .true.
332 ndtr = count(ttr_mask)
333 frac_c = real(ndtr)/real(dtratio(n1))
335 IF (ndtr > 0 .AND. frac_c >= max(lfrac_valid, frac_m))
THEN
337 SELECT CASE(stat_proc)
339 that%voldatir(i1,i,i3,j,i5,i6) = &
340 sum(this%voldatir(i1,:,i3,:,i5,i6), &
343 that%voldatir(i1,i,i3,j,i5,i6) = &
344 sum(this%voldatir(i1,:,i3,:,i5,i6), &
347 that%voldatir(i1,i,i3,j,i5,i6) = &
348 maxval(this%voldatir(i1,:,i3,:,i5,i6), &
351 that%voldatir(i1,i,i3,j,i5,i6) = &
352 minval(this%voldatir(i1,:,i3,:,i5,i6), &
355 that%voldatir(i1,i,i3,j,i5,i6) = &
357 reshape(this%voldatir(i1,:,i3,:,i5,i6), shape=linshape), &
358 mask=reshape(ttr_mask, shape=linshape))
372 IF (
ASSOCIATED(this%voldatid))
THEN
373 DO j = 1,
SIZE(that%timerange)
374 DO i = 1,
SIZE(that%time)
376 DO i1 = 1,
SIZE(this%ana)
377 DO i3 = 1,
SIZE(this%level)
378 DO i6 = 1,
SIZE(this%network)
379 DO i5 = 1,
SIZE(this%dativar%d)
382 DO n1 =
SIZE(dtratio), 1, -1
383 IF (dtratio(n1) <= 0) cycle
385 DO n = 1, map_ttr(i,j)%arraysize
386 IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1))
THEN
387 IF (
c_e(this%voldatid(i1,map_ttr(i,j)%array(n)%it,i3, &
388 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
389 ttr_mask(map_ttr(i,j)%array(n)%it, &
390 map_ttr(i,j)%array(n)%itr) = .true.
395 ndtr = count(ttr_mask)
396 frac_c = real(ndtr)/real(dtratio(n1))
398 IF (ndtr > 0 .AND. frac_c >= max(lfrac_valid, frac_m))
THEN
400 SELECT CASE(stat_proc)
402 that%voldatid(i1,i,i3,j,i5,i6) = &
403 sum(this%voldatid(i1,:,i3,:,i5,i6), &
406 that%voldatid(i1,i,i3,j,i5,i6) = &
407 sum(this%voldatid(i1,:,i3,:,i5,i6), &
410 that%voldatid(i1,i,i3,j,i5,i6) = &
411 maxval(this%voldatid(i1,:,i3,:,i5,i6), &
414 that%voldatid(i1,i,i3,j,i5,i6) = &
415 minval(this%voldatid(i1,:,i3,:,i5,i6), &
418 that%voldatid(i1,i,i3,j,i5,i6) = &
420 reshape(this%voldatid(i1,:,i3,:,i5,i6), shape=linshape), &
421 mask=reshape(ttr_mask, shape=linshape))
441 SUBROUTINE makeother()
442 IF (
PRESENT(other))
THEN
443 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
444 ltimerange=(this%timerange(:)%timerange /= tri .OR. this%timerange(:)%p2 == imiss &
445 .OR. this%timerange(:)%p2 == 0))
447 END SUBROUTINE makeother
449 END SUBROUTINE vol7d_recompute_stat_proc_agg
483 SUBROUTINE vol7d_compute_stat_proc_agg(this, that, stat_proc, &
484 step, start, full_steps, max_step, weighted, other)
485 TYPE(
vol7d),
INTENT(inout) :: this
486 TYPE(
vol7d),
INTENT(out) :: that
487 INTEGER,
INTENT(in) :: stat_proc
489 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
490 LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
491 TYPE(
timedelta),
INTENT(in),
OPTIONAL :: max_step
492 LOGICAL,
INTENT(in),
OPTIONAL :: weighted
493 TYPE(
vol7d),
INTENT(inout),
OPTIONAL :: other
496 TYPE(
vol7d) :: v7dtmp
498 INTEGER :: i, j, n, ninp, ndtr, i1, i3, i5, i6, vartype, maxsize
499 TYPE(
timedelta) :: lmax_step, act_max_step
500 TYPE(
datetime) :: pstart, pend, reftime
502 REAL,
ALLOCATABLE :: tmpvolr(:)
503 DOUBLE PRECISION,
ALLOCATABLE :: tmpvold(:), weights(:)
504 LOGICAL,
ALLOCATABLE :: lin_mask(:)
506 CHARACTER(len=8) :: env_var
508 IF (
PRESENT(max_step))
THEN
511 lmax_step = timedelta_max
513 lweighted = optio_log(weighted)
517 CALL getenv(
'LIBSIM_CLIMAT_BEHAVIOR', env_var)
518 lweighted = lweighted .AND. len_trim(env_var) == 0
520 lweighted = lweighted .AND. stat_proc == 0
523 CALL vol7d_alloc_vol(this)
527 CALL vol7d_smart_sort(this, lsort_time=.true.)
528 CALL vol7d_reform(this, miss=.false.,
sort=.false., unique=.true.)
530 CALL vol7d_copy(this, v7dtmp, ltime=(/.false./), ltimerange=(/.false./))
533 CALL init(that, time_definition=this%time_definition)
535 CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
536 step, this%time_definition, that%time, that%timerange, map_ttr, start=start, &
537 full_steps=full_steps)
539 CALL vol7d_merge(that, v7dtmp)
541 maxsize = maxval(map_ttr(:,:)%arraysize)
542 ALLOCATE(tmpvolr(maxsize), tmpvold(maxsize), lin_mask(maxsize), weights(maxsize))
543 do_otimerange:
DO j = 1,
SIZE(that%timerange)
544 do_otime:
DO i = 1,
SIZE(that%time)
545 ninp = map_ttr(i,j)%arraysize
546 IF (ninp <= 0) cycle do_otime
548 CALL time_timerange_get_period(that%time(i), that%timerange(j), &
549 that%time_definition, pstart, pend, reftime)
551 IF (
ASSOCIATED(this%voldatir))
THEN
552 DO i1 = 1,
SIZE(this%ana)
553 DO i3 = 1,
SIZE(this%level)
554 DO i6 = 1,
SIZE(this%network)
555 DO i5 = 1,
SIZE(this%dativar%r)
557 IF (stat_proc == 4)
THEN
559 IF (map_ttr(i,j)%array(1)%extra_info == 1 .AND. &
560 map_ttr(i,j)%array(ninp)%extra_info == 2)
THEN
561 IF (
c_e(this%voldatir(i1,map_ttr(i,j)%array(1)%it,i3, &
562 map_ttr(i,j)%array(1)%itr,i5,i6)) .AND. &
563 c_e(this%voldatir(i1,map_ttr(i,j)%array(ninp)%it,i3, &
564 map_ttr(i,j)%array(ninp)%itr,i5,i6)))
THEN
565 that%voldatir(i1,i,i3,j,i5,i6) = &
566 this%voldatir(i1,map_ttr(i,j)%array(ninp)%it,i3, &
567 map_ttr(i,j)%array(ninp)%itr,i5,i6) - &
568 this%voldatir(i1,map_ttr(i,j)%array(1)%it,i3, &
569 map_ttr(i,j)%array(1)%itr,i5,i6)
576 vartype = vol7d_vartype(this%dativar%r(i5))
580 IF (
c_e(this%voldatir(i1,map_ttr(i,j)%array(n)%it,i3, &
581 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
583 tmpvolr(ndtr) = this%voldatir(i1,map_ttr(i,j)%array(n)%it,i3, &
584 map_ttr(i,j)%array(n)%itr,i5,i6)
590 CALL compute_stat_proc_agg_sw(map_ttr(i,j)%array(1:ninp)%time, &
591 pstart, pend, lin_mask(1:ninp), act_max_step, weights)
593 CALL compute_stat_proc_agg_sw(map_ttr(i,j)%array(1:ninp)%time, &
594 pstart, pend, lin_mask(1:ninp), act_max_step)
596 IF (act_max_step > lmax_step) cycle
598 SELECT CASE(stat_proc)
601 that%voldatir(i1,i,i3,j,i5,i6) = &
602 sum(real(weights(1:ndtr))*tmpvolr(1:ndtr))
604 that%voldatir(i1,i,i3,j,i5,i6) = &
605 sum(tmpvolr(1:ndtr))/ndtr
608 that%voldatir(i1,i,i3,j,i5,i6) = &
609 maxval(tmpvolr(1:ndtr))
611 that%voldatir(i1,i,i3,j,i5,i6) = &
612 minval(tmpvolr(1:ndtr))
614 that%voldatir(i1,i,i3,j,i5,i6) = &
618 IF (vartype == var_dir360)
THEN
621 WHERE (tmpvolr(1:ndtr) == 0.0)
622 tmpvolr(1:ndtr) = rmiss
623 ELSE WHERE (tmpvolr(1:ndtr) < 22.5 .AND. tmpvolr(1:ndtr) > 0.0)
624 tmpvolr(1:ndtr) = tmpvolr(1:ndtr) + 360.
626 that%voldatir(i1,i,i3,j,i5,i6) = &
637 IF (
ASSOCIATED(this%voldatid))
THEN
638 DO i1 = 1,
SIZE(this%ana)
639 DO i3 = 1,
SIZE(this%level)
640 DO i6 = 1,
SIZE(this%network)
641 DO i5 = 1,
SIZE(this%dativar%d)
643 IF (stat_proc == 4)
THEN
645 IF (map_ttr(i,j)%array(1)%extra_info == 1 .AND. &
646 map_ttr(i,j)%array(ninp)%extra_info == 2)
THEN
647 IF (
c_e(this%voldatid(i1,map_ttr(i,j)%array(1)%it,i3, &
648 map_ttr(i,j)%array(1)%itr,i5,i6)) .AND. &
649 c_e(this%voldatid(i1,map_ttr(i,j)%array(ninp)%it,i3, &
650 map_ttr(i,j)%array(ninp)%itr,i5,i6)))
THEN
651 that%voldatid(i1,i,i3,j,i5,i6) = &
652 this%voldatid(i1,map_ttr(i,j)%array(ninp)%it,i3, &
653 map_ttr(i,j)%array(ninp)%itr,i5,i6) - &
654 this%voldatid(i1,map_ttr(i,j)%array(1)%it,i3, &
655 map_ttr(i,j)%array(1)%itr,i5,i6)
662 vartype = vol7d_vartype(this%dativar%d(i5))
666 IF (
c_e(this%voldatid(i1,map_ttr(i,j)%array(n)%it,i3, &
667 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
669 tmpvold(ndtr) = this%voldatid(i1,map_ttr(i,j)%array(n)%it,i3, &
670 map_ttr(i,j)%array(n)%itr,i5,i6)
676 CALL compute_stat_proc_agg_sw(map_ttr(i,j)%array(1:ninp)%time, &
677 pstart, pend, lin_mask(1:ninp), act_max_step, weights)
679 CALL compute_stat_proc_agg_sw(map_ttr(i,j)%array(1:ninp)%time, &
680 pstart, pend, lin_mask(1:ninp), act_max_step)
682 IF (act_max_step > lmax_step) cycle
684 SELECT CASE(stat_proc)
687 that%voldatid(i1,i,i3,j,i5,i6) = &
688 sum(real(weights(1:ndtr))*tmpvold(1:ndtr))
690 that%voldatid(i1,i,i3,j,i5,i6) = &
691 sum(tmpvold(1:ndtr))/ndtr
694 that%voldatid(i1,i,i3,j,i5,i6) = &
695 maxval(tmpvold(1:ndtr))
697 that%voldatid(i1,i,i3,j,i5,i6) = &
698 minval(tmpvold(1:ndtr))
700 that%voldatid(i1,i,i3,j,i5,i6) = &
704 IF (vartype == var_dir360)
THEN
707 WHERE (tmpvold(1:ndtr) == 0.0d0)
708 tmpvold(1:ndtr) = dmiss
709 ELSE WHERE (tmpvold(1:ndtr) < 22.5d0 .AND. tmpvold(1:ndtr) > 0.0d0)
710 tmpvold(1:ndtr) = tmpvold(1:ndtr) + 360.0d0
712 that%voldatid(i1,i,i3,j,i5,i6) = &
728 DEALLOCATE(tmpvolr, tmpvold, lin_mask, weights)
730 IF (
PRESENT(other))
THEN
731 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
732 ltimerange=(this%timerange(:)%timerange /= tri))
735 END SUBROUTINE vol7d_compute_stat_proc_agg
753 SUBROUTINE vol7d_decompute_stat_proc(this, that, step, other, stat_proc_input)
754 TYPE(
vol7d),
INTENT(inout) :: this
755 TYPE(
vol7d),
INTENT(out) :: that
757 TYPE(
vol7d),
INTENT(inout),
OPTIONAL :: other
758 INTEGER,
INTENT(in),
OPTIONAL :: stat_proc_input
760 INTEGER :: i, tri, steps
763 IF (
PRESENT(stat_proc_input))
THEN
764 tri = stat_proc_input
769 CALL vol7d_alloc_vol(this)
772 CALL getval(step, asec=steps)
775 CALL vol7d_copy(this, that, miss=.false.,
sort=.false., unique=.false., &
776 ltimerange=(this%timerange(:)%timerange == tri .AND. &
777 this%timerange(:)%p1 == 0 .AND. this%timerange(:)%p2 == steps))
780 that%timerange(:)%timerange = 254
781 that%timerange(:)%p2 = 0
782 DO i = 1,
SIZE(that%time(:))
783 that%time(i) = that%time(i) - step/2
786 IF (
PRESENT(other))
THEN
787 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
788 ltimerange=(this%timerange(:)%timerange /= tri .OR. &
789 this%timerange(:)%p1 /= 0 .OR. this%timerange(:)%p2 /= steps))
792 END SUBROUTINE vol7d_decompute_stat_proc
821 SUBROUTINE vol7d_recompute_stat_proc_diff(this, that, stat_proc, step, full_steps, other)
822 TYPE(
vol7d),
INTENT(inout) :: this
823 TYPE(
vol7d),
INTENT(out) :: that
824 INTEGER,
INTENT(in) :: stat_proc
826 LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
827 TYPE(
vol7d),
INTENT(out),
OPTIONAL :: other
829 INTEGER :: i1, i3, i5, i6, i, j, k, l, nitr, steps
830 INTEGER,
ALLOCATABLE :: map_tr(:,:,:,:,:), f(:), keep_tr(:,:,:)
831 LOGICAL,
ALLOCATABLE :: mask_timerange(:)
832 LOGICAL,
ALLOCATABLE :: mask_time(:)
833 TYPE(
vol7d) :: v7dtmp
837 CALL vol7d_alloc_vol(this)
839 CALL init(that, time_definition=this%time_definition)
842 CALL getval(step, asec=steps)
846 CALL recompute_stat_proc_diff_common(this%time, this%timerange, stat_proc, step, &
847 that%time, that%timerange, map_tr, f, keep_tr, &
848 this%time_definition, full_steps)
852 CALL vol7d_alloc(that, nana=0, nlevel=0, nnetwork=0)
853 CALL vol7d_alloc_vol(that)
855 ALLOCATE(mask_time(
SIZE(this%time)), mask_timerange(
SIZE(this%timerange)))
856 DO l = 1,
SIZE(this%time)
857 mask_time(l) = any(this%time(l) == that%time(:))
859 DO l = 1,
SIZE(this%timerange)
860 mask_timerange(l) = any(this%timerange(l) == that%timerange(:))
866 CALL vol7d_copy(this, v7dtmp, miss=.false.,
sort=.false., unique=.false., &
867 ltimerange=mask_timerange(:), ltime=mask_time(:))
869 CALL vol7d_merge(that, v7dtmp, lanasimple=.true., llevelsimple=.true.)
872 IF (
ASSOCIATED(this%voldatir))
THEN
873 DO l = 1,
SIZE(this%time)
875 DO j = 1,
SIZE(this%time)
877 IF (
c_e(map_tr(i,j,k,l,1)))
THEN
878 DO i6 = 1,
SIZE(this%network)
879 DO i5 = 1,
SIZE(this%dativar%r)
880 DO i3 = 1,
SIZE(this%level)
881 DO i1 = 1,
SIZE(this%ana)
882 IF (
c_e(this%voldatir(i1,l,i3,f(k),i5,i6)) .AND. &
883 c_e(this%voldatir(i1,j,i3,f(i),i5,i6)))
THEN
885 IF (stat_proc == 0)
THEN
887 i1,map_tr(i,j,k,l,1),i3,map_tr(i,j,k,l,2),i5,i6) = &
888 (this%voldatir(i1,l,i3,f(k),i5,i6)*this%timerange(f(k))%p2 - &
889 this%voldatir(i1,j,i3,f(i),i5,i6)*this%timerange(f(i))%p2)/ &
891 ELSE IF (stat_proc == 1 .OR. stat_proc == 4)
THEN
893 i1,map_tr(i,j,k,l,1),i3,map_tr(i,j,k,l,2),i5,i6) = &
894 this%voldatir(i1,l,i3,f(k),i5,i6) - &
895 this%voldatir(i1,j,i3,f(i),i5,i6)
910 IF (
ASSOCIATED(this%voldatid))
THEN
911 DO l = 1,
SIZE(this%time)
913 DO j = 1,
SIZE(this%time)
915 IF (
c_e(map_tr(i,j,k,l,1)))
THEN
916 DO i6 = 1,
SIZE(this%network)
917 DO i5 = 1,
SIZE(this%dativar%d)
918 DO i3 = 1,
SIZE(this%level)
919 DO i1 = 1,
SIZE(this%ana)
920 IF (
c_e(this%voldatid(i1,l,i3,f(k),i5,i6)) .AND. &
921 c_e(this%voldatid(i1,j,i3,f(i),i5,i6)))
THEN
925 IF (stat_proc == 0)
THEN
927 i1,map_tr(i,j,k,l,1),i3,map_tr(i,j,k,l,2),i5,i6) = &
928 (this%voldatid(i1,l,i3,f(k),i5,i6)*this%timerange(f(k))%p2 - &
929 this%voldatid(i1,j,i3,f(i),i5,i6)*this%timerange(f(i))%p2)/ &
931 ELSE IF (stat_proc == 1 .OR. stat_proc == 4)
THEN
933 i1,map_tr(i,j,k,l,1),i3,map_tr(i,j,k,l,2),i5,i6) = &
934 this%voldatid(i1,l,i3,f(k),i5,i6) - &
935 this%voldatid(i1,j,i3,f(i),i5,i6)
954 CALL vol7d_smart_sort(that, lsort_time=.true., lsort_timerange=.true.)
956 CALL makeother(.true.)
960 SUBROUTINE makeother(filter)
961 LOGICAL,
INTENT(in) :: filter
962 IF (
PRESENT(other))
THEN
964 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
965 ltimerange=(this%timerange(:)%timerange /= stat_proc))
967 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false.)
970 END SUBROUTINE makeother
972 END SUBROUTINE vol7d_recompute_stat_proc_diff
1002 SUBROUTINE vol7d_compute_stat_proc_metamorph(this, that, stat_proc_input, stat_proc)
1003 TYPE(
vol7d),
INTENT(inout) :: this
1004 TYPE(
vol7d),
INTENT(out) :: that
1005 INTEGER,
INTENT(in) :: stat_proc_input
1006 INTEGER,
INTENT(in) :: stat_proc
1009 LOGICAL,
ALLOCATABLE :: tr_mask(:)
1010 REAL,
ALLOCATABLE :: int_ratio(:)
1011 DOUBLE PRECISION,
ALLOCATABLE :: int_ratiod(:)
1013 IF (.NOT.((stat_proc_input == 0 .AND. stat_proc == 1) .OR. &
1014 (stat_proc_input == 1 .AND. stat_proc == 0)))
THEN
1016 CALL l4f_log(l4f_warn, &
1017 'compute_stat_proc_metamorph, can only be applied to average->accumulated timerange and viceversa')
1020 CALL vol7d_alloc_vol(that)
1025 CALL vol7d_alloc_vol(this)
1028 tr_mask = this%timerange(:)%timerange == stat_proc_input .AND. this%timerange(:)%p2 /= imiss &
1029 .AND. this%timerange(:)%p2 /= 0
1032 IF (count(tr_mask) == 0)
THEN
1033 CALL l4f_log(l4f_warn, &
1034 'vol7d_compute, no timeranges suitable for statistical processing by metamorphosis')
1041 CALL vol7d_copy(this, that, ltimerange=tr_mask)
1042 that%timerange(:)%timerange = stat_proc
1044 ALLOCATE(int_ratio(
SIZE(that%timerange)), int_ratiod(
SIZE(that%timerange)))
1046 IF (stat_proc == 0)
THEN
1047 int_ratio = 1./real(that%timerange(:)%p2)
1048 int_ratiod = 1./dble(that%timerange(:)%p2)
1050 int_ratio = real(that%timerange(:)%p2)
1051 int_ratiod = dble(that%timerange(:)%p2)
1054 IF (
ASSOCIATED(that%voldatir))
THEN
1055 DO j = 1,
SIZE(that%timerange)
1056 WHERE(
c_e(that%voldatir(:,:,:,j,:,:)))
1057 that%voldatir(:,:,:,j,:,:) = that%voldatir(:,:,:,j,:,:)*int_ratio(j)
1059 that%voldatir(:,:,:,j,:,:) = rmiss
1064 IF (
ASSOCIATED(that%voldatid))
THEN
1065 DO j = 1,
SIZE(that%timerange)
1066 WHERE(
c_e(that%voldatid(:,:,:,j,:,:)))
1067 that%voldatid(:,:,:,j,:,:) = that%voldatid(:,:,:,j,:,:)*int_ratiod(j)
1069 that%voldatid(:,:,:,j,:,:) = rmiss
1075 END SUBROUTINE vol7d_compute_stat_proc_metamorph
1078 SUBROUTINE vol7d_recompute_stat_proc_agg_multiv(this, that, &
1079 step, start, frac_valid, multiv_proc)
1080 TYPE(
vol7d),
INTENT(inout) :: this
1081 TYPE(
vol7d),
INTENT(out) :: that
1084 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1085 REAL,
INTENT(in),
OPTIONAL :: frac_valid
1088 INTEGER,
INTENT(in) :: multiv_proc
1091 INTEGER :: i, j, n, n1, ndtr, i1, i3, i5, i6
1092 INTEGER :: linshape(1)
1093 REAL :: lfrac_valid, frac_c, frac_m
1094 LOGICAL,
ALLOCATABLE :: ttr_mask(:,:)
1096 INTEGER,
POINTER :: dtratio(:)
1097 INTEGER :: stat_proc_input, stat_proc
1099 SELECT CASE(multiv_proc)
1101 stat_proc_input = 205
1105 tri = stat_proc_input
1106 IF (
PRESENT(frac_valid))
THEN
1107 lfrac_valid = frac_valid
1113 CALL vol7d_alloc_vol(this)
1117 CALL vol7d_smart_sort(this, lsort_time=.true.)
1118 CALL vol7d_reform(this, miss=.false.,
sort=.false., unique=.true.)
1120 CALL init(that, time_definition=this%time_definition)
1121 CALL vol7d_alloc(that, nana=
SIZE(this%ana), nlevel=
SIZE(this%level), &
1122 nnetwork=
SIZE(this%network))
1123 IF (
ASSOCIATED(this%dativar%r))
THEN
1124 CALL vol7d_alloc(that, ndativarr=
SIZE(this%dativar%r))
1125 that%dativar%r = this%dativar%r
1127 IF (
ASSOCIATED(this%dativar%d))
THEN
1128 CALL vol7d_alloc(that, ndativard=
SIZE(this%dativar%d))
1129 that%dativar%d = this%dativar%d
1132 that%level = this%level
1133 that%network = this%network
1136 CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
1137 step, this%time_definition, that%time, that%timerange, map_ttr, &
1138 dtratio=dtratio, start=start)
1139 CALL vol7d_alloc_vol(that)
1141 ALLOCATE(ttr_mask(
SIZE(this%time),
SIZE(this%timerange)))
1142 linshape = (/
SIZE(ttr_mask)/)
1144 IF (
ASSOCIATED(this%voldatir))
THEN
1145 DO j = 1,
SIZE(that%timerange)
1146 DO i = 1,
SIZE(that%time)
1148 DO i1 = 1,
SIZE(this%ana)
1149 DO i3 = 1,
SIZE(this%level)
1150 DO i6 = 1,
SIZE(this%network)
1151 DO i5 = 1,
SIZE(this%dativar%r)
1154 DO n1 =
SIZE(dtratio), 1, -1
1155 IF (dtratio(n1) <= 0) cycle
1157 DO n = 1, map_ttr(i,j)%arraysize
1158 IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1))
THEN
1159 IF (
c_e(this%voldatir(i1,map_ttr(i,j)%array(n)%it,i3, &
1160 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
1161 ttr_mask(map_ttr(i,j)%array(n)%it, &
1162 map_ttr(i,j)%array(n)%itr) = .true.
1167 ndtr = count(ttr_mask)
1168 frac_c = real(ndtr)/real(dtratio(n1))
1170 IF (ndtr > 0 .AND. frac_c >= max(lfrac_valid, frac_m))
THEN
1172 SELECT CASE(multiv_proc)
1174 that%voldatir(i1,i,i3,j,i5,i6) = &
1175 sum(this%voldatir(i1,:,i3,:,i5,i6), &
1185 CALL delete(map_ttr(i,j))
1190 IF (
ASSOCIATED(this%voldatid))
THEN
1191 DO j = 1,
SIZE(that%timerange)
1192 DO i = 1,
SIZE(that%time)
1194 DO i1 = 1,
SIZE(this%ana)
1195 DO i3 = 1,
SIZE(this%level)
1196 DO i6 = 1,
SIZE(this%network)
1197 DO i5 = 1,
SIZE(this%dativar%d)
1200 DO n1 =
SIZE(dtratio), 1, -1
1201 IF (dtratio(n1) <= 0) cycle
1203 DO n = 1, map_ttr(i,j)%arraysize
1204 IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1))
THEN
1205 IF (
c_e(this%voldatid(i1,map_ttr(i,j)%array(n)%it,i3, &
1206 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
1207 ttr_mask(map_ttr(i,j)%array(n)%it, &
1208 map_ttr(i,j)%array(n)%itr) = .true.
1213 ndtr = count(ttr_mask)
1214 frac_c = real(ndtr)/real(dtratio(n1))
1216 IF (ndtr > 0 .AND. frac_c >= max(lfrac_valid, frac_m))
THEN
1218 SELECT CASE(stat_proc)
1220 that%voldatid(i1,i,i3,j,i5,i6) = &
1221 sum(this%voldatid(i1,:,i3,:,i5,i6), &
1224 that%voldatid(i1,i,i3,j,i5,i6) = &
1225 sum(this%voldatid(i1,:,i3,:,i5,i6), &
1228 that%voldatid(i1,i,i3,j,i5,i6) = &
1229 maxval(this%voldatid(i1,:,i3,:,i5,i6), &
1232 that%voldatid(i1,i,i3,j,i5,i6) = &
1233 minval(this%voldatid(i1,:,i3,:,i5,i6), &
1236 that%voldatid(i1,i,i3,j,i5,i6) = &
1238 reshape(this%voldatid(i1,:,i3,:,i5,i6), shape=linshape), &
1239 mask=reshape(ttr_mask, shape=linshape))
1248 CALL delete(map_ttr(i,j))
1253 DEALLOCATE(ttr_mask)
1255 END SUBROUTINE vol7d_recompute_stat_proc_agg_multiv
1273 SUBROUTINE vol7d_fill_time(this, that, step, start, stopp, cyclicdt)
1274 TYPE(
vol7d),
INTENT(inout) :: this
1275 TYPE(
vol7d),
INTENT(inout) :: that
1277 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1278 TYPE(
datetime),
INTENT(in),
OPTIONAL :: stopp
1282 TYPE(
datetime) :: counter, lstart, lstop
1283 INTEGER :: i, naddtime
1285 CALL safe_start_stop(this, lstart, lstop, start, stopp)
1286 IF (.NOT.
c_e(lstart) .OR. .NOT.
c_e(lstop) .OR. .NOT.
c_e(step))
RETURN
1288 lcyclicdt=cyclicdatetime_miss
1289 if (
present(cyclicdt))
then
1290 if(
c_e(cyclicdt)) lcyclicdt=cyclicdt
1293 CALL l4f_log(l4f_info,
'vol7d_fill_time: time interval '//trim(
to_char(lstart))// &
1301 naddcount:
DO WHILE(counter <= lstop)
1302 DO WHILE(i <=
SIZE(this%time))
1303 IF (counter < this%time(i))
THEN
1306 ELSE IF (counter == this%time(i) .OR. .NOT. counter == lcyclicdt)
THEN
1307 counter = counter + step
1312 naddtime = naddtime + 1
1313 counter = counter + step
1326 IF (naddtime > 0)
THEN
1329 CALL vol7d_alloc(that, ntime=naddtime)
1330 CALL vol7d_alloc_vol(that)
1336 naddadd:
DO WHILE(counter <= lstop)
1337 DO WHILE(i <=
SIZE(this%time))
1338 IF (counter < this%time(i))
THEN
1341 ELSE IF (counter == this%time(i) .OR. .NOT. counter == lcyclicdt)
THEN
1342 counter = counter + step
1347 naddtime = naddtime + 1
1348 that%time(naddtime) = counter
1349 counter = counter + step
1352 CALL vol7d_append(that, this,
sort=.true.)
1357 CALL vol7d_copy(this, that,
sort=.true.)
1361 END SUBROUTINE vol7d_fill_time
1375 SUBROUTINE vol7d_filter_time(this, that, step, start, stopp, cyclicdt)
1376 TYPE(
vol7d),
INTENT(inout) :: this
1377 TYPE(
vol7d),
INTENT(inout) :: that
1378 TYPE(
timedelta),
INTENT(in),
optional :: step
1379 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1380 TYPE(
datetime),
INTENT(in),
OPTIONAL :: stopp
1384 LOGICAL,
ALLOCATABLE :: time_mask(:)
1386 CALL safe_start_stop(this, lstart, lstop, start, stopp)
1387 IF (.NOT.
c_e(lstart) .OR. .NOT.
c_e(lstop))
RETURN
1389 CALL l4f_log(l4f_info,
'vol7d_filter_time: time interval '//trim(
to_char(lstart))// &
1392 ALLOCATE(time_mask(
SIZE(this%time)))
1394 time_mask = this%time >= lstart .AND. this%time <= lstop
1396 IF (
PRESENT(cyclicdt))
THEN
1397 IF (
c_e(cyclicdt))
THEN
1398 time_mask = time_mask .AND. this%time == cyclicdt
1402 IF (
PRESENT(step))
THEN
1404 time_mask = time_mask .AND.
mod(this%time - lstart, step) == timedelta_0
1408 CALL vol7d_copy(this,that, ltime=time_mask)
1410 DEALLOCATE(time_mask)
1412 END SUBROUTINE vol7d_filter_time
1418 SUBROUTINE vol7d_fill_data(this, step, start, stopp, tolerance)
1419 TYPE(
vol7d),
INTENT(inout) :: this
1421 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1422 TYPE(
datetime),
INTENT(in),
OPTIONAL :: stopp
1423 TYPE(
timedelta),
INTENT(in),
optional :: tolerance
1426 integer :: indana , indtime ,indlevel ,indtimerange ,inddativarr, indnetwork, iindtime
1427 type(
timedelta) :: deltato,deltat, ltolerance
1429 CALL safe_start_stop(this, lstart, lstop, start, stopp)
1430 IF (.NOT.
c_e(lstart) .OR. .NOT.
c_e(lstop))
RETURN
1432 CALL l4f_log(l4f_info,
'vol7d_fill_data: time interval '//trim(
to_char(lstart))// &
1438 if (
present(tolerance))
then
1439 if (
c_e(tolerance)) ltolerance=tolerance
1443 do indtime=1,
size(this%time)
1445 IF (this%time(indtime) < lstart .OR. this%time(indtime) > lstop .OR. &
1446 mod(this%time(indtime) - lstart, step) /= timedelta_0) cycle
1447 do indtimerange=1,
size(this%timerange)
1448 if (this%timerange(indtimerange)%timerange /= 254) cycle
1449 do indnetwork=1,
size(this%network)
1450 do inddativarr=1,
size(this%dativar%r)
1451 do indlevel=1,
size(this%level)
1452 do indana=1,
size(this%ana)
1455 if (.not.
c_e(this%voldatir(indana, indtime, indlevel, indtimerange, inddativarr, indnetwork)))
then
1456 deltato=timedelta_miss
1460 do iindtime=indtime+1,
size(this%time)
1462 if (
c_e(this%voldatir (indana, iindtime, indlevel, indtimerange, inddativarr, indnetwork )))
then
1463 deltat=this%time(iindtime)-this%time(indtime)
1465 if (deltat >= ltolerance)
exit
1467 if (deltat < deltato)
then
1468 this%voldatir(indana, indtime, indlevel, indtimerange, inddativarr, indnetwork) = &
1469 this%voldatir(indana, iindtime, indlevel, indtimerange, inddativarr, indnetwork)
1475 do iindtime=indtime-1,1,-1
1477 if (
c_e(this%voldatir (indana, iindtime, indlevel, indtimerange, inddativarr, indnetwork )))
then
1478 if (iindtime < indtime)
then
1479 deltat=this%time(indtime)-this%time(iindtime)
1480 else if (iindtime > indtime)
then
1481 deltat=this%time(iindtime)-this%time(indtime)
1486 if (deltat >= ltolerance)
exit
1488 if (deltat < deltato)
then
1489 this%voldatir(indana, indtime, indlevel, indtimerange, inddativarr, indnetwork) = &
1490 this%voldatir(indana, iindtime, indlevel, indtimerange, inddativarr, indnetwork)
1504 END SUBROUTINE vol7d_fill_data
1510 SUBROUTINE safe_start_stop(this, lstart, lstop, start, stopp)
1511 TYPE(
vol7d),
INTENT(inout) :: this
1512 TYPE(
datetime),
INTENT(out) :: lstart
1513 TYPE(
datetime),
INTENT(out) :: lstop
1514 TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1515 TYPE(
datetime),
INTENT(in),
OPTIONAL :: stopp
1517 lstart = datetime_miss
1518 lstop = datetime_miss
1520 CALL vol7d_alloc_vol(this)
1521 IF (
SIZE(this%time) == 0)
RETURN
1522 CALL vol7d_smart_sort(this, lsort_time=.true.)
1524 IF (
PRESENT(start))
THEN
1525 IF (
c_e(start))
THEN
1528 lstart = this%time(1)
1531 lstart = this%time(1)
1533 IF (
PRESENT(stopp))
THEN
1534 IF (
c_e(stopp))
THEN
1537 lstop = this%time(
SIZE(this%time))
1540 lstop = this%time(
SIZE(this%time))
1543 END SUBROUTINE safe_start_stop
1552 SUBROUTINE vol7d_normalize_vcoord(this,that,ana,time,timerange,network)
1553 TYPE(
vol7d),
INTENT(INOUT) :: this
1554 TYPE(
vol7d),
INTENT(OUT) :: that
1555 integer,
intent(in) :: time,ana,timerange,network
1557 character(len=1) :: type
1559 TYPE(vol7d_var) :: var
1560 LOGICAL,
allocatable :: ltime(:),ltimerange(:),lana(:),lnetwork(:)
1561 logical,
allocatable :: maschera(:)
1564 allocate(ltime(
size(this%time)))
1565 allocate(ltimerange(
size(this%timerange)))
1566 allocate(lana(
size(this%ana)))
1567 allocate(lnetwork(
size(this%network)))
1575 ltimerange(timerange)=.true.
1577 lnetwork(network)=.true.
1579 call vol7d_copy(this, that,unique=.true.,&
1580 ltime=ltime,ltimerange=ltimerange,lana=lana,lnetwork=lnetwork )
1582 call init(var, btable=
"B10004")
1585 ind =
index(that%dativar, var, type=type)
1587 allocate(maschera(
size(that%level)))
1590 (that%level%level1 == 105.and.that%level%level2 == 105) .or. &
1591 (that%level%level1 == 103 .and. that%level%level2 == imiss ) .or. &
1592 (that%level%level1 == 102 .and. that%level%level2 == imiss )) &
1593 .and.
c_e(that%voldatic(1,1,:,1,ind,1))
1601 that%level%level1 = 100
1602 that%level%l1 = int(
realdat(that%voldatid(1,1,:,1,ind,1),that%dativar%d(ind)))
1603 that%level%l1 = int(that%voldatid(1,1,:,1,ind,1))
1604 that%level%level2 = imiss
1605 that%level%l2 = imiss
1611 that%level%level1 = 100
1612 that%level%l1 = int(
realdat(that%voldatir(1,1,:,1,ind,1),that%dativar%r(ind)))
1613 that%level%level2 = imiss
1614 that%level%l2 = imiss
1620 that%level%level1 = 100
1621 that%level%l1 = int(
realdat(that%voldatii(1,1,:,1,ind,1),that%dativar%i(ind)))
1622 that%level%level2 = imiss
1623 that%level%l2 = imiss
1629 that%level%level1 = 100
1630 that%level%l1 = int(
realdat(that%voldatib(1,1,:,1,ind,1),that%dativar%b(ind)))
1631 that%level%level2 = imiss
1632 that%level%l2 = imiss
1638 that%level%level1 = 100
1639 that%level%l1 = int(
realdat(that%voldatic(1,1,:,1,ind,1),that%dativar%c(ind)))
1640 that%level%level2 = imiss
1641 that%level%l2 = imiss
1647 deallocate(ltimerange)
1649 deallocate(lnetwork)
1651 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...