libsim  Versione7.1.6
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 
33 MODULE datetime_class
34 USE kinds
35 USE log4fortran
36 USE err_handling
40 IMPLICIT NONE
41 
42 INTEGER, PARAMETER :: dateint=selected_int_kind(13)
43 
45 TYPE datetime
46  PRIVATE
47  INTEGER(KIND=int_ll) :: iminuti
48 END TYPE datetime
49 
57 TYPE timedelta
58  PRIVATE
59  INTEGER(KIND=int_ll) :: iminuti
60  INTEGER :: month
61 END TYPE timedelta
62 
63 
67 TYPE cyclicdatetime
68  PRIVATE
69  INTEGER :: minute
70  INTEGER :: hour
71  INTEGER :: day
72  INTEGER :: tendaysp
73  INTEGER :: month
74 END TYPE cyclicdatetime
75 
76 
78 TYPE(datetime), PARAMETER :: datetime_miss=datetime(illmiss)
79 
80 TYPE(timedelta), PARAMETER :: timedelta_miss=timedelta(illmiss, 0)
81 
82 TYPE(timedelta), PARAMETER :: timedelta_0=timedelta(0, 0)
83 
84 INTEGER, PARAMETER :: datetime_utc=1
85 
86 INTEGER, PARAMETER :: datetime_local=2
87 
88 TYPE(datetime), PARAMETER :: datetime_min=datetime(-huge(1_int_ll)-1)
89 
90 TYPE(datetime), PARAMETER :: datetime_max=datetime(huge(1_int_ll)-1)
91 
92 TYPE(timedelta), PARAMETER :: timedelta_min=timedelta(-huge(1_int_ll)-1,0)
93 
94 TYPE(timedelta), PARAMETER :: timedelta_max=timedelta(huge(1_int_ll)-1,0)
95 
96 TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
97 
98 
99 INTEGER(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 
107 INTEGER,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 
117 INTEGER(KIND=int_ll),PARAMETER :: &
118  unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
119 
123 INTERFACE init
124  MODULE PROCEDURE datetime_init, timedelta_init
125 END INTERFACE
126 
129 INTERFACE delete
130  MODULE PROCEDURE datetime_delete, timedelta_delete
131 END INTERFACE
132 
134 INTERFACE getval
135  MODULE PROCEDURE datetime_getval, timedelta_getval
136 END INTERFACE
137 
139 INTERFACE to_char
140  MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
141 END INTERFACE
142 
143 
161 INTERFACE t2c
162  MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
163 END INTERFACE
164 
170 INTERFACE operator (==)
171  MODULE PROCEDURE datetime_eq, timedelta_eq, &
172  cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
173 END INTERFACE
174 
180 INTERFACE operator (/=)
181  MODULE PROCEDURE datetime_ne, timedelta_ne
182 END INTERFACE
183 
191 INTERFACE operator (>)
192  MODULE PROCEDURE datetime_gt, timedelta_gt
193 END INTERFACE
194 
202 INTERFACE operator (<)
203  MODULE PROCEDURE datetime_lt, timedelta_lt
204 END INTERFACE
205 
213 INTERFACE operator (>=)
214  MODULE PROCEDURE datetime_ge, timedelta_ge
215 END INTERFACE
216 
224 INTERFACE operator (<=)
225  MODULE PROCEDURE datetime_le, timedelta_le
226 END INTERFACE
227 
234 INTERFACE operator (+)
235  MODULE PROCEDURE datetime_add, timedelta_add
236 END INTERFACE
237 
245 INTERFACE operator (-)
246  MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
247 END INTERFACE
248 
254 INTERFACE operator (*)
255  MODULE PROCEDURE timedelta_mult, timedelta_tlum
256 END INTERFACE
257 
264 INTERFACE operator (/)
265  MODULE PROCEDURE timedelta_divint, timedelta_divtd
266 END INTERFACE
278 INTERFACE mod
279  MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
280 END INTERFACE
284 INTERFACE abs
285  MODULE PROCEDURE timedelta_abs
286 END INTERFACE
287 
290 INTERFACE read_unit
291  MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
292  timedelta_read_unit, timedelta_vect_read_unit
293 END INTERFACE
294 
297 INTERFACE write_unit
298  MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
299  timedelta_write_unit, timedelta_vect_write_unit
300 END INTERFACE
301 
303 INTERFACE display
304  MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
305 END INTERFACE
306 
308 INTERFACE c_e
309  MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
310 END 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"
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 
327 PRIVATE
328 
329 PUBLIC 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
344 PUBLIC insert, append, remove, packarray
345 PUBLIC insert_unique, append_unique
346 PUBLIC cyclicdatetime_to_conventional
347 
348 CONTAINS
349 
350 
351 ! ==============
352 ! == datetime ==
353 ! ==============
354 
361 ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
362  unixtime, isodate, simpledate) result(this)
363 INTEGER,INTENT(IN),OPTIONAL :: year
364 INTEGER,INTENT(IN),OPTIONAL :: month
365 INTEGER,INTENT(IN),OPTIONAL :: day
366 INTEGER,INTENT(IN),OPTIONAL :: hour
367 INTEGER,INTENT(IN),OPTIONAL :: minute
368 INTEGER,INTENT(IN),OPTIONAL :: msec
369 INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
370 CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
371 CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
372 
373 TYPE(datetime) :: this
374 INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
375 CHARACTER(len=23) :: datebuf
377 IF (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 
412 ELSE 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
418 
419 ELSE 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 
430 100 CONTINUE ! condizione di errore in isodate
431  CALL delete(this)
432  RETURN
433  ELSE
434  this = datetime_miss
435  ENDIF
436 
437 ELSE 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 
447 120 CONTINUE ! condizione di errore in simpledate
448  CALL delete(this)
449  RETURN
450  ELSE
451  this = datetime_miss
452  ENDIF
453 
454 ELSE
455  this = datetime_miss
456 ENDIF
457 
458 END FUNCTION datetime_new
459 
460 
462 FUNCTION datetime_new_now(now) RESULT(this)
463 INTEGER,INTENT(IN) :: now
464 type(datetime) :: this
465 
466 INTEGER :: dt(8)
467 
468 IF (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))
473 ELSE
474  this = datetime_miss
475 ENDIF
476 
477 END FUNCTION datetime_new_now
478 
479 
486 SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
487  unixtime, isodate, simpledate, now)
488 TYPE(datetime),INTENT(INOUT) :: this
489 INTEGER,INTENT(IN),OPTIONAL :: year
490 INTEGER,INTENT(IN),OPTIONAL :: month
491 INTEGER,INTENT(IN),OPTIONAL :: day
492 INTEGER,INTENT(IN),OPTIONAL :: hour
493 INTEGER,INTENT(IN),OPTIONAL :: minute
494 INTEGER,INTENT(IN),OPTIONAL :: msec
495 INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
496 CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
497 CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
498 INTEGER,INTENT(IN),OPTIONAL :: now
499 
500 IF (present(now)) THEN
501  this = datetime_new_now(now)
502 ELSE
503  this = datetime_new(year, month, day, hour, minute, msec, &
504  unixtime, isodate, simpledate)
505 ENDIF
506 
507 END SUBROUTINE datetime_init
508 
509 
510 ELEMENTAL SUBROUTINE datetime_delete(this)
511 TYPE(datetime),INTENT(INOUT) :: this
512 
513 this%iminuti = illmiss
514 
515 END SUBROUTINE datetime_delete
516 
517 
522 PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
523  unixtime, isodate, simpledate, oraclesimdate)
524 TYPE(datetime),INTENT(IN) :: this
525 INTEGER,INTENT(OUT),OPTIONAL :: year
526 INTEGER,INTENT(OUT),OPTIONAL :: month
527 INTEGER,INTENT(OUT),OPTIONAL :: day
528 INTEGER,INTENT(OUT),OPTIONAL :: hour
529 INTEGER,INTENT(OUT),OPTIONAL :: minute
530 INTEGER,INTENT(OUT),OPTIONAL :: msec
531 INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
532 CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
533 CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
534 CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
535 
536 INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
537 CHARACTER(len=23) :: datebuf
538 
539 IF (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
620 ENDIF
621 
622 END SUBROUTINE datetime_getval
623 
624 
627 elemental FUNCTION datetime_to_char(this) RESULT(char)
628 TYPE(datetime),INTENT(IN) :: this
629 
630 CHARACTER(len=23) :: char
631 
632 CALL getval(this, isodate=char)
633 
634 END FUNCTION datetime_to_char
635 
637 FUNCTION trim_datetime_to_char(in) RESULT(char)
638 TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
639 
640 CHARACTER(len=len_trim(datetime_to_char(in))) :: char
641 
642 char=datetime_to_char(in)
643 
644 END FUNCTION trim_datetime_to_char
645 
646 
647 
648 SUBROUTINE display_datetime(this)
649 TYPE(datetime),INTENT(in) :: this
650 
651 print*,"TIME: ",to_char(this)
652 
653 end subroutine display_datetime
654 
655 
656 
657 SUBROUTINE display_timedelta(this)
658 TYPE(timedelta),INTENT(in) :: this
659 
660 print*,"TIMEDELTA: ",to_char(this)
661 
662 end subroutine display_timedelta
663 
664 
665 
666 ELEMENTAL FUNCTION c_e_datetime(this) result (res)
667 TYPE(datetime),INTENT(in) :: this
668 LOGICAL :: res
669 
670 res = .not. this == datetime_miss
671 
672 end FUNCTION c_e_datetime
673 
674 
675 ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
676 TYPE(datetime),INTENT(IN) :: this, that
677 LOGICAL :: res
678 
679 res = this%iminuti == that%iminuti
680 
681 END FUNCTION datetime_eq
682 
683 
684 ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
685 TYPE(datetime),INTENT(IN) :: this, that
686 LOGICAL :: res
687 
688 res = .NOT.(this == that)
689 
690 END FUNCTION datetime_ne
691 
692 
693 ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
694 TYPE(datetime),INTENT(IN) :: this, that
695 LOGICAL :: res
696 
697 res = this%iminuti > that%iminuti
698 
699 END FUNCTION datetime_gt
700 
701 
702 ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
703 TYPE(datetime),INTENT(IN) :: this, that
704 LOGICAL :: res
705 
706 res = this%iminuti < that%iminuti
707 
708 END FUNCTION datetime_lt
709 
710 
711 ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
712 TYPE(datetime),INTENT(IN) :: this, that
713 LOGICAL :: res
714 
715 IF (this == that) THEN
716  res = .true.
717 ELSE IF (this > that) THEN
718  res = .true.
719 ELSE
720  res = .false.
721 ENDIF
722 
723 END FUNCTION datetime_ge
724 
725 
726 ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
727 TYPE(datetime),INTENT(IN) :: this, that
728 LOGICAL :: res
729 
730 IF (this == that) THEN
731  res = .true.
732 ELSE IF (this < that) THEN
733  res = .true.
734 ELSE
735  res = .false.
736 ENDIF
737 
738 END FUNCTION datetime_le
739 
740 
741 FUNCTION datetime_add(this, that) RESULT(res)
742 TYPE(datetime),INTENT(IN) :: this
743 TYPE(timedelta),INTENT(IN) :: that
744 TYPE(datetime) :: res
745 
746 INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
747 
748 IF (this == datetime_miss .OR. that == timedelta_miss) THEN
749  res = datetime_miss
750 ELSE
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
758 ENDIF
759 
760 END FUNCTION datetime_add
761 
762 
763 ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
764 TYPE(datetime),INTENT(IN) :: this, that
765 TYPE(timedelta) :: res
766 
767 IF (this == datetime_miss .OR. that == datetime_miss) THEN
768  res = timedelta_miss
769 ELSE
770  res%iminuti = this%iminuti - that%iminuti
771  res%month = 0
772 ENDIF
773 
774 END FUNCTION datetime_subdt
775 
776 
777 FUNCTION datetime_subtd(this, that) RESULT(res)
778 TYPE(datetime),INTENT(IN) :: this
779 TYPE(timedelta),INTENT(IN) :: that
780 TYPE(datetime) :: res
781 
782 INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
783 
784 IF (this == datetime_miss .OR. that == timedelta_miss) THEN
785  res = datetime_miss
786 ELSE
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
794 ENDIF
795 
796 END FUNCTION datetime_subtd
797 
798 
803 SUBROUTINE datetime_read_unit(this, unit)
804 TYPE(datetime),INTENT(out) :: this
805 INTEGER, INTENT(in) :: unit
806 call datetime_vect_read_unit((/this/), unit)
807 
808 END SUBROUTINE datetime_read_unit
809 
810 
815 SUBROUTINE datetime_vect_read_unit(this, unit)
816 TYPE(datetime) :: this(:)
817 INTEGER, INTENT(in) :: unit
818 
819 CHARACTER(len=40) :: form
820 CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
821 INTEGER :: i
822 
823 ALLOCATE(dateiso(SIZE(this)))
824 INQUIRE(unit, form=form)
825 IF (form == 'FORMATTED') THEN
826  READ(unit,'(A23,1X)')dateiso
827 ELSE
828  READ(unit)dateiso
829 ENDIF
830 DO i = 1, SIZE(dateiso)
831  CALL init(this(i), isodate=dateiso(i))
832 ENDDO
833 DEALLOCATE(dateiso)
834 
835 END SUBROUTINE datetime_vect_read_unit
837 
842 SUBROUTINE datetime_write_unit(this, unit)
843 TYPE(datetime),INTENT(in) :: this
844 INTEGER, INTENT(in) :: unit
845 
846 CALL datetime_vect_write_unit((/this/), unit)
847 
848 END SUBROUTINE datetime_write_unit
849 
850 
855 SUBROUTINE datetime_vect_write_unit(this, unit)
856 TYPE(datetime),INTENT(in) :: this(:)
857 INTEGER, INTENT(in) :: unit
858 
859 CHARACTER(len=40) :: form
860 CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
861 INTEGER :: i
862 
863 ALLOCATE(dateiso(SIZE(this)))
864 DO i = 1, SIZE(dateiso)
865  CALL getval(this(i), isodate=dateiso(i))
866 ENDDO
867 INQUIRE(unit, form=form)
868 IF (form == 'FORMATTED') THEN
869  WRITE(unit,'(A23,1X)')dateiso
870 ELSE
871  WRITE(unit)dateiso
872 ENDIF
873 DEALLOCATE(dateiso)
874 
875 END SUBROUTINE datetime_vect_write_unit
876 
877 
878 #include "arrayof_post.F90"
879 
880 
881 ! ===============
882 ! == timedelta ==
883 ! ===============
890 FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
891  isodate, simpledate, oraclesimdate) result(this)
892 INTEGER,INTENT(IN),OPTIONAL :: year
893 INTEGER,INTENT(IN),OPTIONAL :: month
894 INTEGER,INTENT(IN),OPTIONAL :: day
895 INTEGER,INTENT(IN),OPTIONAL :: hour
896 INTEGER,INTENT(IN),OPTIONAL :: minute
897 INTEGER,INTENT(IN),OPTIONAL :: sec
898 INTEGER,INTENT(IN),OPTIONAL :: msec
899 CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
900 CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
901 CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
902 
903 TYPE(timedelta) :: this
904 
905 CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
906  isodate, simpledate, oraclesimdate)
907 
908 END FUNCTION timedelta_new
909 
910 
915 SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
916  isodate, simpledate, oraclesimdate)
917 TYPE(timedelta),INTENT(INOUT) :: this
918 INTEGER,INTENT(IN),OPTIONAL :: year
919 INTEGER,INTENT(IN),OPTIONAL :: month
920 INTEGER,INTENT(IN),OPTIONAL :: day
921 INTEGER,INTENT(IN),OPTIONAL :: hour
922 INTEGER,INTENT(IN),OPTIONAL :: minute
923 INTEGER,INTENT(IN),OPTIONAL :: sec
924 INTEGER,INTENT(IN),OPTIONAL :: msec
925 CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
926 CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
927 CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
928 
929 INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
930 CHARACTER(len=23) :: datebuf
931 
932 this%month = 0
933 
934 IF (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 
956 200 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 
961 ELSE 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 
969 220 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 
975 ELSE 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 
982 ELSE 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
986 
987  this=timedelta_miss
988 
989 ELSE
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
1047 ENDIF
1048 
1049 
1050 
1051 
1052 END SUBROUTINE timedelta_init
1053 
1054 
1055 SUBROUTINE timedelta_delete(this)
1056 TYPE(timedelta),INTENT(INOUT) :: this
1057 
1058 this%iminuti = imiss
1059 this%month = 0
1060 
1061 END SUBROUTINE timedelta_delete
1062 
1063 
1068 PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
1069  day, hour, minute, sec, msec, &
1070  ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
1071 TYPE(timedelta),INTENT(IN) :: this
1072 INTEGER,INTENT(OUT),OPTIONAL :: year
1073 INTEGER,INTENT(OUT),OPTIONAL :: month
1074 INTEGER,INTENT(OUT),OPTIONAL :: amonth
1075 INTEGER,INTENT(OUT),OPTIONAL :: day
1076 INTEGER,INTENT(OUT),OPTIONAL :: hour
1077 INTEGER,INTENT(OUT),OPTIONAL :: minute
1078 INTEGER,INTENT(OUT),OPTIONAL :: sec
1079 INTEGER,INTENT(OUT),OPTIONAL :: msec
1080 INTEGER,INTENT(OUT),OPTIONAL :: ahour
1081 INTEGER,INTENT(OUT),OPTIONAL :: aminute
1082 INTEGER,INTENT(OUT),OPTIONAL :: asec
1083 INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
1084 CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
1085 CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
1086 CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
1087 
1088 CHARACTER(len=23) :: datebuf
1089 
1090 IF (present(amsec)) THEN
1091  amsec = this%iminuti
1092 ENDIF
1093 IF (present(asec)) THEN
1094  asec = int(this%iminuti/1000_int_ll)
1095 ENDIF
1096 IF (present(aminute)) THEN
1097  aminute = int(this%iminuti/60000_int_ll)
1098 ENDIF
1099 IF (present(ahour)) THEN
1100  ahour = int(this%iminuti/3600000_int_ll)
1101 ENDIF
1102 IF (present(msec)) THEN
1103  msec = int(mod(this%iminuti, 1000_int_ll))
1104 ENDIF
1105 IF (present(sec)) THEN
1106  sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
1107 ENDIF
1108 IF (present(minute)) THEN
1109  minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
1110 ENDIF
1111 IF (present(hour)) THEN
1112  hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
1113 ENDIF
1114 IF (present(day)) THEN
1115  day = int(this%iminuti/86400000_int_ll)
1116 ENDIF
1117 IF (present(amonth)) THEN
1118  amonth = this%month
1119 ENDIF
1120 IF (present(month)) THEN
1121  month = mod(this%month-1,12)+1
1122 ENDIF
1123 IF (present(year)) THEN
1124  year = this%month/12
1125 ENDIF
1126 IF (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 
1133 ENDIF
1134 IF (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))
1140 ENDIF
1141 IF (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)
1146 ENDIF
1147 
1148 END SUBROUTINE timedelta_getval
1149 
1150 
1153 elemental FUNCTION timedelta_to_char(this) RESULT(char)
1154 TYPE(timedelta),INTENT(IN) :: this
1155 
1156 CHARACTER(len=23) :: char
1157 
1158 CALL getval(this, isodate=char)
1159 
1160 END FUNCTION timedelta_to_char
1161 
1162 
1163 FUNCTION trim_timedelta_to_char(in) RESULT(char)
1164 TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
1166 CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
1167 
1168 char=timedelta_to_char(in)
1169 
1170 END FUNCTION trim_timedelta_to_char
1171 
1172 
1174 elemental FUNCTION timedelta_getamsec(this)
1175 TYPE(timedelta),INTENT(IN) :: this
1176 INTEGER(kind=int_ll) :: timedelta_getamsec
1177 
1178 timedelta_getamsec = this%iminuti
1179 
1180 END FUNCTION timedelta_getamsec
1181 
1182 
1188 FUNCTION timedelta_depop(this)
1189 TYPE(timedelta),INTENT(IN) :: this
1190 type(timedelta) :: timedelta_depop
1191 
1192 TYPE(datetime) :: tmpdt
1193 
1194 IF (this%month == 0) THEN
1195  timedelta_depop = this
1196 ELSE
1197  tmpdt = datetime_new(1970, 1, 1)
1198  timedelta_depop = (tmpdt + this) - tmpdt
1199 ENDIF
1200 
1201 END FUNCTION timedelta_depop
1202 
1203 
1204 elemental FUNCTION timedelta_eq(this, that) RESULT(res)
1205 TYPE(timedelta),INTENT(IN) :: this, that
1206 LOGICAL :: res
1207 
1208 res = (this%iminuti == that%iminuti .AND. this%month == that%month)
1209 
1210 END FUNCTION timedelta_eq
1211 
1212 
1213 ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
1214 TYPE(timedelta),INTENT(IN) :: this, that
1215 LOGICAL :: res
1216 
1217 res = .NOT.(this == that)
1218 
1219 END FUNCTION timedelta_ne
1220 
1221 
1222 ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
1223 TYPE(timedelta),INTENT(IN) :: this, that
1224 LOGICAL :: res
1225 
1226 res = this%iminuti > that%iminuti
1227 
1228 END FUNCTION timedelta_gt
1229 
1230 
1231 ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
1232 TYPE(timedelta),INTENT(IN) :: this, that
1233 LOGICAL :: res
1234 
1235 res = this%iminuti < that%iminuti
1236 
1237 END FUNCTION timedelta_lt
1238 
1239 
1240 ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
1241 TYPE(timedelta),INTENT(IN) :: this, that
1242 LOGICAL :: res
1243 
1244 IF (this == that) THEN
1245  res = .true.
1246 ELSE IF (this > that) THEN
1247  res = .true.
1248 ELSE
1249  res = .false.
1250 ENDIF
1251 
1252 END FUNCTION timedelta_ge
1253 
1254 
1255 elemental FUNCTION timedelta_le(this, that) RESULT(res)
1256 TYPE(timedelta),INTENT(IN) :: this, that
1257 LOGICAL :: res
1258 
1259 IF (this == that) THEN
1260  res = .true.
1261 ELSE IF (this < that) THEN
1262  res = .true.
1263 ELSE
1264  res = .false.
1265 ENDIF
1266 
1267 END FUNCTION timedelta_le
1268 
1269 
1270 ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
1271 TYPE(timedelta),INTENT(IN) :: this, that
1272 TYPE(timedelta) :: res
1273 
1274 res%iminuti = this%iminuti + that%iminuti
1275 res%month = this%month + that%month
1276 
1277 END FUNCTION timedelta_add
1278 
1279 
1280 ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
1281 TYPE(timedelta),INTENT(IN) :: this, that
1282 TYPE(timedelta) :: res
1283 
1284 res%iminuti = this%iminuti - that%iminuti
1285 res%month = this%month - that%month
1286 
1287 END FUNCTION timedelta_sub
1288 
1289 
1290 ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
1291 TYPE(timedelta),INTENT(IN) :: this
1292 INTEGER,INTENT(IN) :: n
1293 TYPE(timedelta) :: res
1294 
1295 res%iminuti = this%iminuti*n
1296 res%month = this%month*n
1297 
1298 END FUNCTION timedelta_mult
1299 
1300 
1301 ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
1302 INTEGER,INTENT(IN) :: n
1303 TYPE(timedelta),INTENT(IN) :: this
1304 TYPE(timedelta) :: res
1305 
1306 res%iminuti = this%iminuti*n
1307 res%month = this%month*n
1308 
1309 END FUNCTION timedelta_tlum
1310 
1311 
1312 ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
1313 TYPE(timedelta),INTENT(IN) :: this
1314 INTEGER,INTENT(IN) :: n
1315 TYPE(timedelta) :: res
1316 
1317 res%iminuti = this%iminuti/n
1318 res%month = this%month/n
1319 
1320 END FUNCTION timedelta_divint
1321 
1322 
1323 ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
1324 TYPE(timedelta),INTENT(IN) :: this, that
1325 INTEGER :: res
1326 
1327 res = int(this%iminuti/that%iminuti)
1328 
1329 END FUNCTION timedelta_divtd
1330 
1331 
1332 elemental FUNCTION timedelta_mod(this, that) RESULT(res)
1333 TYPE(timedelta),INTENT(IN) :: this, that
1334 TYPE(timedelta) :: res
1335 
1336 res%iminuti = mod(this%iminuti, that%iminuti)
1337 res%month = 0
1338 
1339 END FUNCTION timedelta_mod
1340 
1341 
1342 ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
1343 TYPE(datetime),INTENT(IN) :: this
1344 TYPE(timedelta),INTENT(IN) :: that
1345 TYPE(timedelta) :: res
1346 
1347 IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
1348  res = timedelta_0
1349 ELSE
1350  res%iminuti = mod(this%iminuti, that%iminuti)
1351  res%month = 0
1352 ENDIF
1353 
1354 END FUNCTION datetime_timedelta_mod
1355 
1356 
1357 ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
1358 TYPE(timedelta),INTENT(IN) :: this
1359 TYPE(timedelta) :: res
1360 
1361 res%iminuti = abs(this%iminuti)
1362 res%month = abs(this%month)
1363 
1364 END FUNCTION timedelta_abs
1365 
1366 
1371 SUBROUTINE timedelta_read_unit(this, unit)
1372 TYPE(timedelta),INTENT(out) :: this
1373 INTEGER, INTENT(in) :: unit
1374 
1375 CALL timedelta_vect_read_unit((/this/), unit)
1376 
1377 END SUBROUTINE timedelta_read_unit
1378 
1379 
1384 SUBROUTINE timedelta_vect_read_unit(this, unit)
1385 TYPE(timedelta) :: this(:)
1386 INTEGER, INTENT(in) :: unit
1387 
1388 CHARACTER(len=40) :: form
1389 CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
1390 INTEGER :: i
1391 
1392 ALLOCATE(dateiso(SIZE(this)))
1393 INQUIRE(unit, form=form)
1394 IF (form == 'FORMATTED') THEN
1395  READ(unit,'(3(A23,1X))')dateiso
1396 ELSE
1397  READ(unit)dateiso
1398 ENDIF
1399 DO i = 1, SIZE(dateiso)
1400  CALL init(this(i), isodate=dateiso(i))
1401 ENDDO
1402 DEALLOCATE(dateiso)
1403 
1404 END SUBROUTINE timedelta_vect_read_unit
1405 
1406 
1411 SUBROUTINE timedelta_write_unit(this, unit)
1412 TYPE(timedelta),INTENT(in) :: this
1413 INTEGER, INTENT(in) :: unit
1414 
1415 CALL timedelta_vect_write_unit((/this/), unit)
1416 
1417 END SUBROUTINE timedelta_write_unit
1418 
1419 
1424 SUBROUTINE timedelta_vect_write_unit(this, unit)
1425 TYPE(timedelta),INTENT(in) :: this(:)
1426 INTEGER, INTENT(in) :: unit
1427 
1428 CHARACTER(len=40) :: form
1429 CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
1430 INTEGER :: i
1431 
1432 ALLOCATE(dateiso(SIZE(this)))
1433 DO i = 1, SIZE(dateiso)
1434  CALL getval(this(i), isodate=dateiso(i))
1435 ENDDO
1436 INQUIRE(unit, form=form)
1437 IF (form == 'FORMATTED') THEN
1438  WRITE(unit,'(3(A23,1X))')dateiso
1439 ELSE
1440  WRITE(unit)dateiso
1441 ENDIF
1442 DEALLOCATE(dateiso)
1443 
1444 END SUBROUTINE timedelta_vect_write_unit
1445 
1446 
1447 ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
1448 TYPE(timedelta),INTENT(in) :: this
1449 LOGICAL :: res
1450 
1451 res = .not. this == timedelta_miss
1452 
1453 end FUNCTION c_e_timedelta
1454 
1455 
1456 elemental 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 
1473 INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
1474 INTEGER,intent(out) :: iminuti
1475 
1476 iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
1477 
1478 END SUBROUTINE jeladata5
1479 
1480 
1481 elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
1482 INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
1483 INTEGER(KIND=int_ll),intent(out) :: imillisec
1484 
1485 imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
1486  + imsec
1487 
1488 END SUBROUTINE jeladata5_1
1489 
1490 
1491 
1492 elemental 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 
1511 INTEGER,intent(in) :: iminuti
1512 INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
1513 
1514 INTEGER ::igiorno
1516 imin = mod(iminuti,60)
1517 ihour = mod(iminuti,1440)/60
1518 igiorno = iminuti/1440
1519 IF (mod(iminuti,1440) < 0) igiorno = igiorno-1
1520 CALL ndyin(igiorno,iday,imonth,iyear)
1521 
1522 END SUBROUTINE jeladata6
1523 
1524 
1525 elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
1526 INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
1527 INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
1528 
1529 INTEGER :: igiorno
1530 
1531 imsec = int(mod(imillisec, 60000_int_ll)) ! partial msec
1532 !imin = MOD(imillisec/60000_int_ll, 60)
1533 !ihour = MOD(imillisec/3600000_int_ll, 24)
1534 imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
1535 ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
1536 igiorno = int(imillisec/86400000_int_ll)
1537 !IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
1538 CALL ndyin(igiorno,iday,imonth,iyear)
1539 
1540 END SUBROUTINE jeladata6_1
1541 
1542 
1543 elemental 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
1549 !
1550 !!omend
1551 
1552 INTEGER,intent(in) :: ndays
1553 INTEGER,intent(out) :: igg, imm, iaa
1554 integer :: n,lndays
1555 
1556 lndays=ndays
1557 
1558 n = lndays/d400
1559 lndays = lndays - n*d400
1560 iaa = year0 + n*400
1561 n = min(lndays/d100, 3)
1562 lndays = lndays - n*d100
1563 iaa = iaa + n*100
1564 n = lndays/d4
1565 lndays = lndays - n*d4
1566 iaa = iaa + n*4
1567 n = min(lndays/d1, 3)
1568 lndays = lndays - n*d1
1569 iaa = iaa + n
1570 n = bisextilis(iaa)
1571 DO imm = 1, 12
1572  IF (lndays < ianno(imm+1,n)) EXIT
1573 ENDDO
1574 igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
1575 
1576 END SUBROUTINE ndyin
1577 
1578 
1579 integer 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 
1596 INTEGER, intent(in) :: igg, imm, iaa
1597 
1598 INTEGER :: lmonth, lyear
1599 
1600 ! Limito il mese a [1-12] e correggo l'anno coerentemente
1601 lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
1602 lyear = iaa + (imm - lmonth)/12
1603 ndays = igg+ianno(lmonth, bisextilis(lyear))
1604 ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
1605  (lyear-year0)/400
1606 
1607 END FUNCTION ndays
1608 
1609 
1610 elemental FUNCTION bisextilis(annum)
1611 INTEGER,INTENT(in) :: annum
1612 INTEGER :: bisextilis
1613 
1614 IF (mod(annum,4) == 0 .AND. (mod(annum,400) == 0 .EQV. mod(annum,100) == 0)) THEN
1615  bisextilis = 2
1616 ELSE
1617  bisextilis = 1
1618 ENDIF
1619 END FUNCTION bisextilis
1620 
1621 
1622 ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
1623 TYPE(cyclicdatetime),INTENT(IN) :: this, that
1624 LOGICAL :: res
1625 
1626 res = .true.
1627 if (this%minute /= that%minute) res=.false.
1628 if (this%hour /= that%hour) res=.false.
1629 if (this%day /= that%day) res=.false.
1630 if (this%month /= that%month) res=.false.
1631 if (this%tendaysp /= that%tendaysp) res=.false.
1632 
1633 END FUNCTION cyclicdatetime_eq
1634 
1635 
1636 ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
1637 TYPE(cyclicdatetime),INTENT(IN) :: this
1638 TYPE(datetime),INTENT(IN) :: that
1639 LOGICAL :: res
1640 
1641 integer :: minute,hour,day,month
1642 
1643 call getval(that,minute=minute,hour=hour,day=day,month=month)
1644 
1645 res = .true.
1646 if (c_e(this%minute) .and. this%minute /= minute) res=.false.
1647 if (c_e(this%hour) .and. this%hour /= hour) res=.false.
1648 if (c_e(this%day) .and. this%day /= day) res=.false.
1649 if (c_e(this%month) .and. this%month /= month) res=.false.
1650 if (c_e(this%tendaysp)) then
1651  if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
1652 end if
1653 
1654 END FUNCTION cyclicdatetime_datetime_eq
1655 
1656 
1657 ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
1658 TYPE(datetime),INTENT(IN) :: this
1659 TYPE(cyclicdatetime),INTENT(IN) :: that
1660 LOGICAL :: res
1661 
1662 integer :: minute,hour,day,month
1663 
1664 call getval(this,minute=minute,hour=hour,day=day,month=month)
1665 
1666 res = .true.
1667 if (c_e(that%minute) .and. that%minute /= minute) res=.false.
1668 if (c_e(that%hour) .and. that%hour /= hour) res=.false.
1669 if (c_e(that%day) .and. that%day /= day) res=.false.
1670 if (c_e(that%month) .and. that%month /= month) res=.false.
1671 
1672 if (c_e(that%tendaysp)) then
1673  if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
1674 end if
1675 
1676 
1677 END FUNCTION datetime_cyclicdatetime_eq
1678 
1679 ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
1680 TYPE(cyclicdatetime),INTENT(in) :: this
1681 LOGICAL :: res
1682 
1683 res = .not. this == cyclicdatetime_miss
1684 
1685 end FUNCTION c_e_cyclicdatetime
1686 
1687 
1690 FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
1691 INTEGER,INTENT(IN),OPTIONAL :: tendaysp
1692 INTEGER,INTENT(IN),OPTIONAL :: month
1693 INTEGER,INTENT(IN),OPTIONAL :: day
1694 INTEGER,INTENT(IN),OPTIONAL :: hour
1695 INTEGER,INTENT(IN),OPTIONAL :: minute
1696 CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
1697 
1698 integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
1699 
1700 
1701 TYPE(cyclicdatetime) :: this
1702 
1703 if (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
1739 else
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)
1745 end if
1746 
1747 END FUNCTION cyclicdatetime_new
1748 
1751 elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
1752 TYPE(cyclicdatetime),INTENT(IN) :: this
1753 
1754 CHARACTER(len=80) :: char
1755 
1756 char=to_char(this%tendaysp)//";"//to_char(this%month)//";"//to_char(this%day)//";"//&
1757 to_char(this%hour)//";"//to_char(this%minute)
1758 
1759 END FUNCTION cyclicdatetime_to_char
1760 
1761 
1774 FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
1775 TYPE(cyclicdatetime),INTENT(IN) :: this
1776 
1777 TYPE(datetime) :: dtc
1779 integer :: year,month,day,hour
1780 
1781 dtc = datetime_miss
1782 
1783 ! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
1784 if ( .not. c_e(this)) then
1785  dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
1786  return
1787 end if
1788 
1789 ! minute present -> not good for conventional datetime
1790 if (c_e(this%minute)) return
1791 ! day, month and tendaysp present -> no good
1792 if (c_e(this%day) .and. c_e(this%month) .and. c_e(this%tendaysp)) return
1793 
1794 if (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)
1796 else 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)
1799 else if (c_e(this%month)) then
1800  dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
1801 else if (c_e(this%day)) then
1802  ! only day present -> no good
1803  return
1804 end if
1805 
1806 if (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)
1809 end if
1810 
1811 
1812 END FUNCTION cyclicdatetime_to_conventional
1814 
1815 
1816 FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
1817 TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
1818 
1819 CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
1820 
1821 char=cyclicdatetime_to_char(in)
1822 
1823 END FUNCTION trim_cyclicdatetime_to_char
1824 
1825 
1826 
1827 SUBROUTINE display_cyclicdatetime(this)
1828 TYPE(cyclicdatetime),INTENT(in) :: this
1829 
1830 print*,"CYCLICDATETIME: ",to_char(this)
1831 
1832 end subroutine display_cyclicdatetime
1833 
1834 
1835 #include "array_utilities_inc.F90"
1836 
1837 END MODULE datetime_class
1838 
Classi per la gestione delle coordinate temporali.
Method for removing elements of the array at a desired position.
Definitions of constants and functions for working with missing values.
Functions that return a trimmed CHARACTER representation of the input variable.
Gestione degli errori.
Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o...
Operatore di valore assoluto di un intervallo.
Index method with sorted array.
Method for inserting elements of the array at a desired position.
Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ...
Distruttori per le 2 classi.
Index method.
Restituiscono il valore dell&#39;oggetto in forma di stringa stampabile.
Method for packing the array object reducing at a minimum the memory occupation, without destroying i...
Restituiscono il valore dell&#39;oggetto nella forma desiderata.
Operatore di resto della divisione.
Costruttori per le classi datetime e timedelta.
Class for expressing a relative time interval.
Quick method to append an element to the array.
classe per la gestione del logging
Utilities for CHARACTER variables.
Class for expressing a cyclic datetime.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:242
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.

Generated with Doxygen.