libsim Versione 7.2.0

◆ inssor_datetime()

subroutine inssor_datetime ( type(datetime), dimension (:), intent(inout)  xdont)
private

Sorts into increasing order (Insertion sort) Sorts XDONT into increasing order (Insertion sort) This subroutine uses insertion sort.

It does not use any work array and is faster when XDONT is of very small size (< 20), or already almost sorted, so it is used in a final pass when the partial quicksorting has left a sequence of small subsets and that sorting is only necessary within each subset to complete the process. Michel Olagnon - Apr. 2000

Definizione alla linea 3287 del file datetime_class.F90.

3288! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
3289! authors:
3290! Davide Cesari <dcesari@arpa.emr.it>
3291! Paolo Patruno <ppatruno@arpa.emr.it>
3292
3293! This program is free software; you can redistribute it and/or
3294! modify it under the terms of the GNU General Public License as
3295! published by the Free Software Foundation; either version 2 of
3296! the License, or (at your option) any later version.
3297
3298! This program is distributed in the hope that it will be useful,
3299! but WITHOUT ANY WARRANTY; without even the implied warranty of
3300! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3301! GNU General Public License for more details.
3302
3303! You should have received a copy of the GNU General Public License
3304! along with this program. If not, see <http://www.gnu.org/licenses/>.
3305#include "config.h"
3306
3320MODULE datetime_class
3321USE kinds
3322USE log4fortran
3323USE err_handling
3327IMPLICIT NONE
3328
3329INTEGER, PARAMETER :: dateint=selected_int_kind(13)
3330
3332TYPE datetime
3333 PRIVATE
3334 INTEGER(KIND=int_ll) :: iminuti
3335END TYPE datetime
3336
3344TYPE timedelta
3345 PRIVATE
3346 INTEGER(KIND=int_ll) :: iminuti
3347 INTEGER :: month
3348END TYPE timedelta
3349
3350
3354TYPE cyclicdatetime
3355 PRIVATE
3356 INTEGER :: minute
3357 INTEGER :: hour
3358 INTEGER :: day
3359 INTEGER :: tendaysp
3360 INTEGER :: month
3361END TYPE cyclicdatetime
3362
3363
3365TYPE(datetime), PARAMETER :: datetime_miss=datetime(illmiss)
3367TYPE(timedelta), PARAMETER :: timedelta_miss=timedelta(illmiss, 0)
3369TYPE(timedelta), PARAMETER :: timedelta_0=timedelta(0, 0)
3371INTEGER, PARAMETER :: datetime_utc=1
3373INTEGER, PARAMETER :: datetime_local=2
3375TYPE(datetime), PARAMETER :: datetime_min=datetime(-huge(1_int_ll)-1)
3377TYPE(datetime), PARAMETER :: datetime_max=datetime(huge(1_int_ll)-1)
3379TYPE(timedelta), PARAMETER :: timedelta_min=timedelta(-huge(1_int_ll)-1,0)
3381TYPE(timedelta), PARAMETER :: timedelta_max=timedelta(huge(1_int_ll)-1,0)
3383TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
3384
3385
3386INTEGER(kind=dateint), PARAMETER :: &
3387 sec_in_day=86400, &
3388 sec_in_hour=3600, &
3389 sec_in_min=60, &
3390 min_in_day=1440, &
3391 min_in_hour=60, &
3392 hour_in_day=24
3393
3394INTEGER,PARAMETER :: &
3395 year0=1, & ! anno di origine per iminuti
3396 d1=365, & ! giorni/1 anno nel calendario gregoriano
3397 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
3398 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
3399 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
3400 ianno(13,2)=reshape((/ &
3401 0,31,59,90,120,151,181,212,243,273,304,334,365, &
3402 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
3403
3404INTEGER(KIND=int_ll),PARAMETER :: &
3405 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
3406
3410INTERFACE init
3411 MODULE PROCEDURE datetime_init, timedelta_init
3412END INTERFACE
3413
3416INTERFACE delete
3417 MODULE PROCEDURE datetime_delete, timedelta_delete
3418END INTERFACE
3419
3421INTERFACE getval
3422 MODULE PROCEDURE datetime_getval, timedelta_getval
3423END INTERFACE
3424
3426INTERFACE to_char
3427 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
3428END INTERFACE
3429
3430
3448INTERFACE t2c
3449 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
3450END INTERFACE
3451
3457INTERFACE OPERATOR (==)
3458 MODULE PROCEDURE datetime_eq, timedelta_eq, &
3459 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
3460END INTERFACE
3461
3467INTERFACE OPERATOR (/=)
3468 MODULE PROCEDURE datetime_ne, timedelta_ne
3469END INTERFACE
3470
3478INTERFACE OPERATOR (>)
3479 MODULE PROCEDURE datetime_gt, timedelta_gt
3480END INTERFACE
3481
3489INTERFACE OPERATOR (<)
3490 MODULE PROCEDURE datetime_lt, timedelta_lt
3491END INTERFACE
3492
3500INTERFACE OPERATOR (>=)
3501 MODULE PROCEDURE datetime_ge, timedelta_ge
3502END INTERFACE
3503
3511INTERFACE OPERATOR (<=)
3512 MODULE PROCEDURE datetime_le, timedelta_le
3513END INTERFACE
3514
3521INTERFACE OPERATOR (+)
3522 MODULE PROCEDURE datetime_add, timedelta_add
3523END INTERFACE
3524
3532INTERFACE OPERATOR (-)
3533 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
3534END INTERFACE
3535
3541INTERFACE OPERATOR (*)
3542 MODULE PROCEDURE timedelta_mult, timedelta_tlum
3543END INTERFACE
3544
3551INTERFACE OPERATOR (/)
3552 MODULE PROCEDURE timedelta_divint, timedelta_divtd
3553END INTERFACE
3554
3565INTERFACE mod
3566 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3567END INTERFACE
3568
3571INTERFACE abs
3572 MODULE PROCEDURE timedelta_abs
3573END INTERFACE
3574
3577INTERFACE read_unit
3578 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3579 timedelta_read_unit, timedelta_vect_read_unit
3580END INTERFACE
3581
3584INTERFACE write_unit
3585 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3586 timedelta_write_unit, timedelta_vect_write_unit
3587END INTERFACE
3588
3590INTERFACE display
3591 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3592END INTERFACE
3593
3595INTERFACE c_e
3596 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
3597END INTERFACE
3598
3599#undef VOL7D_POLY_TYPE
3600#undef VOL7D_POLY_TYPES
3601#undef ENABLE_SORT
3602#define VOL7D_POLY_TYPE TYPE(datetime)
3603#define VOL7D_POLY_TYPES _datetime
3604#define ENABLE_SORT
3605#include "array_utilities_pre.F90"
3606
3607
3608#define ARRAYOF_ORIGTYPE TYPE(datetime)
3609#define ARRAYOF_TYPE arrayof_datetime
3610#define ARRAYOF_ORIGEQ 1
3611#include "arrayof_pre.F90"
3612! from arrayof
3613
3614PRIVATE
3615
3616PUBLIC datetime, datetime_miss, datetime_utc, datetime_local, &
3617 datetime_min, datetime_max, &
3618 datetime_new, datetime_new_now, init, delete, getval, to_char, t2c, &
3620 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3621 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3622 OPERATOR(*), OPERATOR(/), mod, abs, &
3623 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3624 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3625 display, c_e, &
3626 count_distinct, pack_distinct, &
3627 count_distinct_sorted, pack_distinct_sorted, &
3628 count_and_pack_distinct, &
3629 map_distinct, map_inv_distinct, index, index_sorted, sort, &
3630 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
3631PUBLIC insert, append, remove, packarray
3632PUBLIC insert_unique, append_unique
3633PUBLIC cyclicdatetime_to_conventional
3634
3635CONTAINS
3636
3637
3638! ==============
3639! == datetime ==
3640! ==============
3641
3648ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3649 unixtime, isodate, simpledate) RESULT(this)
3650INTEGER,INTENT(IN),OPTIONAL :: year
3651INTEGER,INTENT(IN),OPTIONAL :: month
3652INTEGER,INTENT(IN),OPTIONAL :: day
3653INTEGER,INTENT(IN),OPTIONAL :: hour
3654INTEGER,INTENT(IN),OPTIONAL :: minute
3655INTEGER,INTENT(IN),OPTIONAL :: msec
3656INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3657CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3658CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3659
3660TYPE(datetime) :: this
3661INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3662CHARACTER(len=23) :: datebuf
3663
3664IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3665 lyear = year
3666 IF (PRESENT(month)) THEN
3667 lmonth = month
3668 ELSE
3669 lmonth = 1
3670 ENDIF
3671 IF (PRESENT(day)) THEN
3672 lday = day
3673 ELSE
3674 lday = 1
3675 ENDIF
3676 IF (PRESENT(hour)) THEN
3677 lhour = hour
3678 ELSE
3679 lhour = 0
3680 ENDIF
3681 IF (PRESENT(minute)) THEN
3682 lminute = minute
3683 ELSE
3684 lminute = 0
3685 ENDIF
3686 IF (PRESENT(msec)) THEN
3687 lmsec = msec
3688 ELSE
3689 lmsec = 0
3690 ENDIF
3691
3692 if (c_e(lday) .and. c_e(lmonth) .and. c_e(lyear) .and. c_e(lhour) &
3693 .and. c_e(lminute) .and. c_e(lmsec)) then
3694 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3695 else
3696 this=datetime_miss
3697 end if
3698
3699ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3700 if (c_e(unixtime)) then
3701 this%iminuti = (unixtime + unsec)*1000
3702 else
3703 this=datetime_miss
3704 end if
3705
3706ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3707
3708 IF (c_e(isodate) .AND. len_trim(isodate) > 0) THEN
3709 datebuf(1:23) = '0001-01-01 00:00:00.000'
3710 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3711 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3712 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3713 lmsec = lmsec + lsec*1000
3714 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3715 RETURN
3716
3717100 CONTINUE ! condizione di errore in isodate
3718 CALL delete(this)
3719 RETURN
3720 ELSE
3721 this = datetime_miss
3722 ENDIF
3723
3724ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3725 IF (c_e(simpledate) .AND. len_trim(simpledate) > 0)THEN
3726 datebuf(1:17) = '00010101000000000'
3727 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3728 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3729 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3730 lmsec = lmsec + lsec*1000
3731 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3732 RETURN
3733
3734120 CONTINUE ! condizione di errore in simpledate
3735 CALL delete(this)
3736 RETURN
3737 ELSE
3738 this = datetime_miss
3739 ENDIF
3740
3741ELSE
3742 this = datetime_miss
3743ENDIF
3744
3745END FUNCTION datetime_new
3746
3747
3749FUNCTION datetime_new_now(now) RESULT(this)
3750INTEGER,INTENT(IN) :: now
3751TYPE(datetime) :: this
3752
3753INTEGER :: dt(8)
3754
3755IF (c_e(now)) THEN
3756 CALL date_and_time(values=dt)
3757 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3758 CALL init(this, year=dt(1), month=dt(2), day=dt(3), hour=dt(5), minute=dt(6), &
3759 msec=dt(7)*1000+dt(8))
3760ELSE
3761 this = datetime_miss
3762ENDIF
3763
3764END FUNCTION datetime_new_now
3765
3766
3773SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3774 unixtime, isodate, simpledate, now)
3775TYPE(datetime),INTENT(INOUT) :: this
3776INTEGER,INTENT(IN),OPTIONAL :: year
3777INTEGER,INTENT(IN),OPTIONAL :: month
3778INTEGER,INTENT(IN),OPTIONAL :: day
3779INTEGER,INTENT(IN),OPTIONAL :: hour
3780INTEGER,INTENT(IN),OPTIONAL :: minute
3781INTEGER,INTENT(IN),OPTIONAL :: msec
3782INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3783CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3784CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3785INTEGER,INTENT(IN),OPTIONAL :: now
3786
3787IF (PRESENT(now)) THEN
3788 this = datetime_new_now(now)
3789ELSE
3790 this = datetime_new(year, month, day, hour, minute, msec, &
3791 unixtime, isodate, simpledate)
3792ENDIF
3793
3794END SUBROUTINE datetime_init
3795
3796
3797ELEMENTAL SUBROUTINE datetime_delete(this)
3798TYPE(datetime),INTENT(INOUT) :: this
3799
3800this%iminuti = illmiss
3801
3802END SUBROUTINE datetime_delete
3803
3804
3809PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3810 unixtime, isodate, simpledate, oraclesimdate)
3811TYPE(datetime),INTENT(IN) :: this
3812INTEGER,INTENT(OUT),OPTIONAL :: year
3813INTEGER,INTENT(OUT),OPTIONAL :: month
3814INTEGER,INTENT(OUT),OPTIONAL :: day
3815INTEGER,INTENT(OUT),OPTIONAL :: hour
3816INTEGER,INTENT(OUT),OPTIONAL :: minute
3817INTEGER,INTENT(OUT),OPTIONAL :: msec
3818INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3819CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3820CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3821CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3822
3823INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3824CHARACTER(len=23) :: datebuf
3825
3826IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3827 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3828 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3829
3830 IF (this == datetime_miss) THEN
3831
3832 IF (PRESENT(msec)) THEN
3833 msec = imiss
3834 ENDIF
3835 IF (PRESENT(minute)) THEN
3836 minute = imiss
3837 ENDIF
3838 IF (PRESENT(hour)) THEN
3839 hour = imiss
3840 ENDIF
3841 IF (PRESENT(day)) THEN
3842 day = imiss
3843 ENDIF
3844 IF (PRESENT(month)) THEN
3845 month = imiss
3846 ENDIF
3847 IF (PRESENT(year)) THEN
3848 year = imiss
3849 ENDIF
3850 IF (PRESENT(isodate)) THEN
3851 isodate = cmiss
3852 ENDIF
3853 IF (PRESENT(simpledate)) THEN
3854 simpledate = cmiss
3855 ENDIF
3856 IF (PRESENT(oraclesimdate)) THEN
3857!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3858!!$ 'obsoleto, usare piuttosto simpledate')
3859 oraclesimdate=cmiss
3860 ENDIF
3861 IF (PRESENT(unixtime)) THEN
3862 unixtime = illmiss
3863 ENDIF
3864
3865 ELSE
3866
3867 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3868 IF (PRESENT(msec)) THEN
3869 msec = lmsec
3870 ENDIF
3871 IF (PRESENT(minute)) THEN
3872 minute = lminute
3873 ENDIF
3874 IF (PRESENT(hour)) THEN
3875 hour = lhour
3876 ENDIF
3877 IF (PRESENT(day)) THEN
3878 day = lday
3879 ENDIF
3880 IF (PRESENT(month)) THEN
3881 month = lmonth
3882 ENDIF
3883 IF (PRESENT(year)) THEN
3884 year = lyear
3885 ENDIF
3886 IF (PRESENT(isodate)) THEN
3887 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3888 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3889 '.', mod(lmsec, 1000)
3890 isodate = datebuf(1:min(len(isodate),23))
3891 ENDIF
3892 IF (PRESENT(simpledate)) THEN
3893 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3894 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3895 simpledate = datebuf(1:min(len(simpledate),17))
3896 ENDIF
3897 IF (PRESENT(oraclesimdate)) THEN
3898!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3899!!$ 'obsoleto, usare piuttosto simpledate')
3900 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3901 ENDIF
3902 IF (PRESENT(unixtime)) THEN
3903 unixtime = this%iminuti/1000_int_ll-unsec
3904 ENDIF
3905
3906 ENDIF
3907ENDIF
3908
3909END SUBROUTINE datetime_getval
3910
3911
3914elemental FUNCTION datetime_to_char(this) RESULT(char)
3915TYPE(datetime),INTENT(IN) :: this
3916
3917CHARACTER(len=23) :: char
3918
3919CALL getval(this, isodate=char)
3920
3921END FUNCTION datetime_to_char
3922
3923
3924FUNCTION trim_datetime_to_char(in) RESULT(char)
3925TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3926
3927CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3928
3929char=datetime_to_char(in)
3930
3931END FUNCTION trim_datetime_to_char
3932
3933
3934
3935SUBROUTINE display_datetime(this)
3936TYPE(datetime),INTENT(in) :: this
3937
3938print*,"TIME: ",to_char(this)
3939
3940end subroutine display_datetime
3941
3942
3943
3944SUBROUTINE display_timedelta(this)
3945TYPE(timedelta),INTENT(in) :: this
3946
3947print*,"TIMEDELTA: ",to_char(this)
3948
3949end subroutine display_timedelta
3950
3951
3952
3953ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3954TYPE(datetime),INTENT(in) :: this
3955LOGICAL :: res
3956
3957res = .not. this == datetime_miss
3958
3959end FUNCTION c_e_datetime
3960
3961
3962ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3963TYPE(datetime),INTENT(IN) :: this, that
3964LOGICAL :: res
3965
3966res = this%iminuti == that%iminuti
3967
3968END FUNCTION datetime_eq
3969
3970
3971ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3972TYPE(datetime),INTENT(IN) :: this, that
3973LOGICAL :: res
3974
3975res = .NOT.(this == that)
3976
3977END FUNCTION datetime_ne
3978
3979
3980ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3981TYPE(datetime),INTENT(IN) :: this, that
3982LOGICAL :: res
3983
3984res = this%iminuti > that%iminuti
3985
3986END FUNCTION datetime_gt
3987
3988
3989ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3990TYPE(datetime),INTENT(IN) :: this, that
3991LOGICAL :: res
3992
3993res = this%iminuti < that%iminuti
3994
3995END FUNCTION datetime_lt
3996
3997
3998ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3999TYPE(datetime),INTENT(IN) :: this, that
4000LOGICAL :: res
4001
4002IF (this == that) THEN
4003 res = .true.
4004ELSE IF (this > that) THEN
4005 res = .true.
4006ELSE
4007 res = .false.
4008ENDIF
4009
4010END FUNCTION datetime_ge
4011
4012
4013ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
4014TYPE(datetime),INTENT(IN) :: this, that
4015LOGICAL :: res
4016
4017IF (this == that) THEN
4018 res = .true.
4019ELSE IF (this < that) THEN
4020 res = .true.
4021ELSE
4022 res = .false.
4023ENDIF
4024
4025END FUNCTION datetime_le
4026
4027
4028FUNCTION datetime_add(this, that) RESULT(res)
4029TYPE(datetime),INTENT(IN) :: this
4030TYPE(timedelta),INTENT(IN) :: that
4031TYPE(datetime) :: res
4032
4033INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
4034
4035IF (this == datetime_miss .OR. that == timedelta_miss) THEN
4036 res = datetime_miss
4037ELSE
4038 res%iminuti = this%iminuti + that%iminuti
4039 IF (that%month /= 0) THEN
4040 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
4041 minute=lminute, msec=lmsec)
4042 CALL init(res, year=lyear, month=lmonth+that%month, day=lday, &
4043 hour=lhour, minute=lminute, msec=lmsec)
4044 ENDIF
4045ENDIF
4046
4047END FUNCTION datetime_add
4048
4049
4050ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
4051TYPE(datetime),INTENT(IN) :: this, that
4052TYPE(timedelta) :: res
4053
4054IF (this == datetime_miss .OR. that == datetime_miss) THEN
4055 res = timedelta_miss
4056ELSE
4057 res%iminuti = this%iminuti - that%iminuti
4058 res%month = 0
4059ENDIF
4060
4061END FUNCTION datetime_subdt
4062
4063
4064FUNCTION datetime_subtd(this, that) RESULT(res)
4065TYPE(datetime),INTENT(IN) :: this
4066TYPE(timedelta),INTENT(IN) :: that
4067TYPE(datetime) :: res
4068
4069INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
4070
4071IF (this == datetime_miss .OR. that == timedelta_miss) THEN
4072 res = datetime_miss
4073ELSE
4074 res%iminuti = this%iminuti - that%iminuti
4075 IF (that%month /= 0) THEN
4076 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
4077 minute=lminute, msec=lmsec)
4078 CALL init(res, year=lyear, month=lmonth-that%month, day=lday, &
4079 hour=lhour, minute=lminute, msec=lmsec)
4080 ENDIF
4081ENDIF
4082
4083END FUNCTION datetime_subtd
4084
4085
4090SUBROUTINE datetime_read_unit(this, unit)
4091TYPE(datetime),INTENT(out) :: this
4092INTEGER, INTENT(in) :: unit
4093CALL datetime_vect_read_unit((/this/), unit)
4094
4095END SUBROUTINE datetime_read_unit
4096
4097
4102SUBROUTINE datetime_vect_read_unit(this, unit)
4103TYPE(datetime) :: this(:)
4104INTEGER, INTENT(in) :: unit
4105
4106CHARACTER(len=40) :: form
4107CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4108INTEGER :: i
4109
4110ALLOCATE(dateiso(SIZE(this)))
4111INQUIRE(unit, form=form)
4112IF (form == 'FORMATTED') THEN
4113 READ(unit,'(A23,1X)')dateiso
4114ELSE
4115 READ(unit)dateiso
4116ENDIF
4117DO i = 1, SIZE(dateiso)
4118 CALL init(this(i), isodate=dateiso(i))
4119ENDDO
4120DEALLOCATE(dateiso)
4121
4122END SUBROUTINE datetime_vect_read_unit
4123
4124
4129SUBROUTINE datetime_write_unit(this, unit)
4130TYPE(datetime),INTENT(in) :: this
4131INTEGER, INTENT(in) :: unit
4132
4133CALL datetime_vect_write_unit((/this/), unit)
4134
4135END SUBROUTINE datetime_write_unit
4136
4137
4142SUBROUTINE datetime_vect_write_unit(this, unit)
4143TYPE(datetime),INTENT(in) :: this(:)
4144INTEGER, INTENT(in) :: unit
4145
4146CHARACTER(len=40) :: form
4147CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4148INTEGER :: i
4149
4150ALLOCATE(dateiso(SIZE(this)))
4151DO i = 1, SIZE(dateiso)
4152 CALL getval(this(i), isodate=dateiso(i))
4153ENDDO
4154INQUIRE(unit, form=form)
4155IF (form == 'FORMATTED') THEN
4156 WRITE(unit,'(A23,1X)')dateiso
4157ELSE
4158 WRITE(unit)dateiso
4159ENDIF
4160DEALLOCATE(dateiso)
4161
4162END SUBROUTINE datetime_vect_write_unit
4163
4164
4165#include "arrayof_post.F90"
4166
4167
4168! ===============
4169! == timedelta ==
4170! ===============
4177FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
4178 isodate, simpledate, oraclesimdate) RESULT (this)
4179INTEGER,INTENT(IN),OPTIONAL :: year
4180INTEGER,INTENT(IN),OPTIONAL :: month
4181INTEGER,INTENT(IN),OPTIONAL :: day
4182INTEGER,INTENT(IN),OPTIONAL :: hour
4183INTEGER,INTENT(IN),OPTIONAL :: minute
4184INTEGER,INTENT(IN),OPTIONAL :: sec
4185INTEGER,INTENT(IN),OPTIONAL :: msec
4186CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
4187CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
4188CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
4189
4190TYPE(timedelta) :: this
4191
4192CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
4193 isodate, simpledate, oraclesimdate)
4194
4195END FUNCTION timedelta_new
4196
4197
4202SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
4203 isodate, simpledate, oraclesimdate)
4204TYPE(timedelta),INTENT(INOUT) :: this
4205INTEGER,INTENT(IN),OPTIONAL :: year
4206INTEGER,INTENT(IN),OPTIONAL :: month
4207INTEGER,INTENT(IN),OPTIONAL :: day
4208INTEGER,INTENT(IN),OPTIONAL :: hour
4209INTEGER,INTENT(IN),OPTIONAL :: minute
4210INTEGER,INTENT(IN),OPTIONAL :: sec
4211INTEGER,INTENT(IN),OPTIONAL :: msec
4212CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
4213CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
4214CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
4215
4216INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
4217CHARACTER(len=23) :: datebuf
4218
4219this%month = 0
4220
4221IF (PRESENT(isodate)) THEN
4222 datebuf(1:23) = '0000000000 00:00:00.000'
4223 l = len_trim(isodate)
4224! IF (l > 0) THEN
4225 n = index(trim(isodate), ' ') ! align blank space separator
4226 IF (n > 0) THEN
4227 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
4228 datebuf(12-n:12-n+l-1) = isodate(:l)
4229 ELSE
4230 datebuf(1:l) = isodate(1:l)
4231 ENDIF
4232! ENDIF
4233
4234! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
4235 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
4236 h, m, s, ms
4237 this%month = lmonth + 12*lyear
4238 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4239 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4240 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4241 RETURN
4242
4243200 CONTINUE ! condizione di errore in isodate
4244 CALL delete(this)
4245 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
4246 CALL raise_error()
4247
4248ELSE IF (PRESENT(simpledate)) THEN
4249 datebuf(1:17) = '00000000000000000'
4250 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
4251 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
4252 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4253 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4254 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4255
4256220 CONTINUE ! condizione di errore in simpledate
4257 CALL delete(this)
4258 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
4259 CALL raise_error()
4260 RETURN
4261
4262ELSE IF (PRESENT(oraclesimdate)) THEN
4263 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
4264 'obsoleto, usare piuttosto simpledate')
4265 READ(oraclesimdate, '(I8,2I2)')d, h, m
4266 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4267 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
4268
4269ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
4270 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
4271 .and. .not. present(msec) .and. .not. present(isodate) &
4272 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
4273
4274 this=timedelta_miss
4275
4276ELSE
4277 this%iminuti = 0
4278 IF (PRESENT(year)) THEN
4279 if (c_e(year))then
4280 this%month = this%month + year*12
4281 else
4282 this=timedelta_miss
4283 return
4284 end if
4285 ENDIF
4286 IF (PRESENT(month)) THEN
4287 if (c_e(month))then
4288 this%month = this%month + month
4289 else
4290 this=timedelta_miss
4291 return
4292 end if
4293 ENDIF
4294 IF (PRESENT(day)) THEN
4295 if (c_e(day))then
4296 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
4297 else
4298 this=timedelta_miss
4299 return
4300 end if
4301 ENDIF
4302 IF (PRESENT(hour)) THEN
4303 if (c_e(hour))then
4304 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
4305 else
4306 this=timedelta_miss
4307 return
4308 end if
4309 ENDIF
4310 IF (PRESENT(minute)) THEN
4311 if (c_e(minute))then
4312 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
4313 else
4314 this=timedelta_miss
4315 return
4316 end if
4317 ENDIF
4318 IF (PRESENT(sec)) THEN
4319 if (c_e(sec))then
4320 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
4321 else
4322 this=timedelta_miss
4323 return
4324 end if
4325 ENDIF
4326 IF (PRESENT(msec)) THEN
4327 if (c_e(msec))then
4328 this%iminuti = this%iminuti + msec
4329 else
4330 this=timedelta_miss
4331 return
4332 end if
4333 ENDIF
4334ENDIF
4335
4336
4337
4338
4339END SUBROUTINE timedelta_init
4340
4341
4342SUBROUTINE timedelta_delete(this)
4343TYPE(timedelta),INTENT(INOUT) :: this
4344
4345this%iminuti = imiss
4346this%month = 0
4347
4348END SUBROUTINE timedelta_delete
4349
4350
4355PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
4356 day, hour, minute, sec, msec, &
4357 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
4358TYPE(timedelta),INTENT(IN) :: this
4359INTEGER,INTENT(OUT),OPTIONAL :: year
4360INTEGER,INTENT(OUT),OPTIONAL :: month
4361INTEGER,INTENT(OUT),OPTIONAL :: amonth
4362INTEGER,INTENT(OUT),OPTIONAL :: day
4363INTEGER,INTENT(OUT),OPTIONAL :: hour
4364INTEGER,INTENT(OUT),OPTIONAL :: minute
4365INTEGER,INTENT(OUT),OPTIONAL :: sec
4366INTEGER,INTENT(OUT),OPTIONAL :: msec
4367INTEGER,INTENT(OUT),OPTIONAL :: ahour
4368INTEGER,INTENT(OUT),OPTIONAL :: aminute
4369INTEGER,INTENT(OUT),OPTIONAL :: asec
4370INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
4371CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
4372CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
4373CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
4374
4375CHARACTER(len=23) :: datebuf
4376
4377IF (PRESENT(amsec)) THEN
4378 amsec = this%iminuti
4379ENDIF
4380IF (PRESENT(asec)) THEN
4381 asec = int(this%iminuti/1000_int_ll)
4382ENDIF
4383IF (PRESENT(aminute)) THEN
4384 aminute = int(this%iminuti/60000_int_ll)
4385ENDIF
4386IF (PRESENT(ahour)) THEN
4387 ahour = int(this%iminuti/3600000_int_ll)
4388ENDIF
4389IF (PRESENT(msec)) THEN
4390 msec = int(mod(this%iminuti, 1000_int_ll))
4391ENDIF
4392IF (PRESENT(sec)) THEN
4393 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
4394ENDIF
4395IF (PRESENT(minute)) THEN
4396 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
4397ENDIF
4398IF (PRESENT(hour)) THEN
4399 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
4400ENDIF
4401IF (PRESENT(day)) THEN
4402 day = int(this%iminuti/86400000_int_ll)
4403ENDIF
4404IF (PRESENT(amonth)) THEN
4405 amonth = this%month
4406ENDIF
4407IF (PRESENT(month)) THEN
4408 month = mod(this%month-1,12)+1
4409ENDIF
4410IF (PRESENT(year)) THEN
4411 year = this%month/12
4412ENDIF
4413IF (PRESENT(isodate)) THEN ! Non standard, inventato!
4414 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
4415 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), ':', &
4416 mod(this%iminuti/60000_int_ll, 60_int_ll), ':', mod(this%iminuti/1000_int_ll, 60_int_ll), &
4417 '.', mod(this%iminuti, 1000_int_ll)
4418 isodate = datebuf(1:min(len(isodate),23))
4419
4420ENDIF
4421IF (PRESENT(simpledate)) THEN
4422 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
4423 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
4424 mod(this%iminuti/60000_int_ll, 60_int_ll), mod(this%iminuti/1000_int_ll, 60_int_ll), &
4425 mod(this%iminuti, 1000_int_ll)
4426 simpledate = datebuf(1:min(len(simpledate),17))
4427ENDIF
4428IF (PRESENT(oraclesimdate)) THEN
4429!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
4430!!$ 'obsoleto, usare piuttosto simpledate')
4431 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
4432 mod(this%iminuti/3600000_int_ll, 24_int_ll), mod(this%iminuti/60000_int_ll, 60_int_ll)
4433ENDIF
4434
4435END SUBROUTINE timedelta_getval
4436
4437
4440elemental FUNCTION timedelta_to_char(this) RESULT(char)
4441TYPE(timedelta),INTENT(IN) :: this
4442
4443CHARACTER(len=23) :: char
4444
4445CALL getval(this, isodate=char)
4446
4447END FUNCTION timedelta_to_char
4448
4449
4450FUNCTION trim_timedelta_to_char(in) RESULT(char)
4451TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
4452
4453CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
4454
4455char=timedelta_to_char(in)
4456
4457END FUNCTION trim_timedelta_to_char
4458
4459
4461elemental FUNCTION timedelta_getamsec(this)
4462TYPE(timedelta),INTENT(IN) :: this
4463INTEGER(kind=int_ll) :: timedelta_getamsec
4464
4465timedelta_getamsec = this%iminuti
4466
4467END FUNCTION timedelta_getamsec
4468
4469
4475FUNCTION timedelta_depop(this)
4476TYPE(timedelta),INTENT(IN) :: this
4477TYPE(timedelta) :: timedelta_depop
4478
4479TYPE(datetime) :: tmpdt
4480
4481IF (this%month == 0) THEN
4482 timedelta_depop = this
4483ELSE
4484 tmpdt = datetime_new(1970, 1, 1)
4485 timedelta_depop = (tmpdt + this) - tmpdt
4486ENDIF
4487
4488END FUNCTION timedelta_depop
4489
4490
4491elemental FUNCTION timedelta_eq(this, that) RESULT(res)
4492TYPE(timedelta),INTENT(IN) :: this, that
4493LOGICAL :: res
4494
4495res = (this%iminuti == that%iminuti .AND. this%month == that%month)
4496
4497END FUNCTION timedelta_eq
4498
4499
4500ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
4501TYPE(timedelta),INTENT(IN) :: this, that
4502LOGICAL :: res
4503
4504res = .NOT.(this == that)
4505
4506END FUNCTION timedelta_ne
4507
4508
4509ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
4510TYPE(timedelta),INTENT(IN) :: this, that
4511LOGICAL :: res
4512
4513res = this%iminuti > that%iminuti
4514
4515END FUNCTION timedelta_gt
4516
4517
4518ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
4519TYPE(timedelta),INTENT(IN) :: this, that
4520LOGICAL :: res
4521
4522res = this%iminuti < that%iminuti
4523
4524END FUNCTION timedelta_lt
4525
4526
4527ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
4528TYPE(timedelta),INTENT(IN) :: this, that
4529LOGICAL :: res
4530
4531IF (this == that) THEN
4532 res = .true.
4533ELSE IF (this > that) THEN
4534 res = .true.
4535ELSE
4536 res = .false.
4537ENDIF
4538
4539END FUNCTION timedelta_ge
4540
4541
4542elemental FUNCTION timedelta_le(this, that) RESULT(res)
4543TYPE(timedelta),INTENT(IN) :: this, that
4544LOGICAL :: res
4545
4546IF (this == that) THEN
4547 res = .true.
4548ELSE IF (this < that) THEN
4549 res = .true.
4550ELSE
4551 res = .false.
4552ENDIF
4553
4554END FUNCTION timedelta_le
4555
4556
4557ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
4558TYPE(timedelta),INTENT(IN) :: this, that
4559TYPE(timedelta) :: res
4560
4561res%iminuti = this%iminuti + that%iminuti
4562res%month = this%month + that%month
4563
4564END FUNCTION timedelta_add
4565
4566
4567ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
4568TYPE(timedelta),INTENT(IN) :: this, that
4569TYPE(timedelta) :: res
4570
4571res%iminuti = this%iminuti - that%iminuti
4572res%month = this%month - that%month
4573
4574END FUNCTION timedelta_sub
4575
4576
4577ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
4578TYPE(timedelta),INTENT(IN) :: this
4579INTEGER,INTENT(IN) :: n
4580TYPE(timedelta) :: res
4581
4582res%iminuti = this%iminuti*n
4583res%month = this%month*n
4584
4585END FUNCTION timedelta_mult
4586
4587
4588ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
4589INTEGER,INTENT(IN) :: n
4590TYPE(timedelta),INTENT(IN) :: this
4591TYPE(timedelta) :: res
4592
4593res%iminuti = this%iminuti*n
4594res%month = this%month*n
4595
4596END FUNCTION timedelta_tlum
4597
4598
4599ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
4600TYPE(timedelta),INTENT(IN) :: this
4601INTEGER,INTENT(IN) :: n
4602TYPE(timedelta) :: res
4603
4604res%iminuti = this%iminuti/n
4605res%month = this%month/n
4606
4607END FUNCTION timedelta_divint
4608
4609
4610ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
4611TYPE(timedelta),INTENT(IN) :: this, that
4612INTEGER :: res
4613
4614res = int(this%iminuti/that%iminuti)
4615
4616END FUNCTION timedelta_divtd
4617
4618
4619elemental FUNCTION timedelta_mod(this, that) RESULT(res)
4620TYPE(timedelta),INTENT(IN) :: this, that
4621TYPE(timedelta) :: res
4622
4623res%iminuti = mod(this%iminuti, that%iminuti)
4624res%month = 0
4625
4626END FUNCTION timedelta_mod
4627
4628
4629ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
4630TYPE(datetime),INTENT(IN) :: this
4631TYPE(timedelta),INTENT(IN) :: that
4632TYPE(timedelta) :: res
4633
4634IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
4635 res = timedelta_0
4636ELSE
4637 res%iminuti = mod(this%iminuti, that%iminuti)
4638 res%month = 0
4639ENDIF
4640
4641END FUNCTION datetime_timedelta_mod
4642
4643
4644ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
4645TYPE(timedelta),INTENT(IN) :: this
4646TYPE(timedelta) :: res
4647
4648res%iminuti = abs(this%iminuti)
4649res%month = abs(this%month)
4650
4651END FUNCTION timedelta_abs
4652
4653
4658SUBROUTINE timedelta_read_unit(this, unit)
4659TYPE(timedelta),INTENT(out) :: this
4660INTEGER, INTENT(in) :: unit
4661
4662CALL timedelta_vect_read_unit((/this/), unit)
4663
4664END SUBROUTINE timedelta_read_unit
4665
4666
4671SUBROUTINE timedelta_vect_read_unit(this, unit)
4672TYPE(timedelta) :: this(:)
4673INTEGER, INTENT(in) :: unit
4674
4675CHARACTER(len=40) :: form
4676CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4677INTEGER :: i
4678
4679ALLOCATE(dateiso(SIZE(this)))
4680INQUIRE(unit, form=form)
4681IF (form == 'FORMATTED') THEN
4682 READ(unit,'(3(A23,1X))')dateiso
4683ELSE
4684 READ(unit)dateiso
4685ENDIF
4686DO i = 1, SIZE(dateiso)
4687 CALL init(this(i), isodate=dateiso(i))
4688ENDDO
4689DEALLOCATE(dateiso)
4690
4691END SUBROUTINE timedelta_vect_read_unit
4692
4693
4698SUBROUTINE timedelta_write_unit(this, unit)
4699TYPE(timedelta),INTENT(in) :: this
4700INTEGER, INTENT(in) :: unit
4701
4702CALL timedelta_vect_write_unit((/this/), unit)
4703
4704END SUBROUTINE timedelta_write_unit
4705
4706
4711SUBROUTINE timedelta_vect_write_unit(this, unit)
4712TYPE(timedelta),INTENT(in) :: this(:)
4713INTEGER, INTENT(in) :: unit
4714
4715CHARACTER(len=40) :: form
4716CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4717INTEGER :: i
4718
4719ALLOCATE(dateiso(SIZE(this)))
4720DO i = 1, SIZE(dateiso)
4721 CALL getval(this(i), isodate=dateiso(i))
4722ENDDO
4723INQUIRE(unit, form=form)
4724IF (form == 'FORMATTED') THEN
4725 WRITE(unit,'(3(A23,1X))')dateiso
4726ELSE
4727 WRITE(unit)dateiso
4728ENDIF
4729DEALLOCATE(dateiso)
4730
4731END SUBROUTINE timedelta_vect_write_unit
4732
4733
4734ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4735TYPE(timedelta),INTENT(in) :: this
4736LOGICAL :: res
4737
4738res = .not. this == timedelta_miss
4739
4740end FUNCTION c_e_timedelta
4741
4742
4743elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4744
4745!!omstart JELADATA5
4746! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4747! 1 IMINUTI)
4748!
4749! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4750!
4751! variabili integer*4
4752! IN:
4753! IDAY,IMONTH,IYEAR, I*4
4754! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4755!
4756! OUT:
4757! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4758!!OMEND
4759
4760INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4761INTEGER,intent(out) :: iminuti
4762
4763iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4764
4765END SUBROUTINE jeladata5
4766
4767
4768elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4769INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4770INTEGER(KIND=int_ll),intent(out) :: imillisec
4771
4772imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4773 + imsec
4774
4775END SUBROUTINE jeladata5_1
4776
4777
4778
4779elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4780
4781!!omstart JELADATA6
4782! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4783! 1 IMINUTI)
4784!
4785! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4786! 1/1/1
4787!
4788! variabili integer*4
4789! IN:
4790! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4791!
4792! OUT:
4793! IDAY,IMONTH,IYEAR, I*4
4794! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4795!!OMEND
4796
4797
4798INTEGER,intent(in) :: iminuti
4799INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4800
4801INTEGER ::igiorno
4802
4803imin = mod(iminuti,60)
4804ihour = mod(iminuti,1440)/60
4805igiorno = iminuti/1440
4806IF (mod(iminuti,1440) < 0) igiorno = igiorno-1
4807CALL ndyin(igiorno,iday,imonth,iyear)
4808
4809END SUBROUTINE jeladata6
4810
4811
4812elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4813INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4814INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4815
4816INTEGER :: igiorno
4817
4818imsec = int(mod(imillisec, 60000_int_ll)) ! partial msec
4819!imin = MOD(imillisec/60000_int_ll, 60)
4820!ihour = MOD(imillisec/3600000_int_ll, 24)
4821imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4822ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4823igiorno = int(imillisec/86400000_int_ll)
4824!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4825CALL ndyin(igiorno,iday,imonth,iyear)
4826
4827END SUBROUTINE jeladata6_1
4828
4829
4830elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4831
4832!!OMSTART NDYIN
4833! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4834! restituisce la data fornendo in input il numero di
4835! giorni dal 1/1/1
4836!
4837!!omend
4838
4839INTEGER,intent(in) :: ndays
4840INTEGER,intent(out) :: igg, imm, iaa
4841integer :: n,lndays
4842
4843lndays=ndays
4844
4845n = lndays/d400
4846lndays = lndays - n*d400
4847iaa = year0 + n*400
4848n = min(lndays/d100, 3)
4849lndays = lndays - n*d100
4850iaa = iaa + n*100
4851n = lndays/d4
4852lndays = lndays - n*d4
4853iaa = iaa + n*4
4854n = min(lndays/d1, 3)
4855lndays = lndays - n*d1
4856iaa = iaa + n
4857n = bisextilis(iaa)
4858DO imm = 1, 12
4859 IF (lndays < ianno(imm+1,n)) EXIT
4860ENDDO
4861igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4862
4863END SUBROUTINE ndyin
4864
4865
4866integer elemental FUNCTION ndays(igg,imm,iaa)
4867
4868!!OMSTART NDAYS
4869! FUNCTION NDAYS(IGG,IMM,IAA)
4870! restituisce il numero di giorni dal 1/1/1
4871! fornendo in input la data
4872!
4873!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4874! nota bene E' SICURO !!!
4875! un anno e' bisestile se divisibile per 4
4876! un anno rimane bisestile se divisibile per 400
4877! un anno NON e' bisestile se divisibile per 100
4878!
4879!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4880!
4881!!omend
4882
4883INTEGER, intent(in) :: igg, imm, iaa
4884
4885INTEGER :: lmonth, lyear
4886
4887! Limito il mese a [1-12] e correggo l'anno coerentemente
4888lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4889lyear = iaa + (imm - lmonth)/12
4890ndays = igg+ianno(lmonth, bisextilis(lyear))
4891ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4892 (lyear-year0)/400
4893
4894END FUNCTION ndays
4895
4896
4897elemental FUNCTION bisextilis(annum)
4898INTEGER,INTENT(in) :: annum
4899INTEGER :: bisextilis
4900
4901IF (mod(annum,4) == 0 .AND. (mod(annum,400) == 0 .EQV. mod(annum,100) == 0)) THEN
4902 bisextilis = 2
4903ELSE
4904 bisextilis = 1
4905ENDIF
4906END FUNCTION bisextilis
4907
4908
4909ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4910TYPE(cyclicdatetime),INTENT(IN) :: this, that
4911LOGICAL :: res
4912
4913res = .true.
4914if (this%minute /= that%minute) res=.false.
4915if (this%hour /= that%hour) res=.false.
4916if (this%day /= that%day) res=.false.
4917if (this%month /= that%month) res=.false.
4918if (this%tendaysp /= that%tendaysp) res=.false.
4919
4920END FUNCTION cyclicdatetime_eq
4921
4922
4923ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4924TYPE(cyclicdatetime),INTENT(IN) :: this
4925TYPE(datetime),INTENT(IN) :: that
4926LOGICAL :: res
4927
4928integer :: minute,hour,day,month
4929
4930call getval(that,minute=minute,hour=hour,day=day,month=month)
4931
4932res = .true.
4933if (c_e(this%minute) .and. this%minute /= minute) res=.false.
4934if (c_e(this%hour) .and. this%hour /= hour) res=.false.
4935if (c_e(this%day) .and. this%day /= day) res=.false.
4936if (c_e(this%month) .and. this%month /= month) res=.false.
4937if (c_e(this%tendaysp)) then
4938 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4939end if
4940
4941END FUNCTION cyclicdatetime_datetime_eq
4942
4943
4944ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4945TYPE(datetime),INTENT(IN) :: this
4946TYPE(cyclicdatetime),INTENT(IN) :: that
4947LOGICAL :: res
4948
4949integer :: minute,hour,day,month
4950
4951call getval(this,minute=minute,hour=hour,day=day,month=month)
4952
4953res = .true.
4954if (c_e(that%minute) .and. that%minute /= minute) res=.false.
4955if (c_e(that%hour) .and. that%hour /= hour) res=.false.
4956if (c_e(that%day) .and. that%day /= day) res=.false.
4957if (c_e(that%month) .and. that%month /= month) res=.false.
4958
4959if (c_e(that%tendaysp)) then
4960 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4961end if
4962
4963
4964END FUNCTION datetime_cyclicdatetime_eq
4965
4966ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4967TYPE(cyclicdatetime),INTENT(in) :: this
4968LOGICAL :: res
4969
4970res = .not. this == cyclicdatetime_miss
4971
4972end FUNCTION c_e_cyclicdatetime
4973
4974
4977FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4978INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4979INTEGER,INTENT(IN),OPTIONAL :: month
4980INTEGER,INTENT(IN),OPTIONAL :: day
4981INTEGER,INTENT(IN),OPTIONAL :: hour
4982INTEGER,INTENT(IN),OPTIONAL :: minute
4983CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4984
4985integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4986
4987
4988TYPE(cyclicdatetime) :: this
4989
4990if (present(chardate)) then
4991
4992 ltendaysp=imiss
4993 lmonth=imiss
4994 lday=imiss
4995 lhour=imiss
4996 lminute=imiss
4997
4998 if (c_e(chardate))then
4999 ! TMMGGhhmm
5000 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
5001 !print*,chardate(1:1),ios,ltendaysp
5002 if (ios /= 0)ltendaysp=imiss
5003
5004 read(chardate(2:3),'(i2)',iostat=ios)lmonth
5005 !print*,chardate(2:3),ios,lmonth
5006 if (ios /= 0)lmonth=imiss
5007
5008 read(chardate(4:5),'(i2)',iostat=ios)lday
5009 !print*,chardate(4:5),ios,lday
5010 if (ios /= 0)lday=imiss
5011
5012 read(chardate(6:7),'(i2)',iostat=ios)lhour
5013 !print*,chardate(6:7),ios,lhour
5014 if (ios /= 0)lhour=imiss
5015
5016 read(chardate(8:9),'(i2)',iostat=ios)lminute
5017 !print*,chardate(8:9),ios,lminute
5018 if (ios /= 0)lminute=imiss
5019 end if
5020
5021 this%tendaysp=ltendaysp
5022 this%month=lmonth
5023 this%day=lday
5024 this%hour=lhour
5025 this%minute=lminute
5026else
5027 this%tendaysp=optio_l(tendaysp)
5028 this%month=optio_l(month)
5029 this%day=optio_l(day)
5030 this%hour=optio_l(hour)
5031 this%minute=optio_l(minute)
5032end if
5033
5034END FUNCTION cyclicdatetime_new
5035
5038elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
5039TYPE(cyclicdatetime),INTENT(IN) :: this
5040
5041CHARACTER(len=80) :: char
5042
5043char=to_char(this%tendaysp)//";"//to_char(this%month)//";"//to_char(this%day)//";"//&
5044to_char(this%hour)//";"//to_char(this%minute)
5045
5046END FUNCTION cyclicdatetime_to_char
5047
5048
5061FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
5062TYPE(cyclicdatetime),INTENT(IN) :: this
5063
5064TYPE(datetime) :: dtc
5065
5066integer :: year,month,day,hour
5067
5068dtc = datetime_miss
5069
5070! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
5071if ( .not. c_e(this)) then
5072 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
5073 return
5074end if
5075
5076! minute present -> not good for conventional datetime
5077if (c_e(this%minute)) return
5078! day, month and tendaysp present -> no good
5079if (c_e(this%day) .and. c_e(this%month) .and. c_e(this%tendaysp)) return
5080
5081if (c_e(this%day) .and. c_e(this%month)) then
5082 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
5083else if (c_e(this%tendaysp) .and. c_e(this%month)) then
5084 day=(this%tendaysp-1)*10+1
5085 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
5086else if (c_e(this%month)) then
5087 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
5088else if (c_e(this%day)) then
5089 ! only day present -> no good
5090 return
5091end if
5092
5093if (c_e(this%hour)) then
5094 call getval(dtc,year=year,month=month,day=day,hour=hour)
5095 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
5096end if
5097
5098
5099END FUNCTION cyclicdatetime_to_conventional
5100
5101
5102
5103FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
5104TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
5105
5106CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
5107
5108char=cyclicdatetime_to_char(in)
5109
5110END FUNCTION trim_cyclicdatetime_to_char
5111
5112
5113
5114SUBROUTINE display_cyclicdatetime(this)
5115TYPE(cyclicdatetime),INTENT(in) :: this
5116
5117print*,"CYCLICDATETIME: ",to_char(this)
5118
5119end subroutine display_cyclicdatetime
5120
5121
5122#include "array_utilities_inc.F90"
5123
5124END MODULE datetime_class
5125
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:245
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.