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
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, 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, frac_valid=1.0)
145 CALL vol7d_recompute_stat_proc_agg(this, that2, stat_proc_input, &
146 step, start=that1%time(1)+step/2, 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 == 2 .OR. stat_proc == 3))
THEN
160 CALL l4f_log(l4f_info, &
161 'recomputing statistically processed data by aggregation and difference '//&
164 IF (present(other))
THEN
165 CALL vol7d_recompute_stat_proc_agg(this, that1, stat_proc, &
166 step, start, frac_valid, other=other, stat_proc_input=stat_proc_input)
167 CALL vol7d_recompute_stat_proc_diff(this, that2, stat_proc, &
168 step, full_steps, other=other1)
169 CALL vol7d_merge(other, other1,
sort=.true.)
171 CALL vol7d_recompute_stat_proc_agg(this, that1, stat_proc, &
172 step, start, frac_valid, stat_proc_input=stat_proc_input)
173 CALL vol7d_recompute_stat_proc_diff(this, that2, stat_proc, step, full_steps)
176 CALL vol7d_merge(that1, that2,
sort=.true.)
180 IF ((stat_proc_input == 0 .AND. stat_proc == 1) .OR. &
181 (stat_proc_input == 1 .AND. stat_proc == 0))
THEN
182 CALL l4f_log(l4f_info, &
183 'computing statistically processed data by integration/differentiation '// &
184 t2c(stat_proc_input)//
':'//
t2c(stat_proc))
185 CALL vol7d_compute_stat_proc_metamorph(this, that, stat_proc_input, &
188 CALL l4f_log(l4f_error, &
189 'statistical processing '//
t2c(stat_proc_input)//
':'//
t2c(stat_proc)// &
190 ' not implemented or does not make sense')
195 END SUBROUTINE vol7d_compute_stat_proc
242 SUBROUTINE vol7d_recompute_stat_proc_agg(this, that, stat_proc, &
243 step, start, frac_valid, other, stat_proc_input)
244 TYPE(vol7d),
INTENT(inout) :: this
245 type(
vol7d),
INTENT(out) :: that
246 INTEGER,
INTENT(in) :: stat_proc
248 type(datetime),
INTENT(in),
OPTIONAL :: start
249 REAL,
INTENT(in),
OPTIONAL :: frac_valid
250 type(
vol7d),
INTENT(inout),
OPTIONAL :: other
251 INTEGER,
INTENT(in),
OPTIONAL :: stat_proc_input
254 INTEGER :: i, j, n, n1, ndtr, i1, i3, i5, i6
255 INTEGER :: linshape(1)
256 REAL :: lfrac_valid, frac_c, frac_m
257 LOGICAL,
ALLOCATABLE :: ttr_mask(:,:)
259 INTEGER,
POINTER :: dtratio(:)
262 IF (present(stat_proc_input))
THEN
263 tri = stat_proc_input
267 IF (present(frac_valid))
THEN
268 lfrac_valid = frac_valid
274 CALL vol7d_alloc_vol(this)
278 CALL vol7d_smart_sort(this, lsort_time=.true.)
279 CALL vol7d_reform(this, miss=.false.,
sort=.false., unique=.true.)
281 CALL
init(that, time_definition=this%time_definition)
282 CALL vol7d_alloc(that, nana=
SIZE(this%ana), nlevel=
SIZE(this%level), &
283 nnetwork=
SIZE(this%network))
284 IF (
ASSOCIATED(this%dativar%r))
THEN
285 CALL vol7d_alloc(that, ndativarr=
SIZE(this%dativar%r))
286 that%dativar%r = this%dativar%r
288 IF (
ASSOCIATED(this%dativar%d))
THEN
289 CALL vol7d_alloc(that, ndativard=
SIZE(this%dativar%d))
290 that%dativar%d = this%dativar%d
293 that%level = this%level
294 that%network = this%network
297 CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
298 step, this%time_definition, that%time, that%timerange, map_ttr, dtratio, start)
299 CALL vol7d_alloc_vol(that)
301 ALLOCATE(ttr_mask(
SIZE(this%time),
SIZE(this%timerange)))
302 linshape = (/
SIZE(ttr_mask)/)
304 IF (
ASSOCIATED(this%voldatir))
THEN
305 DO j = 1,
SIZE(that%timerange)
306 DO i = 1,
SIZE(that%time)
308 DO i1 = 1,
SIZE(this%ana)
309 DO i3 = 1,
SIZE(this%level)
310 DO i6 = 1,
SIZE(this%network)
311 DO i5 = 1,
SIZE(this%dativar%r)
314 DO n1 =
SIZE(dtratio), 1, -1
315 IF (dtratio(n1) <= 0) cycle
317 DO n = 1, map_ttr(i,j)%arraysize
318 IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1))
THEN
319 IF (
c_e(this%voldatir(i1,map_ttr(i,j)%array(n)%it,i3, &
320 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
321 ttr_mask(map_ttr(i,j)%array(n)%it, &
322 map_ttr(i,j)%array(n)%itr) = .true.
327 ndtr = count(ttr_mask)
328 frac_c =
REAL(ndtr)/
REAL(dtratio(n1))
330 IF (ndtr > 0 .AND. frac_c >= max(lfrac_valid, frac_m))
THEN
332 SELECT CASE(stat_proc)
334 that%voldatir(i1,i,i3,j,i5,i6) = &
335 sum(this%voldatir(i1,:,i3,:,i5,i6), &
338 that%voldatir(i1,i,i3,j,i5,i6) = &
339 sum(this%voldatir(i1,:,i3,:,i5,i6), &
342 that%voldatir(i1,i,i3,j,i5,i6) = &
343 maxval(this%voldatir(i1,:,i3,:,i5,i6), &
346 that%voldatir(i1,i,i3,j,i5,i6) = &
347 minval(this%voldatir(i1,:,i3,:,i5,i6), &
350 that%voldatir(i1,i,i3,j,i5,i6) = &
352 reshape(this%voldatir(i1,:,i3,:,i5,i6), shape=linshape), &
353 mask=reshape(ttr_mask, shape=linshape))
367 IF (
ASSOCIATED(this%voldatid))
THEN
368 DO j = 1,
SIZE(that%timerange)
369 DO i = 1,
SIZE(that%time)
371 DO i1 = 1,
SIZE(this%ana)
372 DO i3 = 1,
SIZE(this%level)
373 DO i6 = 1,
SIZE(this%network)
374 DO i5 = 1,
SIZE(this%dativar%d)
377 DO n1 =
SIZE(dtratio), 1, -1
378 IF (dtratio(n1) <= 0) cycle
380 DO n = 1, map_ttr(i,j)%arraysize
381 IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1))
THEN
382 IF (
c_e(this%voldatid(i1,map_ttr(i,j)%array(n)%it,i3, &
383 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
384 ttr_mask(map_ttr(i,j)%array(n)%it, &
385 map_ttr(i,j)%array(n)%itr) = .true.
390 ndtr = count(ttr_mask)
391 frac_c =
REAL(ndtr)/
REAL(dtratio(n1))
393 IF (ndtr > 0 .AND. frac_c >= max(lfrac_valid, frac_m))
THEN
395 SELECT CASE(stat_proc)
397 that%voldatid(i1,i,i3,j,i5,i6) = &
398 sum(this%voldatid(i1,:,i3,:,i5,i6), &
401 that%voldatid(i1,i,i3,j,i5,i6) = &
402 sum(this%voldatid(i1,:,i3,:,i5,i6), &
405 that%voldatid(i1,i,i3,j,i5,i6) = &
406 maxval(this%voldatid(i1,:,i3,:,i5,i6), &
409 that%voldatid(i1,i,i3,j,i5,i6) = &
410 minval(this%voldatid(i1,:,i3,:,i5,i6), &
413 that%voldatid(i1,i,i3,j,i5,i6) = &
415 reshape(this%voldatid(i1,:,i3,:,i5,i6), shape=linshape), &
416 mask=reshape(ttr_mask, shape=linshape))
436 SUBROUTINE makeother()
437 IF (present(other))
THEN
438 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
439 ltimerange=(this%timerange(:)%timerange /= tri .OR. this%timerange(:)%p2 == imiss &
440 .OR. this%timerange(:)%p2 == 0))
442 END SUBROUTINE makeother
444 END SUBROUTINE vol7d_recompute_stat_proc_agg
478 SUBROUTINE vol7d_compute_stat_proc_agg(this, that, stat_proc, &
479 step, start, max_step, weighted, other)
480 TYPE(vol7d),
INTENT(inout) :: this
481 type(
vol7d),
INTENT(out) :: that
482 INTEGER,
INTENT(in) :: stat_proc
484 type(datetime),
INTENT(in),
OPTIONAL :: start
485 type(
timedelta),
INTENT(in),
OPTIONAL :: max_step
486 LOGICAL,
INTENT(in),
OPTIONAL :: weighted
487 type(
vol7d),
INTENT(inout),
OPTIONAL :: other
490 TYPE(vol7d) :: v7dtmp
492 INTEGER :: i, j, n, ninp, ndtr, i1, i3, i5, i6, vartype, maxsize
493 TYPE(timedelta) :: lmax_step, act_max_step
494 TYPE(datetime
) :: pstart, pend, reftime
496 REAL,
ALLOCATABLE :: tmpvolr(:)
497 DOUBLE PRECISION,
ALLOCATABLE :: tmpvold(:), weights(:)
498 LOGICAL,
ALLOCATABLE :: lin_mask(:)
500 CHARACTER(len=8) :: env_var
502 IF (present(max_step))
THEN
505 lmax_step = timedelta_max
507 lweighted = optio_log(weighted)
511 CALL getenv(
'LIBSIM_CLIMAT_BEHAVIOR', env_var)
512 lweighted = lweighted .AND. len_trim(env_var) == 0
514 lweighted = lweighted .AND. stat_proc == 0
517 CALL vol7d_alloc_vol(this)
521 CALL vol7d_smart_sort(this, lsort_time=.true.)
522 CALL vol7d_reform(this, miss=.false.,
sort=.false., unique=.true.)
524 CALL vol7d_copy(this, v7dtmp, ltime=(/.false./), ltimerange=(/.false./))
527 CALL
init(that, time_definition=this%time_definition)
529 CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
530 step, this%time_definition, that%time, that%timerange, map_ttr, start=start)
532 CALL vol7d_merge(that, v7dtmp)
534 maxsize = maxval(map_ttr(:,:)%arraysize)
535 ALLOCATE(tmpvolr(maxsize), tmpvold(maxsize), lin_mask(maxsize), weights(maxsize))
536 do_otimerange:
DO j = 1,
SIZE(that%timerange)
537 do_otime:
DO i = 1,
SIZE(that%time)
538 ninp = map_ttr(i,j)%arraysize
539 IF (ninp <= 0) cycle do_otime
541 CALL time_timerange_get_period(that%time(i), that%timerange(j), &
542 that%time_definition, pstart, pend, reftime)
544 IF (
ASSOCIATED(this%voldatir))
THEN
545 DO i1 = 1,
SIZE(this%ana)
546 DO i3 = 1,
SIZE(this%level)
547 DO i6 = 1,
SIZE(this%network)
548 DO i5 = 1,
SIZE(this%dativar%r)
550 IF (stat_proc == 4)
THEN
552 IF (map_ttr(i,j)%array(1)%extra_info == 1 .AND. &
553 map_ttr(i,j)%array(n)%extra_info == 2)
THEN
554 IF (
c_e(this%voldatir(i1,map_ttr(i,j)%array(1)%it,i3, &
555 map_ttr(i,j)%array(1)%itr,i5,i6)) .AND. &
556 c_e(this%voldatir(i1,map_ttr(i,j)%array(ninp)%it,i3, &
557 map_ttr(i,j)%array(ninp)%itr,i5,i6)))
THEN
558 that%voldatir(i1,i,i3,j,i5,i6) = &
559 this%voldatir(i1,map_ttr(i,j)%array(ninp)%it,i3, &
560 map_ttr(i,j)%array(ninp)%itr,i5,i6) - &
561 this%voldatir(i1,map_ttr(i,j)%array(1)%it,i3, &
562 map_ttr(i,j)%array(1)%itr,i5,i6)
569 vartype = vol7d_vartype(this%dativar%r(i5))
573 IF (
c_e(this%voldatir(i1,map_ttr(i,j)%array(n)%it,i3, &
574 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
576 tmpvolr(ndtr) = this%voldatir(i1,map_ttr(i,j)%array(n)%it,i3, &
577 map_ttr(i,j)%array(n)%itr,i5,i6)
583 CALL compute_stat_proc_agg_sw(map_ttr(i,j)%array(1:ninp)%time, &
584 pstart, pend, lin_mask(1:ninp), act_max_step, weights)
586 CALL compute_stat_proc_agg_sw(map_ttr(i,j)%array(1:ninp)%time, &
587 pstart, pend, lin_mask(1:ninp), act_max_step)
589 IF (act_max_step > lmax_step) cycle
591 SELECT CASE(stat_proc)
594 that%voldatir(i1,i,i3,j,i5,i6) = &
595 sum(
REAL(weights(1:ndtr))*tmpvolr(1:ndtr))
597 that%voldatir(i1,i,i3,j,i5,i6) = &
598 sum(tmpvolr(1:ndtr))/ndtr
601 that%voldatir(i1,i,i3,j,i5,i6) = &
602 maxval(tmpvolr(1:ndtr))
604 that%voldatir(i1,i,i3,j,i5,i6) = &
605 minval(tmpvolr(1:ndtr))
607 that%voldatir(i1,i,i3,j,i5,i6) = &
611 IF (vartype == var_dir360)
THEN
613 WHERE (tmpvolr(1:ndtr) > 337.5)
614 tmpvolr(1:ndtr) = tmpvolr(1:ndtr) - 360.
616 that%voldatir(i1,i,i3,j,i5,i6) = &
627 IF (
ASSOCIATED(this%voldatid))
THEN
628 DO i1 = 1,
SIZE(this%ana)
629 DO i3 = 1,
SIZE(this%level)
630 DO i6 = 1,
SIZE(this%network)
631 DO i5 = 1,
SIZE(this%dativar%d)
633 IF (stat_proc == 4)
THEN
635 IF (map_ttr(i,j)%array(1)%extra_info == 1 .AND. &
636 map_ttr(i,j)%array(ninp)%extra_info == 2)
THEN
637 IF (
c_e(this%voldatid(i1,map_ttr(i,j)%array(1)%it,i3, &
638 map_ttr(i,j)%array(1)%itr,i5,i6)) .AND. &
639 c_e(this%voldatid(i1,map_ttr(i,j)%array(ninp)%it,i3, &
640 map_ttr(i,j)%array(ninp)%itr,i5,i6)))
THEN
641 that%voldatid(i1,i,i3,j,i5,i6) = &
642 this%voldatid(i1,map_ttr(i,j)%array(ninp)%it,i3, &
643 map_ttr(i,j)%array(ninp)%itr,i5,i6) - &
644 this%voldatid(i1,map_ttr(i,j)%array(1)%it,i3, &
645 map_ttr(i,j)%array(1)%itr,i5,i6)
652 vartype = vol7d_vartype(this%dativar%d(i5))
656 IF (
c_e(this%voldatid(i1,map_ttr(i,j)%array(n)%it,i3, &
657 map_ttr(i,j)%array(n)%itr,i5,i6)))
THEN
659 tmpvold(ndtr) = this%voldatid(i1,map_ttr(i,j)%array(n)%it,i3, &
660 map_ttr(i,j)%array(n)%itr,i5,i6)
666 CALL compute_stat_proc_agg_sw(map_ttr(i,j)%array(1:ninp)%time, &
667 pstart, pend, lin_mask(1:ninp), act_max_step, weights)
669 CALL compute_stat_proc_agg_sw(map_ttr(i,j)%array(1:ninp)%time, &
670 pstart, pend, lin_mask(1:ninp), act_max_step)
672 IF (act_max_step > lmax_step) cycle
674 SELECT CASE(stat_proc)
677 that%voldatid(i1,i,i3,j,i5,i6) = &
678 sum(
REAL(weights(1:ndtr))*tmpvold(1:ndtr))
680 that%voldatid(i1,i,i3,j,i5,i6) = &
681 sum(tmpvold(1:ndtr))/ndtr
684 that%voldatid(i1,i,i3,j,i5,i6) = &
685 maxval(tmpvold(1:ndtr))
687 that%voldatid(i1,i,i3,j,i5,i6) = &
688 minval(tmpvold(1:ndtr))
690 that%voldatid(i1,i,i3,j,i5,i6) = &
694 IF (vartype == var_dir360)
THEN
696 WHERE (tmpvold(1:ndtr) > 337.5)
697 tmpvold(1:ndtr) = tmpvold(1:ndtr) - 360.
699 that%voldatid(i1,i,i3,j,i5,i6) = &
715 DEALLOCATE(tmpvolr, tmpvold, lin_mask, weights)
717 IF (present(other))
THEN
718 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
719 ltimerange=(this%timerange(:)%timerange /= tri))
722 END SUBROUTINE vol7d_compute_stat_proc_agg
740 SUBROUTINE vol7d_decompute_stat_proc(this, that, step, other, stat_proc_input)
741 TYPE(vol7d),
INTENT(inout) :: this
742 type(
vol7d),
INTENT(out) :: that
744 type(
vol7d),
INTENT(inout),
OPTIONAL :: other
745 INTEGER,
INTENT(in),
OPTIONAL :: stat_proc_input
747 INTEGER :: i, tri, steps
750 IF (present(stat_proc_input))
THEN
751 tri = stat_proc_input
756 CALL vol7d_alloc_vol(this)
759 CALL
getval(step, asec=steps)
762 CALL vol7d_copy(this, that, miss=.false.,
sort=.false., unique=.false., &
763 ltimerange=(this%timerange(:)%timerange == tri .AND. &
764 this%timerange(:)%p1 == 0 .AND. this%timerange(:)%p2 == steps))
767 that%timerange(:)%timerange = 254
768 that%timerange(:)%p2 = 0
769 DO i = 1,
SIZE(that%time(:))
770 that%time(i) = that%time(i) - step/2
773 IF (present(other))
THEN
774 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
775 ltimerange=(this%timerange(:)%timerange /= tri .OR. &
776 this%timerange(:)%p1 /= 0 .OR. this%timerange(:)%p2 /= steps))
779 END SUBROUTINE vol7d_decompute_stat_proc
808 SUBROUTINE vol7d_recompute_stat_proc_diff(this, that, stat_proc, step, full_steps, other)
809 TYPE(vol7d),
INTENT(inout) :: this
810 type(
vol7d),
INTENT(out) :: that
811 INTEGER,
INTENT(in) :: stat_proc
813 LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
814 type(
vol7d),
INTENT(out),
OPTIONAL :: other
816 INTEGER :: i1, i3, i5, i6, i, j, k, l, nitr, steps
817 INTEGER,
POINTER :: map_tr(:,:,:,:,:), f(:)
818 LOGICAL,
POINTER :: mask_timerange(:)
819 LOGICAL,
ALLOCATABLE :: mask_time(:)
820 TYPE(vol7d) :: v7dtmp
824 CALL vol7d_alloc_vol(this)
826 CALL
init(that, time_definition=this%time_definition)
829 CALL
getval(step, asec=steps)
833 CALL recompute_stat_proc_diff_common(this%time, this%timerange, stat_proc, step, &
834 nitr, that%time, that%timerange, map_tr, f, mask_timerange, &
835 this%time_definition, full_steps)
838 CALL vol7d_alloc(that, nana=0, nlevel=0, nnetwork=0)
839 CALL vol7d_alloc_vol(that)
841 ALLOCATE(mask_time(
SIZE(this%time)))
842 DO l = 1,
SIZE(this%time)
843 mask_time(l) = any(this%time(l) == that%time(:))
849 CALL vol7d_copy(this, v7dtmp, miss=.false.,
sort=.false., unique=.false., &
850 ltimerange=mask_timerange(:), ltime=mask_time(:))
852 CALL vol7d_merge(that, v7dtmp, lanasimple=.true., llevelsimple=.true.)
853 DEALLOCATE(mask_time)
856 IF (
ASSOCIATED(this%voldatir))
THEN
857 DO l = 1,
SIZE(this%time)
859 DO j = 1,
SIZE(this%time)
861 IF (
c_e(map_tr(i,j,k,l,1)))
THEN
862 DO i6 = 1,
SIZE(this%network)
863 DO i5 = 1,
SIZE(this%dativar%r)
864 DO i3 = 1,
SIZE(this%level)
865 DO i1 = 1,
SIZE(this%ana)
866 IF (
c_e(this%voldatir(i1,l,i3,f(k),i5,i6)) .AND. &
867 c_e(this%voldatir(i1,j,i3,f(i),i5,i6)))
THEN
869 IF (stat_proc == 0)
THEN
871 i1,map_tr(i,j,k,l,1),i3,map_tr(i,j,k,l,2),i5,i6) = &
872 (this%voldatir(i1,l,i3,f(k),i5,i6)*this%timerange(f(k))%p2 - &
873 this%voldatir(i1,j,i3,f(i),i5,i6)*this%timerange(f(i))%p2)/ &
875 ELSE IF (stat_proc == 1 .OR. stat_proc == 4)
THEN
877 i1,map_tr(i,j,k,l,1),i3,map_tr(i,j,k,l,2),i5,i6) = &
878 this%voldatir(i1,l,i3,f(k),i5,i6) - &
879 this%voldatir(i1,j,i3,f(i),i5,i6)
894 IF (
ASSOCIATED(this%voldatid))
THEN
895 DO l = 1,
SIZE(this%time)
897 DO j = 1,
SIZE(this%time)
899 IF (
c_e(map_tr(i,j,k,l,1)))
THEN
900 DO i6 = 1,
SIZE(this%network)
901 DO i5 = 1,
SIZE(this%dativar%d)
902 DO i3 = 1,
SIZE(this%level)
903 DO i1 = 1,
SIZE(this%ana)
904 IF (
c_e(this%voldatid(i1,l,i3,f(k),i5,i6)) .AND. &
905 c_e(this%voldatid(i1,j,i3,f(i),i5,i6)))
THEN
909 IF (stat_proc == 0)
THEN
911 i1,map_tr(i,j,k,l,1),i3,map_tr(i,j,k,l,2),i5,i6) = &
912 (this%voldatid(i1,l,i3,f(k),i5,i6)*this%timerange(f(k))%p2 - &
913 this%voldatid(i1,j,i3,f(i),i5,i6)*this%timerange(f(i))%p2)/ &
915 ELSE IF (stat_proc == 1 .OR. stat_proc == 4)
THEN
917 i1,map_tr(i,j,k,l,1),i3,map_tr(i,j,k,l,2),i5,i6) = &
918 this%voldatid(i1,l,i3,f(k),i5,i6) - &
919 this%voldatid(i1,j,i3,f(i),i5,i6)
938 CALL vol7d_smart_sort(that, lsort_time=.true., lsort_timerange=.true.)
940 DEALLOCATE(map_tr, f, mask_timerange)
941 CALL makeother(.true.)
945 SUBROUTINE makeother(filter)
946 LOGICAL,
INTENT(in) :: filter
947 IF (present(other))
THEN
949 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false., &
950 ltimerange=(this%timerange(:)%timerange /= stat_proc))
952 CALL vol7d_copy(this, other, miss=.false.,
sort=.false., unique=.false.)
955 END SUBROUTINE makeother
957 END SUBROUTINE vol7d_recompute_stat_proc_diff
987 SUBROUTINE vol7d_compute_stat_proc_metamorph(this, that, stat_proc_input, stat_proc)
988 TYPE(vol7d),
INTENT(inout) :: this
989 type(
vol7d),
INTENT(out) :: that
990 INTEGER,
INTENT(in) :: stat_proc_input
991 INTEGER,
INTENT(in) :: stat_proc
994 LOGICAL,
ALLOCATABLE :: tr_mask(:)
995 REAL,
ALLOCATABLE :: int_ratio(:)
996 DOUBLE PRECISION,
ALLOCATABLE :: int_ratiod(:)
998 IF (.NOT.((stat_proc_input == 0 .AND. stat_proc == 1) .OR. &
999 (stat_proc_input == 1 .AND. stat_proc == 0)))
THEN
1001 CALL l4f_log(l4f_warn, &
1002 'compute_stat_proc_metamorph, can only be applied to average->accumulated timerange and viceversa')
1005 CALL vol7d_alloc_vol(that)
1010 CALL vol7d_alloc_vol(this)
1013 tr_mask = this%timerange(:)%timerange == stat_proc_input .AND. this%timerange(:)%p2 /= imiss &
1014 .AND. this%timerange(:)%p2 /= 0
1017 IF (count(tr_mask) == 0)
THEN
1018 CALL l4f_log(l4f_warn, &
1019 'vol7d_compute, no timeranges suitable for statistical processing by metamorphosis')
1026 CALL vol7d_copy(this, that, ltimerange=tr_mask)
1027 that%timerange(:)%timerange = stat_proc
1029 ALLOCATE(int_ratio(
SIZE(that%timerange)), int_ratiod(
SIZE(that%timerange)))
1031 IF (stat_proc == 0)
THEN
1032 int_ratio = 1./
REAL(that%timerange(:)%p2)
1033 int_ratiod = 1./dble(that%timerange(:)%p2)
1035 int_ratio =
REAL(that%timerange(:)%p2)
1036 int_ratiod = dble(that%timerange(:)%p2)
1039 IF (
ASSOCIATED(that%voldatir))
THEN
1040 DO j = 1,
SIZE(that%timerange)
1041 WHERE(
c_e(that%voldatir(:,:,:,j,:,:)))
1042 that%voldatir(:,:,:,j,:,:) = that%voldatir(:,:,:,j,:,:)*int_ratio(j)
1044 that%voldatir(:,:,:,j,:,:) = rmiss
1049 IF (
ASSOCIATED(that%voldatid))
THEN
1050 DO j = 1,
SIZE(that%timerange)
1051 WHERE(
c_e(that%voldatid(:,:,:,j,:,:)))
1052 that%voldatid(:,:,:,j,:,:) = that%voldatid(:,:,:,j,:,:)*int_ratiod(j)
1054 that%voldatid(:,:,:,j,:,:) = rmiss
1060 END SUBROUTINE vol7d_compute_stat_proc_metamorph
1079 SUBROUTINE vol7d_fill_time(this, that, step, start, stopp, cyclicdt)
1080 TYPE(vol7d),
INTENT(inout) :: this
1081 TYPE(vol7d),
INTENT(inout) :: that
1083 TYPE(datetime
),
INTENT(in),
OPTIONAL :: start
1084 TYPE(datetime
),
INTENT(in),
OPTIONAL :: stopp
1088 TYPE(datetime
) :: counter, lstart, lstop
1089 INTEGER :: i, naddtime
1091 CALL safe_start_stop(this, lstart, lstop, start, stopp)
1092 IF (.NOT.
c_e(lstart) .OR. .NOT.
c_e(lstop) .OR. .NOT.
c_e(step))
RETURN
1094 lcyclicdt=cyclicdatetime_miss
1095 if (present(cyclicdt))
then
1096 if(
c_e(cyclicdt)) lcyclicdt=cyclicdt
1099 CALL l4f_log(l4f_info,
'vol7d_fill_time: time interval '//trim(
to_char(lstart))// &
1107 naddcount:
DO WHILE(counter <= lstop)
1108 DO WHILE(i <=
SIZE(this%time))
1109 IF (counter < this%time(i))
THEN
1112 ELSE IF (counter == this%time(i) .OR. .NOT. counter == lcyclicdt)
THEN
1113 counter = counter + step
1118 naddtime = naddtime + 1
1119 counter = counter + step
1132 IF (naddtime > 0)
THEN
1135 CALL vol7d_alloc(that, ntime=naddtime)
1136 CALL vol7d_alloc_vol(that)
1142 naddadd:
DO WHILE(counter <= lstop)
1143 DO WHILE(i <=
SIZE(this%time))
1144 IF (counter < this%time(i))
THEN
1147 ELSE IF (counter == this%time(i) .OR. .NOT. counter == lcyclicdt)
THEN
1148 counter = counter + step
1153 naddtime = naddtime + 1
1154 that%time(naddtime) = counter
1155 counter = counter + step
1158 CALL vol7d_append(that, this,
sort=.true.)
1163 CALL vol7d_copy(this, that,
sort=.true.)
1167 END SUBROUTINE vol7d_fill_time
1181 SUBROUTINE vol7d_filter_time(this, that, step, start, stopp, cyclicdt)
1182 TYPE(vol7d),
INTENT(inout) :: this
1183 TYPE(vol7d),
INTENT(inout) :: that
1184 TYPE(timedelta),
INTENT(in),
optional :: step
1185 type(datetime),
INTENT(in),
OPTIONAL :: start
1186 TYPE(datetime
),
INTENT(in),
OPTIONAL :: stopp
1189 TYPE(datetime
) :: lstart, lstop
1190 LOGICAL,
ALLOCATABLE :: time_mask(:)
1192 CALL safe_start_stop(this, lstart, lstop, start, stopp)
1193 IF (.NOT.
c_e(lstart) .OR. .NOT.
c_e(lstop))
RETURN
1195 CALL l4f_log(l4f_info,
'vol7d_filter_time: time interval '//trim(
to_char(lstart))// &
1198 ALLOCATE(time_mask(
SIZE(this%time)))
1200 time_mask = this%time >= lstart .AND. this%time <= lstop
1202 IF (present(cyclicdt))
THEN
1203 IF (
c_e(cyclicdt))
THEN
1204 time_mask = time_mask .AND. this%time == cyclicdt
1208 IF (present(step))
THEN
1210 time_mask = time_mask .AND.
mod(this%time - lstart, step) == timedelta_0
1214 CALL vol7d_copy(this,that, ltime=time_mask)
1216 DEALLOCATE(time_mask)
1218 END SUBROUTINE vol7d_filter_time
1224 SUBROUTINE vol7d_fill_data(this, step, start, stopp, tolerance)
1225 TYPE(vol7d),
INTENT(inout) :: this
1227 type(datetime),
INTENT(in),
OPTIONAL :: start
1228 type(datetime),
INTENT(in),
OPTIONAL :: stopp
1229 type(
timedelta),
INTENT(in),
optional :: tolerance
1231 TYPE(datetime
) :: lstart, lstop
1232 integer :: indana , indtime ,indlevel ,indtimerange ,inddativarr, indnetwork, iindtime
1233 type(timedelta) :: deltato,deltat, ltolerance
1235 CALL safe_start_stop(this, lstart, lstop, start, stopp)
1236 IF (.NOT.
c_e(lstart) .OR. .NOT.
c_e(lstop))
RETURN
1238 CALL l4f_log(l4f_info,
'vol7d_fill_data: time interval '//trim(
to_char(lstart))// &
1244 if (present(tolerance))
then
1245 if (
c_e(tolerance)) ltolerance=tolerance
1249 do indtime=1,
size(this%time)
1251 IF (this%time(indtime) < lstart .OR. this%time(indtime) > lstop .OR. &
1252 mod(this%time(indtime) - lstart, step) /= timedelta_0) cycle
1253 do indtimerange=1,
size(this%timerange)
1254 if (this%timerange(indtimerange)%timerange /= 254) cycle
1255 do indnetwork=1,
size(this%network)
1256 do inddativarr=1,
size(this%dativar%r)
1257 do indlevel=1,
size(this%level)
1258 do indana=1,
size(this%ana)
1261 if (.not.
c_e(this%voldatir(indana, indtime, indlevel, indtimerange, inddativarr, indnetwork)))
then
1262 deltato=timedelta_miss
1266 do iindtime=indtime+1,
size(this%time)
1268 if (
c_e(this%voldatir (indana, iindtime, indlevel, indtimerange, inddativarr, indnetwork )))
then
1269 deltat=this%time(iindtime)-this%time(indtime)
1271 if (deltat >= ltolerance)
exit
1273 if (deltat < deltato)
then
1274 this%voldatir(indana, indtime, indlevel, indtimerange, inddativarr, indnetwork) = &
1275 this%voldatir(indana, iindtime, indlevel, indtimerange, inddativarr, indnetwork)
1281 do iindtime=indtime-1,1,-1
1283 if (
c_e(this%voldatir (indana, iindtime, indlevel, indtimerange, inddativarr, indnetwork )))
then
1284 if (iindtime < indtime)
then
1285 deltat=this%time(indtime)-this%time(iindtime)
1286 else if (iindtime > indtime)
then
1287 deltat=this%time(iindtime)-this%time(indtime)
1292 if (deltat >= ltolerance)
exit
1294 if (deltat < deltato)
then
1295 this%voldatir(indana, indtime, indlevel, indtimerange, inddativarr, indnetwork) = &
1296 this%voldatir(indana, iindtime, indlevel, indtimerange, inddativarr, indnetwork)
1310 END SUBROUTINE vol7d_fill_data
1316 SUBROUTINE safe_start_stop(this, lstart, lstop, start, stopp)
1317 TYPE(vol7d),
INTENT(inout) :: this
1318 TYPE(datetime
),
INTENT(out) :: lstart
1319 TYPE(datetime
),
INTENT(out) :: lstop
1320 TYPE(datetime
),
INTENT(in),
OPTIONAL :: start
1321 TYPE(datetime
),
INTENT(in),
OPTIONAL :: stopp
1323 lstart = datetime_miss
1324 lstop = datetime_miss
1326 CALL vol7d_alloc_vol(this)
1327 IF (
SIZE(this%time) == 0)
RETURN
1328 CALL vol7d_smart_sort(this, lsort_time=.true.)
1330 IF (present(start))
THEN
1331 IF (
c_e(start))
THEN
1334 lstart = this%time(1)
1337 lstart = this%time(1)
1339 IF (present(stopp))
THEN
1340 IF (
c_e(stopp))
THEN
1343 lstop = this%time(
SIZE(this%time))
1346 lstop = this%time(
SIZE(this%time))
1349 END SUBROUTINE safe_start_stop
1358 SUBROUTINE vol7d_normalize_vcoord(this,that,ana,time,timerange,network)
1359 TYPE(vol7d),
INTENT(INOUT) :: this
1360 type(
vol7d),
INTENT(OUT) :: that
1361 integer,
intent(in) :: time,ana,timerange,network
1363 character(len=1) :: type
1365 TYPE(vol7d_var
) :: var
1366 LOGICAL,
allocatable :: ltime(:),ltimerange(:),lana(:),lnetwork(:)
1367 logical,
allocatable :: maschera(:)
1370 allocate(ltime(
size(this%time)))
1371 allocate(ltimerange(
size(this%timerange)))
1372 allocate(lana(
size(this%ana)))
1373 allocate(lnetwork(
size(this%network)))
1381 ltimerange(timerange)=.true.
1383 lnetwork(network)=.true.
1385 call vol7d_copy(this, that,unique=.true.,&
1386 ltime=ltime,ltimerange=ltimerange,lana=lana,lnetwork=lnetwork )
1388 call
init(var, btable=
"B10004")
1391 ind =
index(that%dativar, var, type=type)
1393 allocate(maschera(
size(that%level)))
1396 (that%level%level1 == 105.and.that%level%level2 == 105) .or. &
1397 (that%level%level1 == 103 .and. that%level%level2 == imiss ) .or. &
1398 (that%level%level1 == 102 .and. that%level%level2 == imiss )) &
1399 .and.
c_e(that%voldatic(1,1,:,1,ind,1))
1407 that%level%level1 = 100
1408 that%level%l1 = int(
realdat(that%voldatid(1,1,:,1,ind,1),that%dativar%d(ind)))
1409 that%level%l1 = int(that%voldatid(1,1,:,1,ind,1))
1410 that%level%level2 = imiss
1411 that%level%l2 = imiss
1417 that%level%level1 = 100
1418 that%level%l1 = int(
realdat(that%voldatir(1,1,:,1,ind,1),that%dativar%r(ind)))
1419 that%level%level2 = imiss
1420 that%level%l2 = imiss
1426 that%level%level1 = 100
1427 that%level%l1 = int(
realdat(that%voldatii(1,1,:,1,ind,1),that%dativar%i(ind)))
1428 that%level%level2 = imiss
1429 that%level%l2 = imiss
1435 that%level%level1 = 100
1436 that%level%l1 = int(
realdat(that%voldatib(1,1,:,1,ind,1),that%dativar%b(ind)))
1437 that%level%level2 = imiss
1438 that%level%l2 = imiss
1444 that%level%level1 = 100
1445 that%level%l1 = int(
realdat(that%voldatic(1,1,:,1,ind,1),that%dativar%c(ind)))
1446 that%level%level2 = imiss
1447 that%level%l2 = imiss
1453 deallocate(ltimerange)
1455 deallocate(lnetwork)
1457 END SUBROUTINE vol7d_normalize_vcoord
Classi per la gestione delle coordinate temporali.
Functions that return a trimmed CHARACTER representation of the input variable.
Compute the mode of the random variable provided taking into account missing data.
Extension of vol7d_class with methods for performing simple statistical operations on entire volumes ...
Module for basic statistical computations taking into account missing data.
Compute the standard deviation of the random variable provided, taking into account missing data...
Classe per la gestione di un volume completo di dati osservati.
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.
Definisce un oggetto contenente i volumi anagrafica e dati e tutti i descrittori delle loro dimension...
Costruttori per le classi datetime e timedelta.
Class for expressing a relative time interval.
This module contains functions that are only for internal use of the library.
Class for expressing a cyclic datetime.
Derived type defining a dynamically extensible array of TYPE(ttr_mapper) elements.