libsim  Versione 7.2.1
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)
80 TYPE(timedelta), PARAMETER :: timedelta_miss=timedelta(illmiss, 0)
82 TYPE(timedelta), PARAMETER :: timedelta_0=timedelta(0, 0)
84 INTEGER, PARAMETER :: datetime_utc=1
86 INTEGER, PARAMETER :: datetime_local=2
88 TYPE(datetime), PARAMETER :: datetime_min=datetime(-huge(1_int_ll)-1)
90 TYPE(datetime), PARAMETER :: datetime_max=datetime(huge(1_int_ll)-1)
92 TYPE(timedelta), PARAMETER :: timedelta_min=timedelta(-huge(1_int_ll)-1,0)
94 TYPE(timedelta), PARAMETER :: timedelta_max=timedelta(huge(1_int_ll)-1,0)
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
267 
278 INTERFACE mod
279  MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
280 END INTERFACE
281 
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"
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 
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
376 
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 
636 
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
836 
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
1165 
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)
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
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
1515 
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
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
1778 
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
1813 
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 
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 
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:255
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.
Class for expressing a cyclic datetime.
Class for expressing an absolute time value.
Class for expressing a relative time interval.

Generated with Doxygen.