libsim Versione 7.1.11

◆ 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 3293 del file datetime_class.F90.

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

Generated with Doxygen.