33 INTEGER :: extra_info=imiss
34 TYPE(datetime) :: time=datetime_miss
37 INTERFACE OPERATOR (==)
38 MODULE PROCEDURE ttr_mapper_eq
41 INTERFACE OPERATOR (/=)
42 MODULE PROCEDURE ttr_mapper_ne
45 INTERFACE OPERATOR (>)
46 MODULE PROCEDURE ttr_mapper_gt
49 INTERFACE OPERATOR (<)
50 MODULE PROCEDURE ttr_mapper_lt
53 INTERFACE OPERATOR (>=)
54 MODULE PROCEDURE ttr_mapper_ge
57 INTERFACE OPERATOR (<=)
58 MODULE PROCEDURE ttr_mapper_le
61 #undef VOL7D_POLY_TYPE 62 #undef VOL7D_POLY_TYPES 64 #define VOL7D_POLY_TYPE TYPE(ttr_mapper) 65 #define VOL7D_POLY_TYPES _ttr_mapper 67 #include "array_utilities_pre.F90" 69 #define ARRAYOF_ORIGTYPE TYPE(ttr_mapper) 70 #define ARRAYOF_TYPE arrayof_ttr_mapper 71 #define ARRAYOF_ORIGEQ 1 72 #define ARRAYOF_ORIGGT 1 73 #include "arrayof_pre.F90" 80 ELEMENTAL FUNCTION ttr_mapper_eq(this, that)
RESULT(res)
81 TYPE(ttr_mapper),
INTENT(IN) :: this, that
84 res = this%time == that%time
86 END FUNCTION ttr_mapper_eq
88 ELEMENTAL FUNCTION ttr_mapper_ne(this, that)
RESULT(res)
89 TYPE(ttr_mapper),
INTENT(IN) :: this, that
92 res = this%time /= that%time
94 END FUNCTION ttr_mapper_ne
96 ELEMENTAL FUNCTION ttr_mapper_gt(this, that)
RESULT(res)
97 TYPE(ttr_mapper),
INTENT(IN) :: this, that
100 res = this%time > that%time
102 END FUNCTION ttr_mapper_gt
104 ELEMENTAL FUNCTION ttr_mapper_lt(this, that)
RESULT(res)
105 TYPE(ttr_mapper),
INTENT(IN) :: this, that
108 res = this%time < that%time
110 END FUNCTION ttr_mapper_lt
112 ELEMENTAL FUNCTION ttr_mapper_ge(this, that)
RESULT(res)
113 TYPE(ttr_mapper),
INTENT(IN) :: this, that
116 res = this%time >= that%time
118 END FUNCTION ttr_mapper_ge
120 ELEMENTAL FUNCTION ttr_mapper_le(this, that)
RESULT(res)
121 TYPE(ttr_mapper),
INTENT(IN) :: this, that
124 res = this%time <= that%time
126 END FUNCTION ttr_mapper_le
128 #include "arrayof_post.F90" 129 #include "array_utilities_inc.F90" 133 SUBROUTINE recompute_stat_proc_diff_common(itime, itimerange, stat_proc, step, &
134 nitr, otime, otimerange, map_tr, f, mask_timerange, time_definition, full_steps, &
136 TYPE(datetime),
INTENT(in) :: itime(:)
137 TYPE(vol7d_timerange),
INTENT(in) :: itimerange(:)
138 INTEGER,
INTENT(in) :: stat_proc
139 TYPE(timedelta),
INTENT(in) :: step
140 INTEGER,
INTENT(out) :: nitr
141 TYPE(datetime),
POINTER :: otime(:)
142 TYPE(vol7d_timerange),
POINTER :: otimerange(:)
143 INTEGER,
POINTER :: map_tr(:,:,:,:,:), f(:)
144 LOGICAL,
POINTER :: mask_timerange(:)
145 INTEGER,
INTENT(in) :: time_definition
146 LOGICAL,
INTENT(in),
OPTIONAL :: full_steps
147 TYPE(datetime),
INTENT(in),
OPTIONAL :: start
149 INTEGER :: i, j, k, l, dirtyrep
150 INTEGER :: steps, deltas
152 TYPE(datetime) :: pstart1, pstart2, pend1, pend2, reftime1, reftime2, tmptime
153 TYPE(vol7d_timerange) :: tmptimerange
154 TYPE(arrayof_datetime) :: a_otime
155 TYPE(arrayof_vol7d_timerange) :: a_otimerange
158 CALL getval(step, asec=steps)
161 IF (
PRESENT(start))
THEN 162 IF (
SIZE(itime) > 1 .AND.
c_e(start))
THEN 163 CALL getval(start-itime(1), asec=deltas)
168 ALLOCATE(mask_timerange(
SIZE(itimerange)))
169 mask_timerange(:) = itimerange(:)%timerange == stat_proc &
170 .AND. itimerange(:)%p1 /= imiss .AND. itimerange(:)%p2 /= imiss &
171 .AND. itimerange(:)%p1 >= 0 &
172 .AND. itimerange(:)%p2 > 0
174 IF (optio_log(full_steps) .AND. steps /= 0)
THEN 175 mask_timerange(:) = mask_timerange(:) .AND. (
mod(itimerange(:)%p2-deltas, steps) == 0)
177 nitr = count(mask_timerange)
181 DO WHILE(.NOT.mask_timerange(j))
188 ALLOCATE(map_tr(nitr,
SIZE(itime), nitr,
SIZE(itime), 2))
189 map_tr(:,:,:,:,:) = imiss
191 mask_timerange(:) = mask_timerange(:) .AND. itimerange(:)%p2 == steps
192 DO i = 1,
SIZE(mask_timerange)
193 IF (mask_timerange(i))
THEN 194 j = append_unique(a_otimerange, itimerange(i))
200 IF (dirtyrep == 2)
THEN 203 CALL sort(a_otime%array)
204 CALL sort(a_otimerange%array)
206 DO l = 1,
SIZE(itime)
208 CALL time_timerange_get_period(itime(l), itimerange(f(k)), &
209 time_definition, pstart2, pend2, reftime2)
211 DO j = 1,
SIZE(itime)
214 CALL time_timerange_get_period(itime(j), itimerange(f(i)), &
215 time_definition, pstart1, pend1, reftime1)
216 tmptimerange = vol7d_timerange_new(timerange=stat_proc)
218 IF (reftime2 == pend2 .AND. reftime1 == pend1)
THEN 219 IF (pstart2 == pstart1 .AND. pend2 > pend1)
THEN 220 CALL time_timerange_set_period(tmptime, tmptimerange, &
221 time_definition, pend1, pend2, reftime2)
224 ELSE IF (pstart2 < pstart1 .AND. pend2 == pend1)
THEN 225 CALL time_timerange_set_period(tmptime, tmptimerange, &
226 time_definition, pstart2, pstart1, pstart1)
230 ELSE IF (reftime2 == reftime1)
THEN 231 IF (pstart2 == pstart1 .AND. pend2 > pend1)
THEN 232 CALL time_timerange_set_period(tmptime, tmptimerange, &
233 time_definition, pend1, pend2, reftime2)
236 ELSE IF (pstart2 < pstart1 .AND. pend2 == pend1)
THEN 237 CALL time_timerange_set_period(tmptime, tmptimerange, &
238 time_definition, pstart2, pstart1, reftime2)
243 useful = useful .AND. tmptime /= datetime_miss .AND. &
244 tmptimerange /= vol7d_timerange_miss .AND. tmptimerange%p2 == steps
247 map_tr(i,j,k,l,1) = append_unique(a_otime, tmptime)
248 map_tr(i,j,k,l,2) = append_unique(a_otimerange, tmptimerange)
256 otime => a_otime%array
257 otimerange => a_otimerange%array
259 CALL delete(a_otime, nodealloc=.true.)
260 CALL delete(a_otimerange, nodealloc=.true.)
262 mask_timerange(:) = mask_timerange(:) .AND. itimerange(:)%p2 == steps
265 CALL l4f_log(l4f_debug, &
266 'recompute_stat_proc_diff, map_tr: '//
t2c((
SIZE(map_tr,1)))//
', '// &
267 t2c((
SIZE(map_tr,2)))//
', '// &
268 t2c((
SIZE(map_tr,3)))//
', '// &
269 t2c((
SIZE(map_tr,4))))
270 CALL l4f_log(l4f_debug, &
271 'recompute_stat_proc_diff, map_tr: '//
t2c((
SIZE(map_tr)))//
', '// &
273 CALL l4f_log(l4f_debug, &
274 'recompute_stat_proc_diff, nitr: '//
t2c(nitr))
275 CALL l4f_log(l4f_debug, &
276 'recompute_stat_proc_diff, good timeranges: '//
t2c(count(mask_timerange)))
277 CALL l4f_log(l4f_debug, &
278 'recompute_stat_proc_diff, output times: '//
t2c(
SIZE(otime)))
279 CALL l4f_log(l4f_debug, &
280 'recompute_stat_proc_diff, output timeranges: '//
t2c(
SIZE(otimerange)))
283 END SUBROUTINE recompute_stat_proc_diff_common
287 SUBROUTINE compute_stat_proc_metamorph_common(istat_proc, itimerange, ostat_proc, &
289 INTEGER,
INTENT(in) :: istat_proc
290 TYPE(vol7d_timerange),
INTENT(in) :: itimerange(:)
291 INTEGER,
INTENT(in) :: ostat_proc
293 TYPE(vol7d_timerange),
POINTER :: otimerange(:)
294 INTEGER,
POINTER :: map_tr(:)
297 LOGICAL :: tr_mask(SIZE(itimerange))
299 IF (
SIZE(itimerange) == 0)
THEN 300 ALLOCATE(otimerange(0), map_tr(0))
305 tr_mask(:) = itimerange(:)%timerange == istat_proc .AND. itimerange(:)%p2 /= imiss &
306 .AND. itimerange(:)%p2 /= 0
307 ALLOCATE(otimerange(count(tr_mask)), map_tr(count(tr_mask)))
309 otimerange = pack(itimerange, mask=tr_mask)
310 otimerange(:)%timerange = ostat_proc
311 map_tr = pack((/(i,i=1,
SIZE(itimerange))/), mask=tr_mask)
313 END SUBROUTINE compute_stat_proc_metamorph_common
317 SUBROUTINE recompute_stat_proc_agg_common(itime, itimerange, stat_proc, tri, &
318 step, time_definition, otime, otimerange, map_ttr, dtratio, start)
319 TYPE(datetime),
INTENT(in) :: itime(:)
320 TYPE(vol7d_timerange),
INTENT(in) :: itimerange(:)
321 INTEGER,
INTENT(in) :: stat_proc
322 INTEGER,
INTENT(in) :: tri
323 TYPE(timedelta),
INTENT(in) :: step
324 INTEGER,
INTENT(in) :: time_definition
325 TYPE(datetime),
POINTER :: otime(:)
326 TYPE(vol7d_timerange),
POINTER :: otimerange(:)
327 TYPE(arrayof_ttr_mapper),
POINTER :: map_ttr(:,:)
328 INTEGER,
POINTER,
OPTIONAL :: dtratio(:)
329 TYPE(datetime),
INTENT(in),
OPTIONAL :: start
331 INTEGER :: i, j, k, l, na, nf, n
332 INTEGER :: steps, p1, maxp1, maxp2, minp1mp2, dstart
334 TYPE(datetime) :: lstart, lend, pstart1, pstart2, pend1, pend2, reftime1, reftime2, tmptime
335 TYPE(arrayof_datetime) :: a_otime
336 TYPE(arrayof_vol7d_timerange) :: a_otimerange
337 TYPE(arrayof_integer) :: a_dtratio
338 LOGICAL,
ALLOCATABLE :: mask_timerange(:)
339 TYPE(ttr_mapper) :: lmapper
340 CHARACTER(len=8) :: env_var
341 LOGICAL :: climat_behavior
346 CALL getenv(
'LIBSIM_CLIMAT_BEHAVIOR', env_var)
347 climat_behavior = len_trim(env_var) > 0 .AND. .NOT.
PRESENT(dtratio)
350 CALL getval(timedelta_depop(step), asec=steps)
353 ALLOCATE(mask_timerange(
SIZE(itimerange)))
354 mask_timerange(:) = itimerange(:)%timerange == tri &
355 .AND. itimerange(:)%p1 /= imiss .AND. itimerange(:)%p1 >= 0
357 IF (
PRESENT(dtratio))
THEN 358 mask_timerange(:) = mask_timerange(:) .AND. itimerange(:)%p2 /= imiss &
359 .AND. itimerange(:)%p2 > 0 .AND.
mod(steps, itimerange(:)%p2) == 0
361 mask_timerange(:) = mask_timerange(:) .AND. itimerange(:)%p2 == 0
365 CALL l4f_log(l4f_debug, &
366 '(re)compute_stat_proc_agg, number of useful timeranges before choosing analysis/forecast: '// &
367 t2c(count(mask_timerange)))
372 na = count(mask_timerange(:) .AND. itimerange(:)%p1 == 0)
373 nf = count(mask_timerange(:) .AND. itimerange(:)%p1 > 0)
376 CALL l4f_log(l4f_debug, &
377 'recompute_stat_proc_agg, na: '//
t2c(na)//
', nf: '//
t2c(nf))
382 CALL l4f_log(l4f_info, &
383 'recompute_stat_proc_agg, processing in forecast mode')
385 mask_timerange(:) = mask_timerange(:) .AND. itimerange(:)%p1 == 0
386 CALL l4f_log(l4f_info, &
387 'recompute_stat_proc_agg, processing in analysis mode')
391 CALL l4f_log(l4f_debug, &
392 '(re)compute_stat_proc_agg, number of useful timeranges: '// &
393 t2c(count(mask_timerange)))
396 IF (
SIZE(itime) == 0 .OR. count(mask_timerange) == 0)
THEN 397 ALLOCATE(otime(0), otimerange(0), map_ttr(0,0))
398 IF (
PRESENT(dtratio))
ALLOCATE(dtratio(0))
403 lstart = datetime_miss
404 IF (
PRESENT(start)) lstart = start
405 lend = itime(
SIZE(itime))
407 maxp1 = maxval(itimerange(:)%p1, mask=mask_timerange)
408 maxp2 = maxval(itimerange(:)%p2, mask=mask_timerange)
409 minp1mp2 = minval(itimerange(:)%p1 - itimerange(:)%p2, mask=mask_timerange)
410 IF (time_definition == 0)
THEN 411 lend = lend + timedelta_new(sec=maxp1)
416 IF (lstart == datetime_miss)
THEN 419 IF (time_definition == 0)
THEN 420 lstart = lstart + timedelta_new(sec=minp1mp2)
423 lstart = lstart - timedelta_new(sec=maxp2)
429 CALL l4f_log(l4f_debug, &
430 'recompute_stat_proc_agg, processing period: '//
t2c(lstart)//
' - '//
t2c(lend))
436 IF (time_definition == 0)
THEN 437 CALL insert(a_otime, itime)
442 CALL getval(lstart-itime(1), asec=dstart)
445 IF (dstart < 0) dstart =
mod(dstart, steps)
446 DO p1 = steps + dstart, maxp1, steps
447 CALL insert_unique(a_otimerange, vol7d_timerange_new(stat_proc, p1, steps))
451 tmptime = lstart + step
452 DO WHILE(tmptime < lend)
453 CALL insert_unique(a_otime, tmptime)
454 tmptime = tmptime + step
456 DO p1 = steps, maxp1, steps
457 CALL insert_unique(a_otimerange, vol7d_timerange_new(stat_proc, p1, steps))
463 tmptime = lstart + step
464 DO WHILE(tmptime < lend)
465 CALL insert_unique(a_otime, tmptime)
466 tmptime = tmptime + step
468 CALL insert_unique(a_otimerange, vol7d_timerange_new(stat_proc, 0, steps))
474 otime => a_otime%array
475 otimerange => a_otimerange%array
477 CALL sort(otimerange)
479 CALL delete(a_otime, nodealloc=.true.)
480 CALL delete(a_otimerange, nodealloc=.true.)
483 CALL l4f_log(l4f_debug, &
484 'recompute_stat_proc_agg, output time and timerange: '//&
485 t2c(
SIZE(otime))//
', '//
t2c(
size(otimerange)))
488 IF (
PRESENT(dtratio))
THEN 490 DO k = 1,
SIZE(itimerange)
491 IF (itimerange(k)%p2 /= 0) &
492 CALL insert_unique(a_dtratio, steps/itimerange(k)%p2)
495 dtratio => a_dtratio%array
498 CALL delete(a_dtratio, nodealloc=.true.)
501 CALL l4f_log(l4f_debug, &
502 'recompute_stat_proc_agg, found '//
t2c(
size(dtratio))// &
503 ' possible aggregation ratios, from '// &
504 t2c(dtratio(1))//
' to '//
t2c(dtratio(
SIZE(dtratio))))
507 ALLOCATE(map_ttr(
SIZE(otime),
SIZE(otimerange)))
508 do_itimerange1:
DO l = 1,
SIZE(itimerange)
509 IF (.NOT.mask_timerange(l)) cycle do_itimerange1
510 do_itime1:
DO k = 1,
SIZE(itime)
511 CALL time_timerange_get_period(itime(k), itimerange(l), &
512 time_definition, pstart1, pend1, reftime1)
513 do_otimerange1:
DO j = 1,
SIZE(otimerange)
514 do_otime1:
DO i = 1,
SIZE(otime)
515 CALL time_timerange_get_period_pop(otime(i), otimerange(j), step, &
516 time_definition, pstart2, pend2, reftime2)
518 IF (reftime1 /= reftime2) cycle do_otime1
521 IF (pstart1 >= pstart2 .AND. pend1 <= pend2 .AND. &
522 mod(pstart1-pstart2, pend1-pstart1) == timedelta_0)
THEN 525 lmapper%extra_info = steps/itimerange(l)%p2
526 n =
append(map_ttr(i,j), lmapper)
536 ALLOCATE(map_ttr(
SIZE(otime),
SIZE(otimerange)))
537 do_itimerange2:
DO l = 1,
SIZE(itimerange)
538 IF (.NOT.mask_timerange(l)) cycle do_itimerange2
539 do_itime2:
DO k = 1,
SIZE(itime)
540 CALL time_timerange_get_period(itime(k), itimerange(l), &
541 time_definition, pstart1, pend1, reftime1)
542 do_otimerange2:
DO j = 1,
SIZE(otimerange)
543 do_otime2:
DO i = 1,
SIZE(otime)
544 CALL time_timerange_get_period_pop(otime(i), otimerange(j), step, &
545 time_definition, pstart2, pend2, reftime2)
547 IF (reftime1 /= reftime2) cycle do_otime2
550 IF (climat_behavior .AND. pstart1 == pstart2) cycle do_otime2
551 IF (pstart1 >= pstart2 .AND. pend1 <= pend2)
THEN 554 IF (pstart1 == pstart2)
THEN 555 lmapper%extra_info = 1
556 ELSE IF (pend1 == pend2)
THEN 557 lmapper%extra_info = 2
559 lmapper%extra_info = imiss
561 lmapper%time = pstart1
562 n = insert_sorted(map_ttr(i,j), lmapper, .true., .true.)
572 END SUBROUTINE recompute_stat_proc_agg_common
575 SUBROUTINE compute_stat_proc_agg_sw(vertime, pstart, pend, time_mask, &
577 TYPE(
datetime),
INTENT(in) :: vertime(:)
580 LOGICAL,
INTENT(in) :: time_mask(:)
581 TYPE(
timedelta),
OPTIONAL,
INTENT(out) :: max_step
582 DOUBLE PRECISION,
OPTIONAL,
INTENT(out) :: weights(:)
585 TYPE(
datetime),
ALLOCATABLE :: lvertime(:)
587 INTEGER(kind=int_ll) :: dt, tdt
589 nt = count(time_mask)
590 ALLOCATE(lvertime(nt))
591 lvertime = pack(vertime, mask=time_mask)
593 IF (
PRESENT(max_step))
THEN 604 max_step = pend - pstart
606 half = lvertime(1) + (lvertime(2) - lvertime(1))/2
607 max_step = half - pstart
609 nexthalf = lvertime(i) + (lvertime(i+1) - lvertime(i))/2
610 IF (nexthalf - half > max_step) max_step = nexthalf - half
613 IF (pend - half > max_step) max_step = pend - half
618 IF (
PRESENT(weights))
THEN 622 CALL getval(pend - pstart, amsec=tdt)
623 half = lvertime(1) + (lvertime(2) - lvertime(1))/2
624 CALL getval(half - pstart, amsec=dt)
625 weights(1) = dble(dt)/dble(tdt)
627 nexthalf = lvertime(i) + (lvertime(i+1) - lvertime(i))/2
629 weights(i) = dble(dt)/dble(tdt)
632 CALL getval(pend - half, amsec=dt)
633 weights(nt) = dble(dt)/dble(tdt)
637 END SUBROUTINE compute_stat_proc_agg_sw
641 SUBROUTINE time_timerange_get_period(time, timerange, time_definition, &
642 pstart, pend, reftime)
644 TYPE(vol7d_timerange),
INTENT(in) :: timerange
645 INTEGER,
INTENT(in) :: time_definition
646 TYPE(
datetime),
INTENT(out) :: reftime
647 TYPE(
datetime),
INTENT(out) :: pstart
653 p1 = timedelta_new(sec=timerange%p1)
654 p2 = timedelta_new(sec=timerange%p2)
656 IF (time == datetime_miss .OR. .NOT.
c_e(timerange%p1) .OR. .NOT.
c_e(timerange%p2) .OR. &
658 timerange%p1 < 0 .OR. timerange%p2 < 0)
THEN 659 pstart = datetime_miss
661 reftime = datetime_miss
665 IF (time_definition == 0)
THEN 669 ELSE IF (time_definition == 1)
THEN 674 pstart = datetime_miss
676 reftime = datetime_miss
679 END SUBROUTINE time_timerange_get_period
685 SUBROUTINE time_timerange_get_period_pop(time, timerange, step, time_definition, &
686 pstart, pend, reftime)
688 TYPE(vol7d_timerange),
INTENT(in) :: timerange
690 INTEGER,
INTENT(in) :: time_definition
691 TYPE(
datetime),
INTENT(out) :: reftime
692 TYPE(
datetime),
INTENT(out) :: pstart
698 p1 = timedelta_new(sec=timerange%p1)
700 IF (time == datetime_miss .OR. .NOT.
c_e(timerange%p1) .OR. .NOT.
c_e(timerange%p2) .OR. &
702 timerange%p1 < 0 .OR. timerange%p2 < 0)
THEN 703 pstart = datetime_miss
705 reftime = datetime_miss
709 IF (time_definition == 0)
THEN 713 ELSE IF (time_definition == 1)
THEN 718 pstart = datetime_miss
720 reftime = datetime_miss
723 END SUBROUTINE time_timerange_get_period_pop
728 SUBROUTINE time_timerange_set_period(time, timerange, time_definition, &
729 pstart, pend, reftime)
731 TYPE(vol7d_timerange),
INTENT(inout) :: timerange
732 INTEGER,
INTENT(in) :: time_definition
733 TYPE(
datetime),
INTENT(in) :: reftime
738 INTEGER(kind=int_ll) :: dmsec
741 IF (time_definition == 0)
THEN 745 ELSE IF (time_definition == 1)
THEN 753 IF (time /= datetime_miss)
THEN 754 CALL getval(p1, amsec=dmsec)
755 timerange%p1 = int(dmsec/1000_int_ll)
756 CALL getval(p2, amsec=dmsec)
757 timerange%p2 = int(dmsec/1000_int_ll)
763 END SUBROUTINE time_timerange_set_period
Functions that return a trimmed CHARACTER representation of the input variable.
Class for expressing an absolute time value.
This module contains functions that are only for internal use of the library.
Classi per la gestione delle coordinate temporali.
Quick method to append an element to the array.
Method for packing the array object reducing at a minimum the memory occupation, without destroying i...
Restituiscono il valore dell'oggetto nella forma desiderata.
Operatore di resto della divisione.
Classe per la gestione di un volume completo di dati osservati.
Class for expressing a relative time interval.
Destructor for finalizing an array object.
Method for inserting elements of the array at a desired position.