106SUBROUTINE vol7d_compute_stat_proc(this, that, stat_proc_input, stat_proc, &
107 step, start, full_steps, frac_valid, max_step, weighted, other)
108TYPE(vol7d),
INTENT(inout) :: this
109TYPE(vol7d),
INTENT(out) :: that
110INTEGER,
INTENT(in) :: stat_proc_input
111INTEGER,
INTENT(in) :: stat_proc
112TYPE(timedelta),
INTENT(in) :: step
113TYPE(datetime),
INTENT(in),
OPTIONAL :: start
114LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
115REAL,
INTENT(in),
OPTIONAL :: frac_valid
116TYPE(timedelta),
INTENT(in),
OPTIONAL :: max_step
117LOGICAL,
INTENT(in),
OPTIONAL :: weighted
118TYPE(vol7d),
INTENT(inout),
OPTIONAL :: other
120TYPE(vol7d) :: that1, that2, other1
123IF (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)
130ELSE 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)
158ELSE 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')
198END SUBROUTINE vol7d_compute_stat_proc
246SUBROUTINE vol7d_recompute_stat_proc_agg(this, that, stat_proc, &
247 step, start, full_steps, frac_valid, other, stat_proc_input)
248TYPE(vol7d),
INTENT(inout) :: this
249TYPE(vol7d),
INTENT(out) :: that
250INTEGER,
INTENT(in) :: stat_proc
251TYPE(timedelta),
INTENT(in) :: step
252TYPE(datetime),
INTENT(in),
OPTIONAL :: start
253LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
254REAL,
INTENT(in),
OPTIONAL :: frac_valid
255TYPE(vol7d),
INTENT(inout),
OPTIONAL :: other
256INTEGER,
INTENT(in),
OPTIONAL :: stat_proc_input
259INTEGER :: i, j, n, n1, ndtr, i1, i3, i5, i6
260INTEGER :: linshape(1)
261REAL :: lfrac_valid, frac_c, frac_m
262LOGICAL,
ALLOCATABLE :: ttr_mask(:,:)
263TYPE(arrayof_ttr_mapper),
POINTER :: map_ttr(:,:)
264INTEGER,
POINTER :: dtratio(:)
267IF (
PRESENT(stat_proc_input))
THEN
268 tri = stat_proc_input
272IF (
PRESENT(frac_valid))
THEN
273 lfrac_valid = frac_valid
279CALL vol7d_alloc_vol(this)
283CALL vol7d_smart_sort(this, lsort_time=.true.)
284CALL vol7d_reform(this, miss=.false.,
sort=.false., unique=.true.)
286CALL init(that, time_definition=this%time_definition)
287CALL vol7d_alloc(that, nana=
SIZE(this%ana), nlevel=
SIZE(this%level), &
288 nnetwork=
SIZE(this%network))
289IF (
ASSOCIATED(this%dativar%r))
THEN
290 CALL vol7d_alloc(that, ndativarr=
SIZE(this%dativar%r))
291 that%dativar%r = this%dativar%r
293IF (
ASSOCIATED(this%dativar%d))
THEN
294 CALL vol7d_alloc(that, ndativard=
SIZE(this%dativar%d))
295 that%dativar%d = this%dativar%d
298that%level = this%level
299that%network = this%network
302CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
303 step, this%time_definition, that%time, that%timerange, map_ttr, dtratio, &
305CALL vol7d_alloc_vol(that)
307ALLOCATE(ttr_mask(
SIZE(this%time),
SIZE(this%timerange)))
308linshape = (/
SIZE(ttr_mask)/)
310IF (
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))
373IF (
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))
442SUBROUTINE makeother()
443IF (
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))
448END SUBROUTINE makeother
450END SUBROUTINE vol7d_recompute_stat_proc_agg
484SUBROUTINE vol7d_compute_stat_proc_agg(this, that, stat_proc, &
485 step, start, full_steps, max_step, weighted, other)
486TYPE(
vol7d),
INTENT(inout) :: this
487TYPE(
vol7d),
INTENT(out) :: that
488INTEGER,
INTENT(in) :: stat_proc
490TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
491LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
492TYPE(
timedelta),
INTENT(in),
OPTIONAL :: max_step
493LOGICAL,
INTENT(in),
OPTIONAL :: weighted
494TYPE(
vol7d),
INTENT(inout),
OPTIONAL :: other
499INTEGER :: i, j, n, ninp, ndtr, i1, i3, i5, i6, vartype, maxsize
500TYPE(
timedelta) :: lmax_step, act_max_step
501TYPE(
datetime) :: pstart, pend, reftime
503REAL,
ALLOCATABLE :: tmpvolr(:)
504DOUBLE PRECISION,
ALLOCATABLE :: tmpvold(:), weights(:)
505LOGICAL,
ALLOCATABLE :: lin_mask(:)
507CHARACTER(len=8) :: env_var
509IF (
PRESENT(max_step))
THEN
512 lmax_step = timedelta_max
514lweighted = optio_log(weighted)
518CALL getenv(
'LIBSIM_CLIMAT_BEHAVIOR', env_var)
519lweighted = lweighted .AND. len_trim(env_var) == 0
521lweighted = lweighted .AND. stat_proc == 0
524CALL vol7d_alloc_vol(this)
528CALL vol7d_smart_sort(this, lsort_time=.true.)
529CALL vol7d_reform(this, miss=.false.,
sort=.false., unique=.true.)
531CALL vol7d_copy(this, v7dtmp, ltime=(/.false./), ltimerange=(/.false./))
534CALL init(that, time_definition=this%time_definition)
536CALL 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)
540CALL vol7d_merge(that, v7dtmp)
542maxsize = maxval(map_ttr(:,:)%arraysize)
543ALLOCATE(tmpvolr(maxsize), tmpvold(maxsize), lin_mask(maxsize), weights(maxsize))
544do_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) = &
729DEALLOCATE(tmpvolr, tmpvold, lin_mask, weights)
731IF (
PRESENT(other))
THEN
732 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
733 ltimerange=(this%timerange(:)%timerange /= tri))
736END SUBROUTINE vol7d_compute_stat_proc_agg
754SUBROUTINE vol7d_decompute_stat_proc(this, that, step, other, stat_proc_input)
755TYPE(
vol7d),
INTENT(inout) :: this
756TYPE(
vol7d),
INTENT(out) :: that
758TYPE(
vol7d),
INTENT(inout),
OPTIONAL :: other
759INTEGER,
INTENT(in),
OPTIONAL :: stat_proc_input
761INTEGER :: i, tri, steps
764IF (
PRESENT(stat_proc_input))
THEN
765 tri = stat_proc_input
770CALL vol7d_alloc_vol(this)
773CALL getval(step, asec=steps)
776CALL 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))
781that%timerange(:)%timerange = 254
782that%timerange(:)%p2 = 0
783DO i = 1,
SIZE(that%time(:))
784 that%time(i) = that%time(i) - step/2
787IF (
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))
793END SUBROUTINE vol7d_decompute_stat_proc
822SUBROUTINE vol7d_recompute_stat_proc_diff(this, that, stat_proc, step, full_steps, start, other)
823TYPE(
vol7d),
INTENT(inout) :: this
824TYPE(
vol7d),
INTENT(out) :: that
825INTEGER,
INTENT(in) :: stat_proc
827LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
828TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
829TYPE(
vol7d),
INTENT(out),
OPTIONAL :: other
831INTEGER :: i1, i3, i5, i6, i, j, k, l, nitr, steps
832INTEGER,
ALLOCATABLE :: map_tr(:,:,:,:,:), f(:), keep_tr(:,:,:)
833LOGICAL,
ALLOCATABLE :: mask_timerange(:)
834LOGICAL,
ALLOCATABLE :: mask_time(:)
839CALL vol7d_alloc_vol(this)
841CALL init(that, time_definition=this%time_definition)
844CALL getval(step, asec=steps)
848CALL 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)
854CALL vol7d_alloc(that, nana=0, nlevel=0, nnetwork=0)
855CALL vol7d_alloc_vol(that)
857ALLOCATE(mask_time(
SIZE(this%time)), mask_timerange(
SIZE(this%timerange)))
858DO l = 1,
SIZE(this%time)
859 mask_time(l) = any(this%time(l) == that%time(:))
861DO l = 1,
SIZE(this%timerange)
862 mask_timerange(l) = any(this%timerange(l) == that%timerange(:))
868CALL vol7d_copy(this, v7dtmp, miss=.false.,
sort=.false., unique=.false., &
869 ltimerange=mask_timerange(:), ltime=mask_time(:))
871CALL vol7d_merge(that, v7dtmp, lanasimple=.true., llevelsimple=.true.)
874IF (
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)
912IF (
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)
956CALL vol7d_smart_sort(that, lsort_time=.true., lsort_timerange=.true.)
958CALL makeother(.true.)
962SUBROUTINE makeother(filter)
963LOGICAL,
INTENT(in) :: filter
964IF (
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.)
972END SUBROUTINE makeother
974END SUBROUTINE vol7d_recompute_stat_proc_diff
1004SUBROUTINE vol7d_compute_stat_proc_metamorph(this, that, stat_proc_input, stat_proc)
1005TYPE(
vol7d),
INTENT(inout) :: this
1006TYPE(
vol7d),
INTENT(out) :: that
1007INTEGER,
INTENT(in) :: stat_proc_input
1008INTEGER,
INTENT(in) :: stat_proc
1011LOGICAL,
ALLOCATABLE :: tr_mask(:)
1012REAL,
ALLOCATABLE :: int_ratio(:)
1013DOUBLE PRECISION,
ALLOCATABLE :: int_ratiod(:)
1015IF (.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)
1027CALL vol7d_alloc_vol(this)
1030tr_mask = this%timerange(:)%timerange == stat_proc_input .AND. this%timerange(:)%p2 /= imiss &
1031 .AND. this%timerange(:)%p2 /= 0
1034IF (count(tr_mask) == 0)
THEN
1035 CALL l4f_log(l4f_warn, &
1036 'vol7d_compute, no timeranges suitable for statistical processing by metamorphosis')
1043CALL vol7d_copy(this, that, ltimerange=tr_mask)
1044that%timerange(:)%timerange = stat_proc
1046ALLOCATE(int_ratio(
SIZE(that%timerange)), int_ratiod(
SIZE(that%timerange)))
1048IF (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)
1056IF (
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
1066IF (
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
1077END SUBROUTINE vol7d_compute_stat_proc_metamorph
1080SUBROUTINE vol7d_recompute_stat_proc_agg_multiv(this, that, &
1081 step, start, frac_valid, multiv_proc)
1082TYPE(
vol7d),
INTENT(inout) :: this
1083TYPE(
vol7d),
INTENT(out) :: that
1086TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1087REAL,
INTENT(in),
OPTIONAL :: frac_valid
1090INTEGER,
INTENT(in) :: multiv_proc
1093INTEGER :: i, j, n, n1, ndtr, i1, i3, i5, i6
1094INTEGER :: linshape(1)
1095REAL :: lfrac_valid, frac_c, frac_m
1096LOGICAL,
ALLOCATABLE :: ttr_mask(:,:)
1098INTEGER,
POINTER :: dtratio(:)
1099INTEGER :: stat_proc_input, stat_proc
1101SELECT CASE(multiv_proc)
1103 stat_proc_input = 205
1107tri = stat_proc_input
1108IF (
PRESENT(frac_valid))
THEN
1109 lfrac_valid = frac_valid
1115CALL vol7d_alloc_vol(this)
1119CALL vol7d_smart_sort(this, lsort_time=.true.)
1120CALL vol7d_reform(this, miss=.false.,
sort=.false., unique=.true.)
1122CALL init(that, time_definition=this%time_definition)
1123CALL vol7d_alloc(that, nana=
SIZE(this%ana), nlevel=
SIZE(this%level), &
1124 nnetwork=
SIZE(this%network))
1125IF (
ASSOCIATED(this%dativar%r))
THEN
1126 CALL vol7d_alloc(that, ndativarr=
SIZE(this%dativar%r))
1127 that%dativar%r = this%dativar%r
1129IF (
ASSOCIATED(this%dativar%d))
THEN
1130 CALL vol7d_alloc(that, ndativard=
SIZE(this%dativar%d))
1131 that%dativar%d = this%dativar%d
1134that%level = this%level
1135that%network = this%network
1138CALL 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)
1141CALL vol7d_alloc_vol(that)
1143ALLOCATE(ttr_mask(
SIZE(this%time),
SIZE(this%timerange)))
1144linshape = (/
SIZE(ttr_mask)/)
1146IF (
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))
1192IF (
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))
1257END SUBROUTINE vol7d_recompute_stat_proc_agg_multiv
1275SUBROUTINE vol7d_fill_time(this, that, step, start, stopp, cyclicdt)
1276TYPE(
vol7d),
INTENT(inout) :: this
1277TYPE(
vol7d),
INTENT(inout) :: that
1279TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1280TYPE(
datetime),
INTENT(in),
OPTIONAL :: stopp
1284TYPE(
datetime) :: counter, lstart, lstop
1285INTEGER :: i, naddtime
1287CALL safe_start_stop(this, lstart, lstop, start, stopp)
1288IF (.NOT.
c_e(lstart) .OR. .NOT.
c_e(lstop) .OR. .NOT.
c_e(step))
RETURN
1290lcyclicdt=cyclicdatetime_miss
1291if (
present(cyclicdt))
then
1292 if(
c_e(cyclicdt)) lcyclicdt=cyclicdt
1295CALL l4f_log(l4f_info,
'vol7d_fill_time: time interval '//trim(
to_char(lstart))// &
1303naddcount:
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
1328IF (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.)
1363END SUBROUTINE vol7d_fill_time
1377SUBROUTINE vol7d_filter_time(this, that, step, start, stopp, cyclicdt)
1378TYPE(
vol7d),
INTENT(inout) :: this
1379TYPE(
vol7d),
INTENT(inout) :: that
1380TYPE(
timedelta),
INTENT(in),
optional :: step
1381TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1382TYPE(
datetime),
INTENT(in),
OPTIONAL :: stopp
1386LOGICAL,
ALLOCATABLE :: time_mask(:)
1388CALL safe_start_stop(this, lstart, lstop, start, stopp)
1389IF (.NOT.
c_e(lstart) .OR. .NOT.
c_e(lstop))
RETURN
1391CALL l4f_log(l4f_info,
'vol7d_filter_time: time interval '//trim(
to_char(lstart))// &
1394ALLOCATE(time_mask(
SIZE(this%time)))
1396time_mask = this%time >= lstart .AND. this%time <= lstop
1398IF (
PRESENT(cyclicdt))
THEN
1399 IF (
c_e(cyclicdt))
THEN
1400 time_mask = time_mask .AND. this%time == cyclicdt
1404IF (
PRESENT(step))
THEN
1406 time_mask = time_mask .AND.
mod(this%time - lstart, step) == timedelta_0
1410CALL vol7d_copy(this,that, ltime=time_mask)
1412DEALLOCATE(time_mask)
1414END SUBROUTINE vol7d_filter_time
1420SUBROUTINE vol7d_fill_data(this, step, start, stopp, tolerance)
1421TYPE(
vol7d),
INTENT(inout) :: this
1423TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1424TYPE(
datetime),
INTENT(in),
OPTIONAL :: stopp
1425TYPE(
timedelta),
INTENT(in),
optional :: tolerance
1428integer :: indana , indtime ,indlevel ,indtimerange ,inddativarr, indnetwork, iindtime
1429type(
timedelta) :: deltato,deltat, ltolerance
1431CALL safe_start_stop(this, lstart, lstop, start, stopp)
1432IF (.NOT.
c_e(lstart) .OR. .NOT.
c_e(lstop))
RETURN
1434CALL l4f_log(l4f_info,
'vol7d_fill_data: time interval '//trim(
to_char(lstart))// &
1440if (
present(tolerance))
then
1441 if (
c_e(tolerance)) ltolerance=tolerance
1445do 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)
1506END SUBROUTINE vol7d_fill_data
1512SUBROUTINE safe_start_stop(this, lstart, lstop, start, stopp)
1513TYPE(
vol7d),
INTENT(inout) :: this
1514TYPE(
datetime),
INTENT(out) :: lstart
1516TYPE(
datetime),
INTENT(in),
OPTIONAL :: start
1517TYPE(
datetime),
INTENT(in),
OPTIONAL :: stopp
1519lstart = datetime_miss
1520lstop = datetime_miss
1522CALL vol7d_alloc_vol(this)
1523IF (
SIZE(this%time) == 0)
RETURN
1524CALL vol7d_smart_sort(this, lsort_time=.true.)
1526IF (
PRESENT(start))
THEN
1527 IF (
c_e(start))
THEN
1530 lstart = this%time(1)
1533 lstart = this%time(1)
1535IF (
PRESENT(stopp))
THEN
1536 IF (
c_e(stopp))
THEN
1539 lstop = this%time(
SIZE(this%time))
1542 lstop = this%time(
SIZE(this%time))
1545END SUBROUTINE safe_start_stop
1554SUBROUTINE vol7d_normalize_vcoord(this,that,ana,time,timerange,network)
1555TYPE(
vol7d),
INTENT(INOUT) :: this
1556TYPE(
vol7d),
INTENT(OUT) :: that
1557integer,
intent(in) :: time,ana,timerange,network
1559character(len=1) :: type
1561TYPE(vol7d_var) :: var
1562LOGICAL,
allocatable :: ltime(:),ltimerange(:),lana(:),lnetwork(:)
1563logical,
allocatable :: maschera(:)
1566allocate(ltime(
size(this%time)))
1567allocate(ltimerange(
size(this%timerange)))
1568allocate(lana(
size(this%ana)))
1569allocate(lnetwork(
size(this%network)))
1577ltimerange(timerange)=.true.
1579lnetwork(network)=.true.
1581call vol7d_copy(this, that,unique=.true.,&
1582 ltime=ltime,ltimerange=ltimerange,lana=lana,lnetwork=lnetwork )
1584call init(var, btable=
"B10004")
1587ind =
index(that%dativar, var, type=type)
1589allocate(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
1649deallocate(ltimerange)
1653END 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...