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
489 TYPE(timedelta),
INTENT(in) :: step
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
502 TYPE(arrayof_ttr_mapper),
POINTER :: map_ttr(:,:)
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
757 TYPE(timedelta),
INTENT(in) :: step
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
826 TYPE(timedelta),
INTENT(in) :: step
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
1085 TYPE(timedelta),
INTENT(in) :: step
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(:,:)
1097 TYPE(arrayof_ttr_mapper),
POINTER :: map_ttr(:,:)
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
1278 TYPE(timedelta),
INTENT(in) :: step
1279 TYPE(datetime),
INTENT(in),
OPTIONAL :: start
1280 TYPE(datetime),
INTENT(in),
OPTIONAL :: stopp
1281 TYPE(cyclicdatetime),
INTENT(in),
OPTIONAL :: cyclicdt
1283 TYPE(cyclicdatetime) :: lcyclicdt
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
1383 TYPE(cyclicdatetime),
INTENT(in),
OPTIONAL :: cyclicdt
1385 TYPE(datetime) :: lstart, lstop
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
1422 TYPE(timedelta),
INTENT(in) :: step
1423 TYPE(datetime),
INTENT(in),
OPTIONAL :: start
1424 TYPE(datetime),
INTENT(in),
OPTIONAL :: stopp
1425 TYPE(timedelta),
INTENT(in),
optional :: tolerance
1427 TYPE(datetime) :: lstart, lstop
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
Functions that return a trimmed CHARACTER representation of the input variable.
Compute the mode of the random variable provided taking into account missing data.
This module contains functions that are only for internal use of the library.
Classi per la gestione delle coordinate temporali.
Compute the standard deviation of the random variable provided, taking into account missing data...
Distruttori per le 2 classi.
Restituiscono il valore dell'oggetto in forma di stringa stampabile.
Restituiscono il valore dell'oggetto nella forma desiderata.
Operatore di resto della divisione.
Classe per la gestione di un volume completo di dati osservati.
Costruttori per le classi datetime e timedelta.
Extension of vol7d_class with methods for performing simple statistical operations on entire volumes ...
Module for basic statistical computations taking into account missing data.