libsim Versione 7.1.11
datetime_class.F90
1! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2! authors:
3! Davide Cesari <dcesari@arpa.emr.it>
4! Paolo Patruno <ppatruno@arpa.emr.it>
5
6! This program is free software; you can redistribute it and/or
7! modify it under the terms of the GNU General Public License as
8! published by the Free Software Foundation; either version 2 of
9! the License, or (at your option) any later version.
10
11! This program is distributed in the hope that it will be useful,
12! but WITHOUT ANY WARRANTY; without even the implied warranty of
13! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14! GNU General Public License for more details.
15
16! You should have received a copy of the GNU General Public License
17! along with this program. If not, see <http://www.gnu.org/licenses/>.
18#include "config.h"
19
33MODULE datetime_class
34USE kinds
40IMPLICIT NONE
41
42INTEGER, PARAMETER :: dateint=selected_int_kind(13)
43
45TYPE datetime
46 PRIVATE
47 INTEGER(KIND=int_ll) :: iminuti
48END TYPE datetime
49
57TYPE timedelta
58 PRIVATE
59 INTEGER(KIND=int_ll) :: iminuti
60 INTEGER :: month
61END TYPE timedelta
62
63
68 PRIVATE
69 INTEGER :: minute
70 INTEGER :: hour
71 INTEGER :: day
72 INTEGER :: tendaysp
73 INTEGER :: month
74END TYPE cyclicdatetime
75
76
78TYPE(datetime), PARAMETER :: datetime_miss=datetime(illmiss)
80TYPE(timedelta), PARAMETER :: timedelta_miss=timedelta(illmiss, 0)
82TYPE(timedelta), PARAMETER :: timedelta_0=timedelta(0, 0)
84INTEGER, PARAMETER :: datetime_utc=1
86INTEGER, PARAMETER :: datetime_local=2
88TYPE(datetime), PARAMETER :: datetime_min=datetime(-huge(1_int_ll)-1)
90TYPE(datetime), PARAMETER :: datetime_max=datetime(huge(1_int_ll)-1)
92TYPE(timedelta), PARAMETER :: timedelta_min=timedelta(-huge(1_int_ll)-1,0)
94TYPE(timedelta), PARAMETER :: timedelta_max=timedelta(huge(1_int_ll)-1,0)
96TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
97
98
99INTEGER(kind=dateint), PARAMETER :: &
100 sec_in_day=86400, &
101 sec_in_hour=3600, &
102 sec_in_min=60, &
103 min_in_day=1440, &
104 min_in_hour=60, &
105 hour_in_day=24
106
107INTEGER,PARAMETER :: &
108 year0=1, & ! anno di origine per iminuti
109 d1=365, & ! giorni/1 anno nel calendario gregoriano
110 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
111 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
112 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
113 ianno(13,2)=reshape((/ &
114 0,31,59,90,120,151,181,212,243,273,304,334,365, &
115 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
116
117INTEGER(KIND=int_ll),PARAMETER :: &
118 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
119
123INTERFACE init
124 MODULE PROCEDURE datetime_init, timedelta_init
125END INTERFACE
126
129INTERFACE delete
130 MODULE PROCEDURE datetime_delete, timedelta_delete
131END INTERFACE
132
134INTERFACE getval
135 MODULE PROCEDURE datetime_getval, timedelta_getval
136END INTERFACE
137
139INTERFACE to_char
140 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
141END INTERFACE
142
143
161INTERFACE t2c
162 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
163END INTERFACE
164
170INTERFACE OPERATOR (==)
171 MODULE PROCEDURE datetime_eq, timedelta_eq, &
172 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
173END INTERFACE
174
180INTERFACE OPERATOR (/=)
181 MODULE PROCEDURE datetime_ne, timedelta_ne
182END INTERFACE
183
191INTERFACE OPERATOR (>)
192 MODULE PROCEDURE datetime_gt, timedelta_gt
193END INTERFACE
194
202INTERFACE OPERATOR (<)
203 MODULE PROCEDURE datetime_lt, timedelta_lt
204END INTERFACE
205
213INTERFACE OPERATOR (>=)
214 MODULE PROCEDURE datetime_ge, timedelta_ge
215END INTERFACE
216
224INTERFACE OPERATOR (<=)
225 MODULE PROCEDURE datetime_le, timedelta_le
226END INTERFACE
234INTERFACE OPERATOR (+)
235 MODULE PROCEDURE datetime_add, timedelta_add
236END INTERFACE
237
245INTERFACE OPERATOR (-)
246 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
247END INTERFACE
248
254INTERFACE OPERATOR (*)
255 MODULE PROCEDURE timedelta_mult, timedelta_tlum
256END INTERFACE
257
264INTERFACE OPERATOR (/)
265 MODULE PROCEDURE timedelta_divint, timedelta_divtd
266END INTERFACE
267
278INTERFACE mod
279 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
280END INTERFACE
281
284INTERFACE abs
285 MODULE PROCEDURE timedelta_abs
286END INTERFACE
287
290INTERFACE read_unit
291 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
292 timedelta_read_unit, timedelta_vect_read_unit
293END INTERFACE
294
297INTERFACE write_unit
298 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
299 timedelta_write_unit, timedelta_vect_write_unit
300END INTERFACE
301
303INTERFACE display
304 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
305END INTERFACE
306
308INTERFACE c_e
309 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
310END INTERFACE
311
312#undef VOL7D_POLY_TYPE
313#undef VOL7D_POLY_TYPES
314#undef ENABLE_SORT
315#define VOL7D_POLY_TYPE TYPE(datetime)
316#define VOL7D_POLY_TYPES _datetime
317#define ENABLE_SORT
318#include "array_utilities_pre.F90"
319
320
321#define ARRAYOF_ORIGTYPE TYPE(datetime)
322#define ARRAYOF_TYPE arrayof_datetime
323#define ARRAYOF_ORIGEQ 1
324#include "arrayof_pre.F90"
325! from arrayof
326
327PRIVATE
329PUBLIC datetime, datetime_miss, datetime_utc, datetime_local, &
330 datetime_min, datetime_max, &
331 datetime_new, datetime_new_now, init, delete, getval, to_char, t2c, &
333 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
334 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
335 OPERATOR(*), OPERATOR(/), mod, abs, &
336 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
337 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
338 display, c_e, &
339 count_distinct, pack_distinct, &
340 count_distinct_sorted, pack_distinct_sorted, &
341 count_and_pack_distinct, &
342 map_distinct, map_inv_distinct, index, index_sorted, sort, &
343 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
345PUBLIC insert_unique, append_unique
346PUBLIC cyclicdatetime_to_conventional
347
348CONTAINS
349
350
351! ==============
352! == datetime ==
353! ==============
354
361ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
362 unixtime, isodate, simpledate) RESULT(this)
363INTEGER,INTENT(IN),OPTIONAL :: year
364INTEGER,INTENT(IN),OPTIONAL :: month
365INTEGER,INTENT(IN),OPTIONAL :: day
366INTEGER,INTENT(IN),OPTIONAL :: hour
367INTEGER,INTENT(IN),OPTIONAL :: minute
368INTEGER,INTENT(IN),OPTIONAL :: msec
369INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
370CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
371CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
372
373TYPE(datetime) :: this
374INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
375CHARACTER(len=23) :: datebuf
376
377IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
378 lyear = year
379 IF (PRESENT(month)) THEN
380 lmonth = month
381 ELSE
382 lmonth = 1
383 ENDIF
384 IF (PRESENT(day)) THEN
385 lday = day
386 ELSE
387 lday = 1
388 ENDIF
389 IF (PRESENT(hour)) THEN
390 lhour = hour
391 ELSE
392 lhour = 0
393 ENDIF
394 IF (PRESENT(minute)) THEN
395 lminute = minute
396 ELSE
397 lminute = 0
398 ENDIF
399 IF (PRESENT(msec)) THEN
400 lmsec = msec
401 ELSE
402 lmsec = 0
403 ENDIF
404
405 if (c_e(lday) .and. c_e(lmonth) .and. c_e(lyear) .and. c_e(lhour) &
406 .and. c_e(lminute) .and. c_e(lmsec)) then
407 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
408 else
409 this=datetime_miss
410 end if
411
412ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
413 if (c_e(unixtime)) then
414 this%iminuti = (unixtime + unsec)*1000
415 else
416 this=datetime_miss
417 end if
419ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
420
421 IF (c_e(isodate) .AND. len_trim(isodate) > 0) THEN
422 datebuf(1:23) = '0001-01-01 00:00:00.000'
423 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
424 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
425 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
426 lmsec = lmsec + lsec*1000
427 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
428 RETURN
429
430100 CONTINUE ! condizione di errore in isodate
431 CALL delete(this)
432 RETURN
433 ELSE
434 this = datetime_miss
435 ENDIF
436
437ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
438 IF (c_e(simpledate) .AND. len_trim(simpledate) > 0)THEN
439 datebuf(1:17) = '00010101000000000'
440 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
441 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
442 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
443 lmsec = lmsec + lsec*1000
444 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
445 RETURN
446
447120 CONTINUE ! condizione di errore in simpledate
448 CALL delete(this)
449 RETURN
450 ELSE
451 this = datetime_miss
452 ENDIF
453
454ELSE
455 this = datetime_miss
456ENDIF
457
458END FUNCTION datetime_new
459
460
462FUNCTION datetime_new_now(now) RESULT(this)
463INTEGER,INTENT(IN) :: now
464TYPE(datetime) :: this
465
466INTEGER :: dt(8)
467
468IF (c_e(now)) THEN
469 CALL date_and_time(values=dt)
470 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
471 CALL init(this, year=dt(1), month=dt(2), day=dt(3), hour=dt(5), minute=dt(6), &
472 msec=dt(7)*1000+dt(8))
473ELSE
474 this = datetime_miss
475ENDIF
476
477END FUNCTION datetime_new_now
479
486SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
487 unixtime, isodate, simpledate, now)
488TYPE(datetime),INTENT(INOUT) :: this
489INTEGER,INTENT(IN),OPTIONAL :: year
490INTEGER,INTENT(IN),OPTIONAL :: month
491INTEGER,INTENT(IN),OPTIONAL :: day
492INTEGER,INTENT(IN),OPTIONAL :: hour
493INTEGER,INTENT(IN),OPTIONAL :: minute
494INTEGER,INTENT(IN),OPTIONAL :: msec
495INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
496CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
497CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
498INTEGER,INTENT(IN),OPTIONAL :: now
499
500IF (PRESENT(now)) THEN
501 this = datetime_new_now(now)
502ELSE
503 this = datetime_new(year, month, day, hour, minute, msec, &
504 unixtime, isodate, simpledate)
505ENDIF
506
507END SUBROUTINE datetime_init
508
509
510ELEMENTAL SUBROUTINE datetime_delete(this)
511TYPE(datetime),INTENT(INOUT) :: this
512
513this%iminuti = illmiss
514
515END SUBROUTINE datetime_delete
516
517
522PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
523 unixtime, isodate, simpledate, oraclesimdate)
524TYPE(datetime),INTENT(IN) :: this
525INTEGER,INTENT(OUT),OPTIONAL :: year
526INTEGER,INTENT(OUT),OPTIONAL :: month
527INTEGER,INTENT(OUT),OPTIONAL :: day
528INTEGER,INTENT(OUT),OPTIONAL :: hour
529INTEGER,INTENT(OUT),OPTIONAL :: minute
530INTEGER,INTENT(OUT),OPTIONAL :: msec
531INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
532CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
533CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
534CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
535
536INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
537CHARACTER(len=23) :: datebuf
538
539IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
540 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
541 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
542
543 IF (this == datetime_miss) THEN
544
545 IF (PRESENT(msec)) THEN
546 msec = imiss
547 ENDIF
548 IF (PRESENT(minute)) THEN
549 minute = imiss
550 ENDIF
551 IF (PRESENT(hour)) THEN
552 hour = imiss
553 ENDIF
554 IF (PRESENT(day)) THEN
555 day = imiss
556 ENDIF
557 IF (PRESENT(month)) THEN
558 month = imiss
559 ENDIF
560 IF (PRESENT(year)) THEN
561 year = imiss
562 ENDIF
563 IF (PRESENT(isodate)) THEN
564 isodate = cmiss
565 ENDIF
566 IF (PRESENT(simpledate)) THEN
567 simpledate = cmiss
568 ENDIF
569 IF (PRESENT(oraclesimdate)) THEN
570!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
571!!$ 'obsoleto, usare piuttosto simpledate')
572 oraclesimdate=cmiss
573 ENDIF
574 IF (PRESENT(unixtime)) THEN
575 unixtime = illmiss
576 ENDIF
577
578 ELSE
579
580 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
581 IF (PRESENT(msec)) THEN
582 msec = lmsec
583 ENDIF
584 IF (PRESENT(minute)) THEN
585 minute = lminute
586 ENDIF
587 IF (PRESENT(hour)) THEN
588 hour = lhour
589 ENDIF
590 IF (PRESENT(day)) THEN
591 day = lday
592 ENDIF
593 IF (PRESENT(month)) THEN
594 month = lmonth
595 ENDIF
596 IF (PRESENT(year)) THEN
597 year = lyear
598 ENDIF
599 IF (PRESENT(isodate)) THEN
600 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
601 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
602 '.', mod(lmsec, 1000)
603 isodate = datebuf(1:min(len(isodate),23))
604 ENDIF
605 IF (PRESENT(simpledate)) THEN
606 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
607 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
608 simpledate = datebuf(1:min(len(simpledate),17))
609 ENDIF
610 IF (PRESENT(oraclesimdate)) THEN
611!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
612!!$ 'obsoleto, usare piuttosto simpledate')
613 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
614 ENDIF
615 IF (PRESENT(unixtime)) THEN
616 unixtime = this%iminuti/1000_int_ll-unsec
617 ENDIF
618
619 ENDIF
620ENDIF
621
622END SUBROUTINE datetime_getval
623
624
627elemental FUNCTION datetime_to_char(this) RESULT(char)
628TYPE(datetime),INTENT(IN) :: this
629
630CHARACTER(len=23) :: char
631
632CALL getval(this, isodate=char)
633
634END FUNCTION datetime_to_char
635
636
637FUNCTION trim_datetime_to_char(in) RESULT(char)
638TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
639
640CHARACTER(len=len_trim(datetime_to_char(in))) :: char
641
642char=datetime_to_char(in)
643
644END FUNCTION trim_datetime_to_char
646
647
648SUBROUTINE display_datetime(this)
649TYPE(datetime),INTENT(in) :: this
650
651print*,"TIME: ",to_char(this)
652
653end subroutine display_datetime
654
655
656
657SUBROUTINE display_timedelta(this)
658TYPE(timedelta),INTENT(in) :: this
659
660print*,"TIMEDELTA: ",to_char(this)
661
662end subroutine display_timedelta
663
664
665
666ELEMENTAL FUNCTION c_e_datetime(this) result (res)
667TYPE(datetime),INTENT(in) :: this
668LOGICAL :: res
669
670res = .not. this == datetime_miss
671
672end FUNCTION c_e_datetime
673
674
675ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
676TYPE(datetime),INTENT(IN) :: this, that
677LOGICAL :: res
678
679res = this%iminuti == that%iminuti
680
681END FUNCTION datetime_eq
682
683
684ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
685TYPE(datetime),INTENT(IN) :: this, that
686LOGICAL :: res
687
688res = .NOT.(this == that)
689
690END FUNCTION datetime_ne
691
692
693ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
694TYPE(datetime),INTENT(IN) :: this, that
695LOGICAL :: res
696
697res = this%iminuti > that%iminuti
698
699END FUNCTION datetime_gt
700
701
702ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
703TYPE(datetime),INTENT(IN) :: this, that
704LOGICAL :: res
705
706res = this%iminuti < that%iminuti
707
708END FUNCTION datetime_lt
709
710
711ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
712TYPE(datetime),INTENT(IN) :: this, that
713LOGICAL :: res
714
715IF (this == that) THEN
716 res = .true.
717ELSE IF (this > that) THEN
718 res = .true.
719ELSE
720 res = .false.
721ENDIF
722
723END FUNCTION datetime_ge
724
725
726ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
727TYPE(datetime),INTENT(IN) :: this, that
728LOGICAL :: res
729
730IF (this == that) THEN
731 res = .true.
732ELSE IF (this < that) THEN
733 res = .true.
734ELSE
735 res = .false.
736ENDIF
737
738END FUNCTION datetime_le
739
740
741FUNCTION datetime_add(this, that) RESULT(res)
742TYPE(datetime),INTENT(IN) :: this
743TYPE(timedelta),INTENT(IN) :: that
744TYPE(datetime) :: res
745
746INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
747
748IF (this == datetime_miss .OR. that == timedelta_miss) THEN
749 res = datetime_miss
750ELSE
751 res%iminuti = this%iminuti + that%iminuti
752 IF (that%month /= 0) THEN
753 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
754 minute=lminute, msec=lmsec)
755 CALL init(res, year=lyear, month=lmonth+that%month, day=lday, &
756 hour=lhour, minute=lminute, msec=lmsec)
757 ENDIF
758ENDIF
759
760END FUNCTION datetime_add
761
762
763ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
764TYPE(datetime),INTENT(IN) :: this, that
765TYPE(timedelta) :: res
766
767IF (this == datetime_miss .OR. that == datetime_miss) THEN
768 res = timedelta_miss
769ELSE
770 res%iminuti = this%iminuti - that%iminuti
771 res%month = 0
772ENDIF
773
774END FUNCTION datetime_subdt
775
776
777FUNCTION datetime_subtd(this, that) RESULT(res)
778TYPE(datetime),INTENT(IN) :: this
779TYPE(timedelta),INTENT(IN) :: that
780TYPE(datetime) :: res
781
782INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
783
784IF (this == datetime_miss .OR. that == timedelta_miss) THEN
785 res = datetime_miss
786ELSE
787 res%iminuti = this%iminuti - that%iminuti
788 IF (that%month /= 0) THEN
789 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
790 minute=lminute, msec=lmsec)
791 CALL init(res, year=lyear, month=lmonth-that%month, day=lday, &
792 hour=lhour, minute=lminute, msec=lmsec)
793 ENDIF
794ENDIF
795
796END FUNCTION datetime_subtd
797
798
803SUBROUTINE datetime_read_unit(this, unit)
804TYPE(datetime),INTENT(out) :: this
805INTEGER, INTENT(in) :: unit
806CALL datetime_vect_read_unit((/this/), unit)
807
808END SUBROUTINE datetime_read_unit
809
810
815SUBROUTINE datetime_vect_read_unit(this, unit)
816TYPE(datetime) :: this(:)
817INTEGER, INTENT(in) :: unit
818
819CHARACTER(len=40) :: form
820CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
821INTEGER :: i
822
823ALLOCATE(dateiso(SIZE(this)))
824INQUIRE(unit, form=form)
825IF (form == 'FORMATTED') THEN
826 READ(unit,'(A23,1X)')dateiso
827ELSE
828 READ(unit)dateiso
829ENDIF
830DO i = 1, SIZE(dateiso)
831 CALL init(this(i), isodate=dateiso(i))
832ENDDO
833DEALLOCATE(dateiso)
834
835END SUBROUTINE datetime_vect_read_unit
836
837
842SUBROUTINE datetime_write_unit(this, unit)
843TYPE(datetime),INTENT(in) :: this
844INTEGER, INTENT(in) :: unit
846CALL datetime_vect_write_unit((/this/), unit)
847
848END SUBROUTINE datetime_write_unit
849
850
855SUBROUTINE datetime_vect_write_unit(this, unit)
856TYPE(datetime),INTENT(in) :: this(:)
857INTEGER, INTENT(in) :: unit
858
859CHARACTER(len=40) :: form
860CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
861INTEGER :: i
862
863ALLOCATE(dateiso(SIZE(this)))
864DO i = 1, SIZE(dateiso)
865 CALL getval(this(i), isodate=dateiso(i))
866ENDDO
867INQUIRE(unit, form=form)
868IF (form == 'FORMATTED') THEN
869 WRITE(unit,'(A23,1X)')dateiso
870ELSE
871 WRITE(unit)dateiso
872ENDIF
873DEALLOCATE(dateiso)
874
875END SUBROUTINE datetime_vect_write_unit
876
877
878#include "arrayof_post.F90"
879
880
881! ===============
882! == timedelta ==
883! ===============
890FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
891 isodate, simpledate, oraclesimdate) RESULT (this)
892INTEGER,INTENT(IN),OPTIONAL :: year
893INTEGER,INTENT(IN),OPTIONAL :: month
894INTEGER,INTENT(IN),OPTIONAL :: day
895INTEGER,INTENT(IN),OPTIONAL :: hour
896INTEGER,INTENT(IN),OPTIONAL :: minute
897INTEGER,INTENT(IN),OPTIONAL :: sec
898INTEGER,INTENT(IN),OPTIONAL :: msec
899CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
900CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
901CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
902
903TYPE(timedelta) :: this
904
905CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
906 isodate, simpledate, oraclesimdate)
907
908END FUNCTION timedelta_new
909
910
915SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
916 isodate, simpledate, oraclesimdate)
917TYPE(timedelta),INTENT(INOUT) :: this
918INTEGER,INTENT(IN),OPTIONAL :: year
919INTEGER,INTENT(IN),OPTIONAL :: month
920INTEGER,INTENT(IN),OPTIONAL :: day
921INTEGER,INTENT(IN),OPTIONAL :: hour
922INTEGER,INTENT(IN),OPTIONAL :: minute
923INTEGER,INTENT(IN),OPTIONAL :: sec
924INTEGER,INTENT(IN),OPTIONAL :: msec
925CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
926CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
927CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
928
929INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
930CHARACTER(len=23) :: datebuf
931
932this%month = 0
933
934IF (PRESENT(isodate)) THEN
935 datebuf(1:23) = '0000000000 00:00:00.000'
936 l = len_trim(isodate)
937! IF (l > 0) THEN
938 n = index(trim(isodate), ' ') ! align blank space separator
939 IF (n > 0) THEN
940 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
941 datebuf(12-n:12-n+l-1) = isodate(:l)
942 ELSE
943 datebuf(1:l) = isodate(1:l)
944 ENDIF
945! ENDIF
946
947! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
948 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
949 h, m, s, ms
950 this%month = lmonth + 12*lyear
951 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
952 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
953 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
954 RETURN
955
956200 CONTINUE ! condizione di errore in isodate
957 CALL delete(this)
958 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
959 CALL raise_error()
960
961ELSE IF (PRESENT(simpledate)) THEN
962 datebuf(1:17) = '00000000000000000'
963 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
964 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
965 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
966 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
967 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
968
969220 CONTINUE ! condizione di errore in simpledate
970 CALL delete(this)
971 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
972 CALL raise_error()
973 RETURN
974
975ELSE IF (PRESENT(oraclesimdate)) THEN
976 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
977 'obsoleto, usare piuttosto simpledate')
978 READ(oraclesimdate, '(I8,2I2)')d, h, m
979 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
980 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
981
982ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
983 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
984 .and. .not. present(msec) .and. .not. present(isodate) &
985 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
987 this=timedelta_miss
988
989ELSE
990 this%iminuti = 0
991 IF (PRESENT(year)) THEN
992 if (c_e(year))then
993 this%month = this%month + year*12
994 else
995 this=timedelta_miss
996 return
997 end if
998 ENDIF
999 IF (PRESENT(month)) THEN
1000 if (c_e(month))then
1001 this%month = this%month + month
1002 else
1003 this=timedelta_miss
1004 return
1005 end if
1006 ENDIF
1007 IF (PRESENT(day)) THEN
1008 if (c_e(day))then
1009 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
1010 else
1011 this=timedelta_miss
1012 return
1013 end if
1014 ENDIF
1015 IF (PRESENT(hour)) THEN
1016 if (c_e(hour))then
1017 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
1018 else
1019 this=timedelta_miss
1020 return
1021 end if
1022 ENDIF
1023 IF (PRESENT(minute)) THEN
1024 if (c_e(minute))then
1025 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
1026 else
1027 this=timedelta_miss
1028 return
1029 end if
1030 ENDIF
1031 IF (PRESENT(sec)) THEN
1032 if (c_e(sec))then
1033 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
1034 else
1035 this=timedelta_miss
1036 return
1037 end if
1038 ENDIF
1039 IF (PRESENT(msec)) THEN
1040 if (c_e(msec))then
1041 this%iminuti = this%iminuti + msec
1042 else
1043 this=timedelta_miss
1044 return
1045 end if
1046 ENDIF
1047ENDIF
1048
1049
1050
1051
1052END SUBROUTINE timedelta_init
1053
1054
1055SUBROUTINE timedelta_delete(this)
1056TYPE(timedelta),INTENT(INOUT) :: this
1057
1058this%iminuti = imiss
1059this%month = 0
1060
1061END SUBROUTINE timedelta_delete
1062
1063
1068PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
1069 day, hour, minute, sec, msec, &
1070 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
1071TYPE(timedelta),INTENT(IN) :: this
1072INTEGER,INTENT(OUT),OPTIONAL :: year
1073INTEGER,INTENT(OUT),OPTIONAL :: month
1074INTEGER,INTENT(OUT),OPTIONAL :: amonth
1075INTEGER,INTENT(OUT),OPTIONAL :: day
1076INTEGER,INTENT(OUT),OPTIONAL :: hour
1077INTEGER,INTENT(OUT),OPTIONAL :: minute
1078INTEGER,INTENT(OUT),OPTIONAL :: sec
1079INTEGER,INTENT(OUT),OPTIONAL :: msec
1080INTEGER,INTENT(OUT),OPTIONAL :: ahour
1081INTEGER,INTENT(OUT),OPTIONAL :: aminute
1082INTEGER,INTENT(OUT),OPTIONAL :: asec
1083INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
1084CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
1085CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
1086CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
1087
1088CHARACTER(len=23) :: datebuf
1089
1090IF (PRESENT(amsec)) THEN
1091 amsec = this%iminuti
1092ENDIF
1093IF (PRESENT(asec)) THEN
1094 asec = int(this%iminuti/1000_int_ll)
1095ENDIF
1096IF (PRESENT(aminute)) THEN
1097 aminute = int(this%iminuti/60000_int_ll)
1098ENDIF
1099IF (PRESENT(ahour)) THEN
1100 ahour = int(this%iminuti/3600000_int_ll)
1101ENDIF
1102IF (PRESENT(msec)) THEN
1103 msec = int(mod(this%iminuti, 1000_int_ll))
1104ENDIF
1105IF (PRESENT(sec)) THEN
1106 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
1107ENDIF
1108IF (PRESENT(minute)) THEN
1109 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
1110ENDIF
1111IF (PRESENT(hour)) THEN
1112 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
1113ENDIF
1114IF (PRESENT(day)) THEN
1115 day = int(this%iminuti/86400000_int_ll)
1116ENDIF
1117IF (PRESENT(amonth)) THEN
1118 amonth = this%month
1119ENDIF
1120IF (PRESENT(month)) THEN
1121 month = mod(this%month-1,12)+1
1122ENDIF
1123IF (PRESENT(year)) THEN
1124 year = this%month/12
1125ENDIF
1126IF (PRESENT(isodate)) THEN ! Non standard, inventato!
1127 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
1128 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), ':', &
1129 mod(this%iminuti/60000_int_ll, 60_int_ll), ':', mod(this%iminuti/1000_int_ll, 60_int_ll), &
1130 '.', mod(this%iminuti, 1000_int_ll)
1131 isodate = datebuf(1:min(len(isodate),23))
1132
1133ENDIF
1134IF (PRESENT(simpledate)) THEN
1135 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
1136 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
1137 mod(this%iminuti/60000_int_ll, 60_int_ll), mod(this%iminuti/1000_int_ll, 60_int_ll), &
1138 mod(this%iminuti, 1000_int_ll)
1139 simpledate = datebuf(1:min(len(simpledate),17))
1140ENDIF
1141IF (PRESENT(oraclesimdate)) THEN
1142!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
1143!!$ 'obsoleto, usare piuttosto simpledate')
1144 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
1145 mod(this%iminuti/3600000_int_ll, 24_int_ll), mod(this%iminuti/60000_int_ll, 60_int_ll)
1146ENDIF
1147
1148END SUBROUTINE timedelta_getval
1149
1150
1153elemental FUNCTION timedelta_to_char(this) RESULT(char)
1154TYPE(timedelta),INTENT(IN) :: this
1155
1156CHARACTER(len=23) :: char
1157
1158CALL getval(this, isodate=char)
1159
1160END FUNCTION timedelta_to_char
1161
1163FUNCTION trim_timedelta_to_char(in) RESULT(char)
1164TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
1165
1166CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
1167
1168char=timedelta_to_char(in)
1169
1170END FUNCTION trim_timedelta_to_char
1171
1172
1174elemental FUNCTION timedelta_getamsec(this)
1175TYPE(timedelta),INTENT(IN) :: this
1176INTEGER(kind=int_ll) :: timedelta_getamsec
1177
1178timedelta_getamsec = this%iminuti
1179
1180END FUNCTION timedelta_getamsec
1181
1182
1188FUNCTION timedelta_depop(this)
1189TYPE(timedelta),INTENT(IN) :: this
1190TYPE(timedelta) :: timedelta_depop
1191
1192TYPE(datetime) :: tmpdt
1193
1194IF (this%month == 0) THEN
1195 timedelta_depop = this
1196ELSE
1197 tmpdt = datetime_new(1970, 1, 1)
1198 timedelta_depop = (tmpdt + this) - tmpdt
1199ENDIF
1200
1201END FUNCTION timedelta_depop
1202
1203
1204elemental FUNCTION timedelta_eq(this, that) RESULT(res)
1205TYPE(timedelta),INTENT(IN) :: this, that
1206LOGICAL :: res
1207
1208res = (this%iminuti == that%iminuti .AND. this%month == that%month)
1209
1210END FUNCTION timedelta_eq
1211
1212
1213ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
1214TYPE(timedelta),INTENT(IN) :: this, that
1215LOGICAL :: res
1216
1217res = .NOT.(this == that)
1218
1219END FUNCTION timedelta_ne
1220
1221
1222ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
1223TYPE(timedelta),INTENT(IN) :: this, that
1224LOGICAL :: res
1225
1226res = this%iminuti > that%iminuti
1227
1228END FUNCTION timedelta_gt
1229
1230
1231ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
1232TYPE(timedelta),INTENT(IN) :: this, that
1233LOGICAL :: res
1234
1235res = this%iminuti < that%iminuti
1236
1237END FUNCTION timedelta_lt
1238
1239
1240ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
1241TYPE(timedelta),INTENT(IN) :: this, that
1242LOGICAL :: res
1243
1244IF (this == that) THEN
1245 res = .true.
1246ELSE IF (this > that) THEN
1247 res = .true.
1248ELSE
1249 res = .false.
1250ENDIF
1251
1252END FUNCTION timedelta_ge
1253
1254
1255elemental FUNCTION timedelta_le(this, that) RESULT(res)
1256TYPE(timedelta),INTENT(IN) :: this, that
1257LOGICAL :: res
1258
1259IF (this == that) THEN
1260 res = .true.
1261ELSE IF (this < that) THEN
1262 res = .true.
1263ELSE
1264 res = .false.
1265ENDIF
1266
1267END FUNCTION timedelta_le
1268
1269
1270ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
1271TYPE(timedelta),INTENT(IN) :: this, that
1272TYPE(timedelta) :: res
1273
1274res%iminuti = this%iminuti + that%iminuti
1275res%month = this%month + that%month
1276
1277END FUNCTION timedelta_add
1278
1279
1280ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
1281TYPE(timedelta),INTENT(IN) :: this, that
1282TYPE(timedelta) :: res
1283
1284res%iminuti = this%iminuti - that%iminuti
1285res%month = this%month - that%month
1287END FUNCTION timedelta_sub
1288
1289
1290ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
1291TYPE(timedelta),INTENT(IN) :: this
1292INTEGER,INTENT(IN) :: n
1293TYPE(timedelta) :: res
1294
1295res%iminuti = this%iminuti*n
1296res%month = this%month*n
1297
1298END FUNCTION timedelta_mult
1300
1301ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
1302INTEGER,INTENT(IN) :: n
1303TYPE(timedelta),INTENT(IN) :: this
1304TYPE(timedelta) :: res
1305
1306res%iminuti = this%iminuti*n
1307res%month = this%month*n
1308
1309END FUNCTION timedelta_tlum
1310
1311
1312ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
1313TYPE(timedelta),INTENT(IN) :: this
1314INTEGER,INTENT(IN) :: n
1315TYPE(timedelta) :: res
1317res%iminuti = this%iminuti/n
1318res%month = this%month/n
1319
1320END FUNCTION timedelta_divint
1321
1322
1323ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
1324TYPE(timedelta),INTENT(IN) :: this, that
1325INTEGER :: res
1326
1327res = int(this%iminuti/that%iminuti)
1328
1329END FUNCTION timedelta_divtd
1330
1331
1332elemental FUNCTION timedelta_mod(this, that) RESULT(res)
1333TYPE(timedelta),INTENT(IN) :: this, that
1334TYPE(timedelta) :: res
1335
1336res%iminuti = mod(this%iminuti, that%iminuti)
1337res%month = 0
1338
1339END FUNCTION timedelta_mod
1340
1341
1342ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
1343TYPE(datetime),INTENT(IN) :: this
1344TYPE(timedelta),INTENT(IN) :: that
1345TYPE(timedelta) :: res
1346
1347IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
1348 res = timedelta_0
1349ELSE
1350 res%iminuti = mod(this%iminuti, that%iminuti)
1351 res%month = 0
1352ENDIF
1353
1354END FUNCTION datetime_timedelta_mod
1355
1356
1357ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
1358TYPE(timedelta),INTENT(IN) :: this
1359TYPE(timedelta) :: res
1360
1361res%iminuti = abs(this%iminuti)
1362res%month = abs(this%month)
1363
1364END FUNCTION timedelta_abs
1365
1366
1371SUBROUTINE timedelta_read_unit(this, unit)
1372TYPE(timedelta),INTENT(out) :: this
1373INTEGER, INTENT(in) :: unit
1374
1375CALL timedelta_vect_read_unit((/this/), unit)
1376
1377END SUBROUTINE timedelta_read_unit
1378
1379
1384SUBROUTINE timedelta_vect_read_unit(this, unit)
1385TYPE(timedelta) :: this(:)
1386INTEGER, INTENT(in) :: unit
1387
1388CHARACTER(len=40) :: form
1389CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
1390INTEGER :: i
1391
1392ALLOCATE(dateiso(SIZE(this)))
1393INQUIRE(unit, form=form)
1394IF (form == 'FORMATTED') THEN
1395 READ(unit,'(3(A23,1X))')dateiso
1396ELSE
1397 READ(unit)dateiso
1398ENDIF
1399DO i = 1, SIZE(dateiso)
1400 CALL init(this(i), isodate=dateiso(i))
1401ENDDO
1402DEALLOCATE(dateiso)
1403
1404END SUBROUTINE timedelta_vect_read_unit
1405
1406
1411SUBROUTINE timedelta_write_unit(this, unit)
1412TYPE(timedelta),INTENT(in) :: this
1413INTEGER, INTENT(in) :: unit
1414
1415CALL timedelta_vect_write_unit((/this/), unit)
1416
1417END SUBROUTINE timedelta_write_unit
1418
1419
1424SUBROUTINE timedelta_vect_write_unit(this, unit)
1425TYPE(timedelta),INTENT(in) :: this(:)
1426INTEGER, INTENT(in) :: unit
1427
1428CHARACTER(len=40) :: form
1429CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
1430INTEGER :: i
1431
1432ALLOCATE(dateiso(SIZE(this)))
1433DO i = 1, SIZE(dateiso)
1434 CALL getval(this(i), isodate=dateiso(i))
1435ENDDO
1436INQUIRE(unit, form=form)
1437IF (form == 'FORMATTED') THEN
1438 WRITE(unit,'(3(A23,1X))')dateiso
1439ELSE
1440 WRITE(unit)dateiso
1441ENDIF
1442DEALLOCATE(dateiso)
1443
1444END SUBROUTINE timedelta_vect_write_unit
1445
1446
1447ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
1448TYPE(timedelta),INTENT(in) :: this
1449LOGICAL :: res
1450
1451res = .not. this == timedelta_miss
1452
1453end FUNCTION c_e_timedelta
1454
1455
1456elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
1457
1458!!omstart JELADATA5
1459! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
1460! 1 IMINUTI)
1461!
1462! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
1463!
1464! variabili integer*4
1465! IN:
1466! IDAY,IMONTH,IYEAR, I*4
1467! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
1468!
1469! OUT:
1470! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
1471!!OMEND
1472
1473INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
1474INTEGER,intent(out) :: iminuti
1475
1476iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
1477
1478END SUBROUTINE jeladata5
1479
1480
1481elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
1482INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
1483INTEGER(KIND=int_ll),intent(out) :: imillisec
1484
1485imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
1486 + imsec
1487
1488END SUBROUTINE jeladata5_1
1489
1490
1491
1492elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
1493
1494!!omstart JELADATA6
1495! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
1496! 1 IMINUTI)
1497!
1498! Calcola la data e l'ora corrispondente a IMINUTI dopo il
1499! 1/1/1
1500!
1501! variabili integer*4
1502! IN:
1503! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
1504!
1505! OUT:
1506! IDAY,IMONTH,IYEAR, I*4
1507! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
1508!!OMEND
1509
1510
1511INTEGER,intent(in) :: iminuti
1512INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
1513
1514INTEGER ::igiorno
1515
1516imin = mod(iminuti,60)
1517ihour = mod(iminuti,1440)/60
1518igiorno = iminuti/1440
1519IF (mod(iminuti,1440) < 0) igiorno = igiorno-1
1520CALL ndyin(igiorno,iday,imonth,iyear)
1521
1522END SUBROUTINE jeladata6
1523
1525elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
1526INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
1527INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
1528
1529INTEGER :: igiorno
1530
1531imsec = int(mod(imillisec, 60000_int_ll)) ! partial msec
1532!imin = MOD(imillisec/60000_int_ll, 60)
1533!ihour = MOD(imillisec/3600000_int_ll, 24)
1534imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
1535ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
1536igiorno = int(imillisec/86400000_int_ll)
1537!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
1538CALL ndyin(igiorno,iday,imonth,iyear)
1539
1540END SUBROUTINE jeladata6_1
1541
1542
1543elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
1544
1545!!OMSTART NDYIN
1546! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
1547! restituisce la data fornendo in input il numero di
1548! giorni dal 1/1/1
1550!!omend
1551
1552INTEGER,intent(in) :: ndays
1553INTEGER,intent(out) :: igg, imm, iaa
1554integer :: n,lndays
1555
1556lndays=ndays
1557
1558n = lndays/d400
1559lndays = lndays - n*d400
1560iaa = year0 + n*400
1561n = min(lndays/d100, 3)
1562lndays = lndays - n*d100
1563iaa = iaa + n*100
1564n = lndays/d4
1565lndays = lndays - n*d4
1566iaa = iaa + n*4
1567n = min(lndays/d1, 3)
1568lndays = lndays - n*d1
1569iaa = iaa + n
1570n = bisextilis(iaa)
1571DO imm = 1, 12
1572 IF (lndays < ianno(imm+1,n)) EXIT
1573ENDDO
1574igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
1575
1576END SUBROUTINE ndyin
1577
1578
1579integer elemental FUNCTION ndays(igg,imm,iaa)
1580
1581!!OMSTART NDAYS
1582! FUNCTION NDAYS(IGG,IMM,IAA)
1583! restituisce il numero di giorni dal 1/1/1
1584! fornendo in input la data
1585!
1586!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1587! nota bene E' SICURO !!!
1588! un anno e' bisestile se divisibile per 4
1589! un anno rimane bisestile se divisibile per 400
1590! un anno NON e' bisestile se divisibile per 100
1591!
1592!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1593!
1594!!omend
1595
1596INTEGER, intent(in) :: igg, imm, iaa
1597
1598INTEGER :: lmonth, lyear
1599
1600! Limito il mese a [1-12] e correggo l'anno coerentemente
1601lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
1602lyear = iaa + (imm - lmonth)/12
1603ndays = igg+ianno(lmonth, bisextilis(lyear))
1604ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
1605 (lyear-year0)/400
1606
1607END FUNCTION ndays
1608
1609
1610elemental FUNCTION bisextilis(annum)
1611INTEGER,INTENT(in) :: annum
1612INTEGER :: bisextilis
1613
1614IF (mod(annum,4) == 0 .AND. (mod(annum,400) == 0 .EQV. mod(annum,100) == 0)) THEN
1615 bisextilis = 2
1616ELSE
1617 bisextilis = 1
1618ENDIF
1619END FUNCTION bisextilis
1620
1621
1622ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
1623TYPE(cyclicdatetime),INTENT(IN) :: this, that
1624LOGICAL :: res
1625
1626res = .true.
1627if (this%minute /= that%minute) res=.false.
1628if (this%hour /= that%hour) res=.false.
1629if (this%day /= that%day) res=.false.
1630if (this%month /= that%month) res=.false.
1631if (this%tendaysp /= that%tendaysp) res=.false.
1632
1633END FUNCTION cyclicdatetime_eq
1634
1635
1636ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
1637TYPE(cyclicdatetime),INTENT(IN) :: this
1638TYPE(datetime),INTENT(IN) :: that
1639LOGICAL :: res
1640
1641integer :: minute,hour,day,month
1642
1643call getval(that,minute=minute,hour=hour,day=day,month=month)
1644
1645res = .true.
1646if (c_e(this%minute) .and. this%minute /= minute) res=.false.
1647if (c_e(this%hour) .and. this%hour /= hour) res=.false.
1648if (c_e(this%day) .and. this%day /= day) res=.false.
1649if (c_e(this%month) .and. this%month /= month) res=.false.
1650if (c_e(this%tendaysp)) then
1651 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
1652end if
1653
1654END FUNCTION cyclicdatetime_datetime_eq
1655
1656
1657ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
1658TYPE(datetime),INTENT(IN) :: this
1659TYPE(cyclicdatetime),INTENT(IN) :: that
1660LOGICAL :: res
1661
1662integer :: minute,hour,day,month
1663
1664call getval(this,minute=minute,hour=hour,day=day,month=month)
1665
1666res = .true.
1667if (c_e(that%minute) .and. that%minute /= minute) res=.false.
1668if (c_e(that%hour) .and. that%hour /= hour) res=.false.
1669if (c_e(that%day) .and. that%day /= day) res=.false.
1670if (c_e(that%month) .and. that%month /= month) res=.false.
1671
1672if (c_e(that%tendaysp)) then
1673 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
1674end if
1675
1676
1677END FUNCTION datetime_cyclicdatetime_eq
1678
1679ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
1680TYPE(cyclicdatetime),INTENT(in) :: this
1681LOGICAL :: res
1682
1683res = .not. this == cyclicdatetime_miss
1684
1685end FUNCTION c_e_cyclicdatetime
1686
1687
1690FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
1691INTEGER,INTENT(IN),OPTIONAL :: tendaysp
1692INTEGER,INTENT(IN),OPTIONAL :: month
1693INTEGER,INTENT(IN),OPTIONAL :: day
1694INTEGER,INTENT(IN),OPTIONAL :: hour
1695INTEGER,INTENT(IN),OPTIONAL :: minute
1696CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
1697
1698integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
1699
1700
1701TYPE(cyclicdatetime) :: this
1703if (present(chardate)) then
1704
1705 ltendaysp=imiss
1706 lmonth=imiss
1707 lday=imiss
1708 lhour=imiss
1709 lminute=imiss
1710
1711 if (c_e(chardate))then
1712 ! TMMGGhhmm
1713 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
1714 !print*,chardate(1:1),ios,ltendaysp
1715 if (ios /= 0)ltendaysp=imiss
1716
1717 read(chardate(2:3),'(i2)',iostat=ios)lmonth
1718 !print*,chardate(2:3),ios,lmonth
1719 if (ios /= 0)lmonth=imiss
1720
1721 read(chardate(4:5),'(i2)',iostat=ios)lday
1722 !print*,chardate(4:5),ios,lday
1723 if (ios /= 0)lday=imiss
1724
1725 read(chardate(6:7),'(i2)',iostat=ios)lhour
1726 !print*,chardate(6:7),ios,lhour
1727 if (ios /= 0)lhour=imiss
1728
1729 read(chardate(8:9),'(i2)',iostat=ios)lminute
1730 !print*,chardate(8:9),ios,lminute
1731 if (ios /= 0)lminute=imiss
1732 end if
1733
1734 this%tendaysp=ltendaysp
1735 this%month=lmonth
1736 this%day=lday
1737 this%hour=lhour
1738 this%minute=lminute
1739else
1740 this%tendaysp=optio_l(tendaysp)
1741 this%month=optio_l(month)
1742 this%day=optio_l(day)
1743 this%hour=optio_l(hour)
1744 this%minute=optio_l(minute)
1745end if
1746
1747END FUNCTION cyclicdatetime_new
1748
1751elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
1752TYPE(cyclicdatetime),INTENT(IN) :: this
1753
1754CHARACTER(len=80) :: char
1755
1756char=to_char(this%tendaysp)//";"//to_char(this%month)//";"//to_char(this%day)//";"//&
1757to_char(this%hour)//";"//to_char(this%minute)
1758
1759END FUNCTION cyclicdatetime_to_char
1760
1761
1774FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
1775TYPE(cyclicdatetime),INTENT(IN) :: this
1776
1777TYPE(datetime) :: dtc
1778
1779integer :: year,month,day,hour
1780
1781dtc = datetime_miss
1782
1783! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
1784if ( .not. c_e(this)) then
1785 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
1786 return
1787end if
1788
1789! minute present -> not good for conventional datetime
1790if (c_e(this%minute)) return
1791! day, month and tendaysp present -> no good
1792if (c_e(this%day) .and. c_e(this%month) .and. c_e(this%tendaysp)) return
1793
1794if (c_e(this%day) .and. c_e(this%month)) then
1795 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
1796else if (c_e(this%tendaysp) .and. c_e(this%month)) then
1797 day=(this%tendaysp-1)*10+1
1798 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
1799else if (c_e(this%month)) then
1800 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
1801else if (c_e(this%day)) then
1802 ! only day present -> no good
1803 return
1804end if
1805
1806if (c_e(this%hour)) then
1807 call getval(dtc,year=year,month=month,day=day,hour=hour)
1808 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
1809end if
1810
1811
1812END FUNCTION cyclicdatetime_to_conventional
1813
1814
1815
1816FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
1817TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
1818
1819CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
1820
1821char=cyclicdatetime_to_char(in)
1823END FUNCTION trim_cyclicdatetime_to_char
1824
1825
1826
1827SUBROUTINE display_cyclicdatetime(this)
1828TYPE(cyclicdatetime),INTENT(in) :: this
1829
1830print*,"CYCLICDATETIME: ",to_char(this)
1831
1832end subroutine display_cyclicdatetime
1833
1834
1835#include "array_utilities_inc.F90"
1836
1837END MODULE datetime_class
1838
Operatore di valore assoluto di un intervallo.
Quick method to append an element to the array.
Distruttori per le 2 classi.
Restituiscono il valore dell'oggetto nella forma desiderata.
Index method with sorted array.
Costruttori per le classi datetime e timedelta.
Method for inserting elements of the array at a desired position.
Operatore di resto della divisione.
Method for packing the array object reducing at a minimum the memory occupation, without destroying i...
Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o...
Method for removing elements of the array at a desired position.
Functions that return a trimmed CHARACTER representation of the input variable.
Restituiscono il valore dell'oggetto in forma di stringa stampabile.
Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ...
Index method.
Utilities for CHARACTER variables.
Classi per la gestione delle coordinate temporali.
Gestione degli errori.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:251
classe per la gestione del logging
Definitions of constants and functions for working with missing values.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Derived type defining a dynamically extensible array of TYPE(datetime) elements.
Class for expressing a cyclic datetime.
Class for expressing an absolute time value.
Class for expressing a relative time interval.

Generated with Doxygen.