libsim Versione 7.1.11
|
◆ sort_datetime()
Sorts inline into ascending order - Quicksort Quicksort chooses a "pivot" in the set, and explores the array from both ends, looking for a value > pivot with the increasing index, for a value <= pivot with the decreasing index, and swapping them when it has found one of each. The array is then subdivided in 2 ([3]) subsets: { values <= pivot} {pivot} {values > pivot} One then call recursively the program to sort each subset. When the size of the subarray is small enough or the maximum level of recursion is gained, one uses an insertion sort that is faster for very small sets.
Definizione alla linea 3168 del file datetime_class.F90. 3169! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
3170! authors:
3171! Davide Cesari <dcesari@arpa.emr.it>
3172! Paolo Patruno <ppatruno@arpa.emr.it>
3173
3174! This program is free software; you can redistribute it and/or
3175! modify it under the terms of the GNU General Public License as
3176! published by the Free Software Foundation; either version 2 of
3177! the License, or (at your option) any later version.
3178
3179! This program is distributed in the hope that it will be useful,
3180! but WITHOUT ANY WARRANTY; without even the implied warranty of
3181! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3182! GNU General Public License for more details.
3183
3184! You should have received a copy of the GNU General Public License
3185! along with this program. If not, see <http://www.gnu.org/licenses/>.
3186#include "config.h"
3187
3208IMPLICIT NONE
3209
3210INTEGER, PARAMETER :: dateint=selected_int_kind(13)
3211
3214 PRIVATE
3215 INTEGER(KIND=int_ll) :: iminuti
3217
3226 PRIVATE
3227 INTEGER(KIND=int_ll) :: iminuti
3228 INTEGER :: month
3230
3231
3236 PRIVATE
3237 INTEGER :: minute
3238 INTEGER :: hour
3239 INTEGER :: day
3240 INTEGER :: tendaysp
3241 INTEGER :: month
3243
3244
3252INTEGER, PARAMETER :: datetime_utc=1
3254INTEGER, PARAMETER :: datetime_local=2
3264TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
3265
3266
3267INTEGER(kind=dateint), PARAMETER :: &
3268 sec_in_day=86400, &
3269 sec_in_hour=3600, &
3270 sec_in_min=60, &
3271 min_in_day=1440, &
3272 min_in_hour=60, &
3273 hour_in_day=24
3274
3275INTEGER,PARAMETER :: &
3276 year0=1, & ! anno di origine per iminuti
3277 d1=365, & ! giorni/1 anno nel calendario gregoriano
3278 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
3279 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
3280 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
3281 ianno(13,2)=reshape((/ &
3282 0,31,59,90,120,151,181,212,243,273,304,334,365, &
3283 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
3284
3285INTEGER(KIND=int_ll),PARAMETER :: &
3286 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
3287
3292 MODULE PROCEDURE datetime_init, timedelta_init
3293END INTERFACE
3294
3298 MODULE PROCEDURE datetime_delete, timedelta_delete
3299END INTERFACE
3300
3303 MODULE PROCEDURE datetime_getval, timedelta_getval
3304END INTERFACE
3305
3308 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
3309END INTERFACE
3310
3311
3330 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
3331END INTERFACE
3332
3338INTERFACE OPERATOR (==)
3339 MODULE PROCEDURE datetime_eq, timedelta_eq, &
3340 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
3341END INTERFACE
3342
3348INTERFACE OPERATOR (/=)
3349 MODULE PROCEDURE datetime_ne, timedelta_ne
3350END INTERFACE
3351
3359INTERFACE OPERATOR (>)
3360 MODULE PROCEDURE datetime_gt, timedelta_gt
3361END INTERFACE
3362
3370INTERFACE OPERATOR (<)
3371 MODULE PROCEDURE datetime_lt, timedelta_lt
3372END INTERFACE
3373
3381INTERFACE OPERATOR (>=)
3382 MODULE PROCEDURE datetime_ge, timedelta_ge
3383END INTERFACE
3384
3392INTERFACE OPERATOR (<=)
3393 MODULE PROCEDURE datetime_le, timedelta_le
3394END INTERFACE
3395
3402INTERFACE OPERATOR (+)
3403 MODULE PROCEDURE datetime_add, timedelta_add
3404END INTERFACE
3405
3413INTERFACE OPERATOR (-)
3414 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
3415END INTERFACE
3416
3422INTERFACE OPERATOR (*)
3423 MODULE PROCEDURE timedelta_mult, timedelta_tlum
3424END INTERFACE
3425
3432INTERFACE OPERATOR (/)
3433 MODULE PROCEDURE timedelta_divint, timedelta_divtd
3434END INTERFACE
3435
3447 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3448END INTERFACE
3449
3453 MODULE PROCEDURE timedelta_abs
3454END INTERFACE
3455
3459 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3460 timedelta_read_unit, timedelta_vect_read_unit
3461END INTERFACE
3462
3466 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3467 timedelta_write_unit, timedelta_vect_write_unit
3468END INTERFACE
3469
3472 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3473END INTERFACE
3474
3477 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
3478END INTERFACE
3479
3480#undef VOL7D_POLY_TYPE
3481#undef VOL7D_POLY_TYPES
3482#undef ENABLE_SORT
3483#define VOL7D_POLY_TYPE TYPE(datetime)
3484#define VOL7D_POLY_TYPES _datetime
3485#define ENABLE_SORT
3486#include "array_utilities_pre.F90"
3487
3488
3489#define ARRAYOF_ORIGTYPE TYPE(datetime)
3490#define ARRAYOF_TYPE arrayof_datetime
3491#define ARRAYOF_ORIGEQ 1
3492#include "arrayof_pre.F90"
3493! from arrayof
3494
3495PRIVATE
3496
3498 datetime_min, datetime_max, &
3501 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3502 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3504 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3505 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3507 count_distinct, pack_distinct, &
3508 count_distinct_sorted, pack_distinct_sorted, &
3509 count_and_pack_distinct, &
3511 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
3513PUBLIC insert_unique, append_unique
3514PUBLIC cyclicdatetime_to_conventional
3515
3516CONTAINS
3517
3518
3519! ==============
3520! == datetime ==
3521! ==============
3522
3529ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3530 unixtime, isodate, simpledate) RESULT(this)
3531INTEGER,INTENT(IN),OPTIONAL :: year
3532INTEGER,INTENT(IN),OPTIONAL :: month
3533INTEGER,INTENT(IN),OPTIONAL :: day
3534INTEGER,INTENT(IN),OPTIONAL :: hour
3535INTEGER,INTENT(IN),OPTIONAL :: minute
3536INTEGER,INTENT(IN),OPTIONAL :: msec
3537INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3538CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3539CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3540
3541TYPE(datetime) :: this
3542INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3543CHARACTER(len=23) :: datebuf
3544
3545IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3546 lyear = year
3547 IF (PRESENT(month)) THEN
3548 lmonth = month
3549 ELSE
3550 lmonth = 1
3551 ENDIF
3552 IF (PRESENT(day)) THEN
3553 lday = day
3554 ELSE
3555 lday = 1
3556 ENDIF
3557 IF (PRESENT(hour)) THEN
3558 lhour = hour
3559 ELSE
3560 lhour = 0
3561 ENDIF
3562 IF (PRESENT(minute)) THEN
3563 lminute = minute
3564 ELSE
3565 lminute = 0
3566 ENDIF
3567 IF (PRESENT(msec)) THEN
3568 lmsec = msec
3569 ELSE
3570 lmsec = 0
3571 ENDIF
3572
3575 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3576 else
3577 this=datetime_miss
3578 end if
3579
3580ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3582 this%iminuti = (unixtime + unsec)*1000
3583 else
3584 this=datetime_miss
3585 end if
3586
3587ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3588
3590 datebuf(1:23) = '0001-01-01 00:00:00.000'
3591 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3592 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3593 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3594 lmsec = lmsec + lsec*1000
3595 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3596 RETURN
3597
3598100 CONTINUE ! condizione di errore in isodate
3600 RETURN
3601 ELSE
3602 this = datetime_miss
3603 ENDIF
3604
3605ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3607 datebuf(1:17) = '00010101000000000'
3608 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3609 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3610 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3611 lmsec = lmsec + lsec*1000
3612 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3613 RETURN
3614
3615120 CONTINUE ! condizione di errore in simpledate
3617 RETURN
3618 ELSE
3619 this = datetime_miss
3620 ENDIF
3621
3622ELSE
3623 this = datetime_miss
3624ENDIF
3625
3626END FUNCTION datetime_new
3627
3628
3630FUNCTION datetime_new_now(now) RESULT(this)
3631INTEGER,INTENT(IN) :: now
3632TYPE(datetime) :: this
3633
3634INTEGER :: dt(8)
3635
3637 CALL date_and_time(values=dt)
3638 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3640 msec=dt(7)*1000+dt(8))
3641ELSE
3642 this = datetime_miss
3643ENDIF
3644
3645END FUNCTION datetime_new_now
3646
3647
3654SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3655 unixtime, isodate, simpledate, now)
3656TYPE(datetime),INTENT(INOUT) :: this
3657INTEGER,INTENT(IN),OPTIONAL :: year
3658INTEGER,INTENT(IN),OPTIONAL :: month
3659INTEGER,INTENT(IN),OPTIONAL :: day
3660INTEGER,INTENT(IN),OPTIONAL :: hour
3661INTEGER,INTENT(IN),OPTIONAL :: minute
3662INTEGER,INTENT(IN),OPTIONAL :: msec
3663INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3664CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3665CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3666INTEGER,INTENT(IN),OPTIONAL :: now
3667
3668IF (PRESENT(now)) THEN
3669 this = datetime_new_now(now)
3670ELSE
3671 this = datetime_new(year, month, day, hour, minute, msec, &
3672 unixtime, isodate, simpledate)
3673ENDIF
3674
3675END SUBROUTINE datetime_init
3676
3677
3678ELEMENTAL SUBROUTINE datetime_delete(this)
3679TYPE(datetime),INTENT(INOUT) :: this
3680
3681this%iminuti = illmiss
3682
3683END SUBROUTINE datetime_delete
3684
3685
3690PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3691 unixtime, isodate, simpledate, oraclesimdate)
3692TYPE(datetime),INTENT(IN) :: this
3693INTEGER,INTENT(OUT),OPTIONAL :: year
3694INTEGER,INTENT(OUT),OPTIONAL :: month
3695INTEGER,INTENT(OUT),OPTIONAL :: day
3696INTEGER,INTENT(OUT),OPTIONAL :: hour
3697INTEGER,INTENT(OUT),OPTIONAL :: minute
3698INTEGER,INTENT(OUT),OPTIONAL :: msec
3699INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3700CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3701CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3702CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3703
3704INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3705CHARACTER(len=23) :: datebuf
3706
3707IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3708 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3709 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3710
3711 IF (this == datetime_miss) THEN
3712
3713 IF (PRESENT(msec)) THEN
3714 msec = imiss
3715 ENDIF
3716 IF (PRESENT(minute)) THEN
3717 minute = imiss
3718 ENDIF
3719 IF (PRESENT(hour)) THEN
3720 hour = imiss
3721 ENDIF
3722 IF (PRESENT(day)) THEN
3723 day = imiss
3724 ENDIF
3725 IF (PRESENT(month)) THEN
3726 month = imiss
3727 ENDIF
3728 IF (PRESENT(year)) THEN
3729 year = imiss
3730 ENDIF
3731 IF (PRESENT(isodate)) THEN
3732 isodate = cmiss
3733 ENDIF
3734 IF (PRESENT(simpledate)) THEN
3735 simpledate = cmiss
3736 ENDIF
3737 IF (PRESENT(oraclesimdate)) THEN
3738!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3739!!$ 'obsoleto, usare piuttosto simpledate')
3740 oraclesimdate=cmiss
3741 ENDIF
3742 IF (PRESENT(unixtime)) THEN
3743 unixtime = illmiss
3744 ENDIF
3745
3746 ELSE
3747
3748 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3749 IF (PRESENT(msec)) THEN
3750 msec = lmsec
3751 ENDIF
3752 IF (PRESENT(minute)) THEN
3753 minute = lminute
3754 ENDIF
3755 IF (PRESENT(hour)) THEN
3756 hour = lhour
3757 ENDIF
3758 IF (PRESENT(day)) THEN
3759 day = lday
3760 ENDIF
3761 IF (PRESENT(month)) THEN
3762 month = lmonth
3763 ENDIF
3764 IF (PRESENT(year)) THEN
3765 year = lyear
3766 ENDIF
3767 IF (PRESENT(isodate)) THEN
3768 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3769 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3771 isodate = datebuf(1:min(len(isodate),23))
3772 ENDIF
3773 IF (PRESENT(simpledate)) THEN
3774 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3775 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3776 simpledate = datebuf(1:min(len(simpledate),17))
3777 ENDIF
3778 IF (PRESENT(oraclesimdate)) THEN
3779!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3780!!$ 'obsoleto, usare piuttosto simpledate')
3781 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3782 ENDIF
3783 IF (PRESENT(unixtime)) THEN
3784 unixtime = this%iminuti/1000_int_ll-unsec
3785 ENDIF
3786
3787 ENDIF
3788ENDIF
3789
3790END SUBROUTINE datetime_getval
3791
3792
3795elemental FUNCTION datetime_to_char(this) RESULT(char)
3796TYPE(datetime),INTENT(IN) :: this
3797
3798CHARACTER(len=23) :: char
3799
3801
3802END FUNCTION datetime_to_char
3803
3804
3805FUNCTION trim_datetime_to_char(in) RESULT(char)
3806TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3807
3808CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3809
3810char=datetime_to_char(in)
3811
3812END FUNCTION trim_datetime_to_char
3813
3814
3815
3816SUBROUTINE display_datetime(this)
3817TYPE(datetime),INTENT(in) :: this
3818
3820
3821end subroutine display_datetime
3822
3823
3824
3825SUBROUTINE display_timedelta(this)
3826TYPE(timedelta),INTENT(in) :: this
3827
3829
3830end subroutine display_timedelta
3831
3832
3833
3834ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3835TYPE(datetime),INTENT(in) :: this
3836LOGICAL :: res
3837
3838res = .not. this == datetime_miss
3839
3840end FUNCTION c_e_datetime
3841
3842
3843ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3844TYPE(datetime),INTENT(IN) :: this, that
3845LOGICAL :: res
3846
3847res = this%iminuti == that%iminuti
3848
3849END FUNCTION datetime_eq
3850
3851
3852ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3853TYPE(datetime),INTENT(IN) :: this, that
3854LOGICAL :: res
3855
3856res = .NOT.(this == that)
3857
3858END FUNCTION datetime_ne
3859
3860
3861ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3862TYPE(datetime),INTENT(IN) :: this, that
3863LOGICAL :: res
3864
3865res = this%iminuti > that%iminuti
3866
3867END FUNCTION datetime_gt
3868
3869
3870ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3871TYPE(datetime),INTENT(IN) :: this, that
3872LOGICAL :: res
3873
3874res = this%iminuti < that%iminuti
3875
3876END FUNCTION datetime_lt
3877
3878
3879ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3880TYPE(datetime),INTENT(IN) :: this, that
3881LOGICAL :: res
3882
3883IF (this == that) THEN
3884 res = .true.
3885ELSE IF (this > that) THEN
3886 res = .true.
3887ELSE
3888 res = .false.
3889ENDIF
3890
3891END FUNCTION datetime_ge
3892
3893
3894ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3895TYPE(datetime),INTENT(IN) :: this, that
3896LOGICAL :: res
3897
3898IF (this == that) THEN
3899 res = .true.
3900ELSE IF (this < that) THEN
3901 res = .true.
3902ELSE
3903 res = .false.
3904ENDIF
3905
3906END FUNCTION datetime_le
3907
3908
3909FUNCTION datetime_add(this, that) RESULT(res)
3910TYPE(datetime),INTENT(IN) :: this
3911TYPE(timedelta),INTENT(IN) :: that
3912TYPE(datetime) :: res
3913
3914INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3915
3916IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3917 res = datetime_miss
3918ELSE
3919 res%iminuti = this%iminuti + that%iminuti
3920 IF (that%month /= 0) THEN
3922 minute=lminute, msec=lmsec)
3924 hour=lhour, minute=lminute, msec=lmsec)
3925 ENDIF
3926ENDIF
3927
3928END FUNCTION datetime_add
3929
3930
3931ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3932TYPE(datetime),INTENT(IN) :: this, that
3933TYPE(timedelta) :: res
3934
3935IF (this == datetime_miss .OR. that == datetime_miss) THEN
3936 res = timedelta_miss
3937ELSE
3938 res%iminuti = this%iminuti - that%iminuti
3939 res%month = 0
3940ENDIF
3941
3942END FUNCTION datetime_subdt
3943
3944
3945FUNCTION datetime_subtd(this, that) RESULT(res)
3946TYPE(datetime),INTENT(IN) :: this
3947TYPE(timedelta),INTENT(IN) :: that
3948TYPE(datetime) :: res
3949
3950INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3951
3952IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3953 res = datetime_miss
3954ELSE
3955 res%iminuti = this%iminuti - that%iminuti
3956 IF (that%month /= 0) THEN
3958 minute=lminute, msec=lmsec)
3960 hour=lhour, minute=lminute, msec=lmsec)
3961 ENDIF
3962ENDIF
3963
3964END FUNCTION datetime_subtd
3965
3966
3971SUBROUTINE datetime_read_unit(this, unit)
3972TYPE(datetime),INTENT(out) :: this
3973INTEGER, INTENT(in) :: unit
3974CALL datetime_vect_read_unit((/this/), unit)
3975
3976END SUBROUTINE datetime_read_unit
3977
3978
3983SUBROUTINE datetime_vect_read_unit(this, unit)
3984TYPE(datetime) :: this(:)
3985INTEGER, INTENT(in) :: unit
3986
3987CHARACTER(len=40) :: form
3988CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3989INTEGER :: i
3990
3991ALLOCATE(dateiso(SIZE(this)))
3992INQUIRE(unit, form=form)
3993IF (form == 'FORMATTED') THEN
3994 READ(unit,'(A23,1X)')dateiso
3995ELSE
3996 READ(unit)dateiso
3997ENDIF
3998DO i = 1, SIZE(dateiso)
4000ENDDO
4001DEALLOCATE(dateiso)
4002
4003END SUBROUTINE datetime_vect_read_unit
4004
4005
4010SUBROUTINE datetime_write_unit(this, unit)
4011TYPE(datetime),INTENT(in) :: this
4012INTEGER, INTENT(in) :: unit
4013
4014CALL datetime_vect_write_unit((/this/), unit)
4015
4016END SUBROUTINE datetime_write_unit
4017
4018
4023SUBROUTINE datetime_vect_write_unit(this, unit)
4024TYPE(datetime),INTENT(in) :: this(:)
4025INTEGER, INTENT(in) :: unit
4026
4027CHARACTER(len=40) :: form
4028CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4029INTEGER :: i
4030
4031ALLOCATE(dateiso(SIZE(this)))
4032DO i = 1, SIZE(dateiso)
4034ENDDO
4035INQUIRE(unit, form=form)
4036IF (form == 'FORMATTED') THEN
4037 WRITE(unit,'(A23,1X)')dateiso
4038ELSE
4039 WRITE(unit)dateiso
4040ENDIF
4041DEALLOCATE(dateiso)
4042
4043END SUBROUTINE datetime_vect_write_unit
4044
4045
4046#include "arrayof_post.F90"
4047
4048
4049! ===============
4050! == timedelta ==
4051! ===============
4058FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
4059 isodate, simpledate, oraclesimdate) RESULT (this)
4060INTEGER,INTENT(IN),OPTIONAL :: year
4061INTEGER,INTENT(IN),OPTIONAL :: month
4062INTEGER,INTENT(IN),OPTIONAL :: day
4063INTEGER,INTENT(IN),OPTIONAL :: hour
4064INTEGER,INTENT(IN),OPTIONAL :: minute
4065INTEGER,INTENT(IN),OPTIONAL :: sec
4066INTEGER,INTENT(IN),OPTIONAL :: msec
4067CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
4068CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
4069CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
4070
4071TYPE(timedelta) :: this
4072
4073CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
4074 isodate, simpledate, oraclesimdate)
4075
4076END FUNCTION timedelta_new
4077
4078
4083SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
4084 isodate, simpledate, oraclesimdate)
4085TYPE(timedelta),INTENT(INOUT) :: this
4086INTEGER,INTENT(IN),OPTIONAL :: year
4087INTEGER,INTENT(IN),OPTIONAL :: month
4088INTEGER,INTENT(IN),OPTIONAL :: day
4089INTEGER,INTENT(IN),OPTIONAL :: hour
4090INTEGER,INTENT(IN),OPTIONAL :: minute
4091INTEGER,INTENT(IN),OPTIONAL :: sec
4092INTEGER,INTENT(IN),OPTIONAL :: msec
4093CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
4094CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
4095CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
4096
4097INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
4098CHARACTER(len=23) :: datebuf
4099
4100this%month = 0
4101
4102IF (PRESENT(isodate)) THEN
4103 datebuf(1:23) = '0000000000 00:00:00.000'
4104 l = len_trim(isodate)
4105! IF (l > 0) THEN
4107 IF (n > 0) THEN
4108 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
4109 datebuf(12-n:12-n+l-1) = isodate(:l)
4110 ELSE
4111 datebuf(1:l) = isodate(1:l)
4112 ENDIF
4113! ENDIF
4114
4115! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
4116 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
4117 h, m, s, ms
4118 this%month = lmonth + 12*lyear
4119 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4120 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4121 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4122 RETURN
4123
4124200 CONTINUE ! condizione di errore in isodate
4126 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
4127 CALL raise_error()
4128
4129ELSE IF (PRESENT(simpledate)) THEN
4130 datebuf(1:17) = '00000000000000000'
4131 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
4132 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
4133 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4134 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4135 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4136
4137220 CONTINUE ! condizione di errore in simpledate
4139 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
4140 CALL raise_error()
4141 RETURN
4142
4143ELSE IF (PRESENT(oraclesimdate)) THEN
4144 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
4145 'obsoleto, usare piuttosto simpledate')
4146 READ(oraclesimdate, '(I8,2I2)')d, h, m
4147 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4148 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
4149
4150ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
4151 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
4152 .and. .not. present(msec) .and. .not. present(isodate) &
4153 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
4154
4155 this=timedelta_miss
4156
4157ELSE
4158 this%iminuti = 0
4159 IF (PRESENT(year)) THEN
4161 this%month = this%month + year*12
4162 else
4163 this=timedelta_miss
4164 return
4165 end if
4166 ENDIF
4167 IF (PRESENT(month)) THEN
4169 this%month = this%month + month
4170 else
4171 this=timedelta_miss
4172 return
4173 end if
4174 ENDIF
4175 IF (PRESENT(day)) THEN
4177 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
4178 else
4179 this=timedelta_miss
4180 return
4181 end if
4182 ENDIF
4183 IF (PRESENT(hour)) THEN
4185 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
4186 else
4187 this=timedelta_miss
4188 return
4189 end if
4190 ENDIF
4191 IF (PRESENT(minute)) THEN
4193 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
4194 else
4195 this=timedelta_miss
4196 return
4197 end if
4198 ENDIF
4199 IF (PRESENT(sec)) THEN
4201 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
4202 else
4203 this=timedelta_miss
4204 return
4205 end if
4206 ENDIF
4207 IF (PRESENT(msec)) THEN
4209 this%iminuti = this%iminuti + msec
4210 else
4211 this=timedelta_miss
4212 return
4213 end if
4214 ENDIF
4215ENDIF
4216
4217
4218
4219
4220END SUBROUTINE timedelta_init
4221
4222
4223SUBROUTINE timedelta_delete(this)
4224TYPE(timedelta),INTENT(INOUT) :: this
4225
4226this%iminuti = imiss
4227this%month = 0
4228
4229END SUBROUTINE timedelta_delete
4230
4231
4236PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
4237 day, hour, minute, sec, msec, &
4238 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
4239TYPE(timedelta),INTENT(IN) :: this
4240INTEGER,INTENT(OUT),OPTIONAL :: year
4241INTEGER,INTENT(OUT),OPTIONAL :: month
4242INTEGER,INTENT(OUT),OPTIONAL :: amonth
4243INTEGER,INTENT(OUT),OPTIONAL :: day
4244INTEGER,INTENT(OUT),OPTIONAL :: hour
4245INTEGER,INTENT(OUT),OPTIONAL :: minute
4246INTEGER,INTENT(OUT),OPTIONAL :: sec
4247INTEGER,INTENT(OUT),OPTIONAL :: msec
4248INTEGER,INTENT(OUT),OPTIONAL :: ahour
4249INTEGER,INTENT(OUT),OPTIONAL :: aminute
4250INTEGER,INTENT(OUT),OPTIONAL :: asec
4251INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
4252CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
4253CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
4254CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
4255
4256CHARACTER(len=23) :: datebuf
4257
4258IF (PRESENT(amsec)) THEN
4259 amsec = this%iminuti
4260ENDIF
4261IF (PRESENT(asec)) THEN
4262 asec = int(this%iminuti/1000_int_ll)
4263ENDIF
4264IF (PRESENT(aminute)) THEN
4265 aminute = int(this%iminuti/60000_int_ll)
4266ENDIF
4267IF (PRESENT(ahour)) THEN
4268 ahour = int(this%iminuti/3600000_int_ll)
4269ENDIF
4270IF (PRESENT(msec)) THEN
4271 msec = int(mod(this%iminuti, 1000_int_ll))
4272ENDIF
4273IF (PRESENT(sec)) THEN
4274 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
4275ENDIF
4276IF (PRESENT(minute)) THEN
4277 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
4278ENDIF
4279IF (PRESENT(hour)) THEN
4280 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
4281ENDIF
4282IF (PRESENT(day)) THEN
4283 day = int(this%iminuti/86400000_int_ll)
4284ENDIF
4285IF (PRESENT(amonth)) THEN
4286 amonth = this%month
4287ENDIF
4288IF (PRESENT(month)) THEN
4289 month = mod(this%month-1,12)+1
4290ENDIF
4291IF (PRESENT(year)) THEN
4292 year = this%month/12
4293ENDIF
4294IF (PRESENT(isodate)) THEN ! Non standard, inventato!
4295 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
4299 isodate = datebuf(1:min(len(isodate),23))
4300
4301ENDIF
4302IF (PRESENT(simpledate)) THEN
4303 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
4304 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
4306 mod(this%iminuti, 1000_int_ll)
4307 simpledate = datebuf(1:min(len(simpledate),17))
4308ENDIF
4309IF (PRESENT(oraclesimdate)) THEN
4310!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
4311!!$ 'obsoleto, usare piuttosto simpledate')
4312 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
4314ENDIF
4315
4316END SUBROUTINE timedelta_getval
4317
4318
4321elemental FUNCTION timedelta_to_char(this) RESULT(char)
4322TYPE(timedelta),INTENT(IN) :: this
4323
4324CHARACTER(len=23) :: char
4325
4327
4328END FUNCTION timedelta_to_char
4329
4330
4331FUNCTION trim_timedelta_to_char(in) RESULT(char)
4332TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
4333
4334CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
4335
4336char=timedelta_to_char(in)
4337
4338END FUNCTION trim_timedelta_to_char
4339
4340
4342elemental FUNCTION timedelta_getamsec(this)
4343TYPE(timedelta),INTENT(IN) :: this
4344INTEGER(kind=int_ll) :: timedelta_getamsec
4345
4346timedelta_getamsec = this%iminuti
4347
4348END FUNCTION timedelta_getamsec
4349
4350
4356FUNCTION timedelta_depop(this)
4357TYPE(timedelta),INTENT(IN) :: this
4358TYPE(timedelta) :: timedelta_depop
4359
4360TYPE(datetime) :: tmpdt
4361
4362IF (this%month == 0) THEN
4363 timedelta_depop = this
4364ELSE
4365 tmpdt = datetime_new(1970, 1, 1)
4366 timedelta_depop = (tmpdt + this) - tmpdt
4367ENDIF
4368
4369END FUNCTION timedelta_depop
4370
4371
4372elemental FUNCTION timedelta_eq(this, that) RESULT(res)
4373TYPE(timedelta),INTENT(IN) :: this, that
4374LOGICAL :: res
4375
4376res = (this%iminuti == that%iminuti .AND. this%month == that%month)
4377
4378END FUNCTION timedelta_eq
4379
4380
4381ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
4382TYPE(timedelta),INTENT(IN) :: this, that
4383LOGICAL :: res
4384
4385res = .NOT.(this == that)
4386
4387END FUNCTION timedelta_ne
4388
4389
4390ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
4391TYPE(timedelta),INTENT(IN) :: this, that
4392LOGICAL :: res
4393
4394res = this%iminuti > that%iminuti
4395
4396END FUNCTION timedelta_gt
4397
4398
4399ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
4400TYPE(timedelta),INTENT(IN) :: this, that
4401LOGICAL :: res
4402
4403res = this%iminuti < that%iminuti
4404
4405END FUNCTION timedelta_lt
4406
4407
4408ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
4409TYPE(timedelta),INTENT(IN) :: this, that
4410LOGICAL :: res
4411
4412IF (this == that) THEN
4413 res = .true.
4414ELSE IF (this > that) THEN
4415 res = .true.
4416ELSE
4417 res = .false.
4418ENDIF
4419
4420END FUNCTION timedelta_ge
4421
4422
4423elemental FUNCTION timedelta_le(this, that) RESULT(res)
4424TYPE(timedelta),INTENT(IN) :: this, that
4425LOGICAL :: res
4426
4427IF (this == that) THEN
4428 res = .true.
4429ELSE IF (this < that) THEN
4430 res = .true.
4431ELSE
4432 res = .false.
4433ENDIF
4434
4435END FUNCTION timedelta_le
4436
4437
4438ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
4439TYPE(timedelta),INTENT(IN) :: this, that
4440TYPE(timedelta) :: res
4441
4442res%iminuti = this%iminuti + that%iminuti
4443res%month = this%month + that%month
4444
4445END FUNCTION timedelta_add
4446
4447
4448ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
4449TYPE(timedelta),INTENT(IN) :: this, that
4450TYPE(timedelta) :: res
4451
4452res%iminuti = this%iminuti - that%iminuti
4453res%month = this%month - that%month
4454
4455END FUNCTION timedelta_sub
4456
4457
4458ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
4459TYPE(timedelta),INTENT(IN) :: this
4460INTEGER,INTENT(IN) :: n
4461TYPE(timedelta) :: res
4462
4463res%iminuti = this%iminuti*n
4464res%month = this%month*n
4465
4466END FUNCTION timedelta_mult
4467
4468
4469ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
4470INTEGER,INTENT(IN) :: n
4471TYPE(timedelta),INTENT(IN) :: this
4472TYPE(timedelta) :: res
4473
4474res%iminuti = this%iminuti*n
4475res%month = this%month*n
4476
4477END FUNCTION timedelta_tlum
4478
4479
4480ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
4481TYPE(timedelta),INTENT(IN) :: this
4482INTEGER,INTENT(IN) :: n
4483TYPE(timedelta) :: res
4484
4485res%iminuti = this%iminuti/n
4486res%month = this%month/n
4487
4488END FUNCTION timedelta_divint
4489
4490
4491ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
4492TYPE(timedelta),INTENT(IN) :: this, that
4493INTEGER :: res
4494
4495res = int(this%iminuti/that%iminuti)
4496
4497END FUNCTION timedelta_divtd
4498
4499
4500elemental FUNCTION timedelta_mod(this, that) RESULT(res)
4501TYPE(timedelta),INTENT(IN) :: this, that
4502TYPE(timedelta) :: res
4503
4504res%iminuti = mod(this%iminuti, that%iminuti)
4505res%month = 0
4506
4507END FUNCTION timedelta_mod
4508
4509
4510ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
4511TYPE(datetime),INTENT(IN) :: this
4512TYPE(timedelta),INTENT(IN) :: that
4513TYPE(timedelta) :: res
4514
4515IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
4516 res = timedelta_0
4517ELSE
4518 res%iminuti = mod(this%iminuti, that%iminuti)
4519 res%month = 0
4520ENDIF
4521
4522END FUNCTION datetime_timedelta_mod
4523
4524
4525ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
4526TYPE(timedelta),INTENT(IN) :: this
4527TYPE(timedelta) :: res
4528
4529res%iminuti = abs(this%iminuti)
4530res%month = abs(this%month)
4531
4532END FUNCTION timedelta_abs
4533
4534
4539SUBROUTINE timedelta_read_unit(this, unit)
4540TYPE(timedelta),INTENT(out) :: this
4541INTEGER, INTENT(in) :: unit
4542
4543CALL timedelta_vect_read_unit((/this/), unit)
4544
4545END SUBROUTINE timedelta_read_unit
4546
4547
4552SUBROUTINE timedelta_vect_read_unit(this, unit)
4553TYPE(timedelta) :: this(:)
4554INTEGER, INTENT(in) :: unit
4555
4556CHARACTER(len=40) :: form
4557CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4558INTEGER :: i
4559
4560ALLOCATE(dateiso(SIZE(this)))
4561INQUIRE(unit, form=form)
4562IF (form == 'FORMATTED') THEN
4563 READ(unit,'(3(A23,1X))')dateiso
4564ELSE
4565 READ(unit)dateiso
4566ENDIF
4567DO i = 1, SIZE(dateiso)
4569ENDDO
4570DEALLOCATE(dateiso)
4571
4572END SUBROUTINE timedelta_vect_read_unit
4573
4574
4579SUBROUTINE timedelta_write_unit(this, unit)
4580TYPE(timedelta),INTENT(in) :: this
4581INTEGER, INTENT(in) :: unit
4582
4583CALL timedelta_vect_write_unit((/this/), unit)
4584
4585END SUBROUTINE timedelta_write_unit
4586
4587
4592SUBROUTINE timedelta_vect_write_unit(this, unit)
4593TYPE(timedelta),INTENT(in) :: this(:)
4594INTEGER, INTENT(in) :: unit
4595
4596CHARACTER(len=40) :: form
4597CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4598INTEGER :: i
4599
4600ALLOCATE(dateiso(SIZE(this)))
4601DO i = 1, SIZE(dateiso)
4603ENDDO
4604INQUIRE(unit, form=form)
4605IF (form == 'FORMATTED') THEN
4606 WRITE(unit,'(3(A23,1X))')dateiso
4607ELSE
4608 WRITE(unit)dateiso
4609ENDIF
4610DEALLOCATE(dateiso)
4611
4612END SUBROUTINE timedelta_vect_write_unit
4613
4614
4615ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4616TYPE(timedelta),INTENT(in) :: this
4617LOGICAL :: res
4618
4619res = .not. this == timedelta_miss
4620
4621end FUNCTION c_e_timedelta
4622
4623
4624elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4625
4626!!omstart JELADATA5
4627! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4628! 1 IMINUTI)
4629!
4630! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4631!
4632! variabili integer*4
4633! IN:
4634! IDAY,IMONTH,IYEAR, I*4
4635! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4636!
4637! OUT:
4638! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4639!!OMEND
4640
4641INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4642INTEGER,intent(out) :: iminuti
4643
4644iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4645
4646END SUBROUTINE jeladata5
4647
4648
4649elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4650INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4651INTEGER(KIND=int_ll),intent(out) :: imillisec
4652
4653imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4654 + imsec
4655
4656END SUBROUTINE jeladata5_1
4657
4658
4659
4660elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4661
4662!!omstart JELADATA6
4663! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4664! 1 IMINUTI)
4665!
4666! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4667! 1/1/1
4668!
4669! variabili integer*4
4670! IN:
4671! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4672!
4673! OUT:
4674! IDAY,IMONTH,IYEAR, I*4
4675! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4676!!OMEND
4677
4678
4679INTEGER,intent(in) :: iminuti
4680INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4681
4682INTEGER ::igiorno
4683
4684imin = mod(iminuti,60)
4685ihour = mod(iminuti,1440)/60
4686igiorno = iminuti/1440
4688CALL ndyin(igiorno,iday,imonth,iyear)
4689
4690END SUBROUTINE jeladata6
4691
4692
4693elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4694INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4695INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4696
4697INTEGER :: igiorno
4698
4700!imin = MOD(imillisec/60000_int_ll, 60)
4701!ihour = MOD(imillisec/3600000_int_ll, 24)
4702imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4703ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4704igiorno = int(imillisec/86400000_int_ll)
4705!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4706CALL ndyin(igiorno,iday,imonth,iyear)
4707
4708END SUBROUTINE jeladata6_1
4709
4710
4711elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4712
4713!!OMSTART NDYIN
4714! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4715! restituisce la data fornendo in input il numero di
4716! giorni dal 1/1/1
4717!
4718!!omend
4719
4720INTEGER,intent(in) :: ndays
4721INTEGER,intent(out) :: igg, imm, iaa
4722integer :: n,lndays
4723
4724lndays=ndays
4725
4726n = lndays/d400
4727lndays = lndays - n*d400
4728iaa = year0 + n*400
4729n = min(lndays/d100, 3)
4730lndays = lndays - n*d100
4731iaa = iaa + n*100
4732n = lndays/d4
4733lndays = lndays - n*d4
4734iaa = iaa + n*4
4735n = min(lndays/d1, 3)
4736lndays = lndays - n*d1
4737iaa = iaa + n
4738n = bisextilis(iaa)
4739DO imm = 1, 12
4740 IF (lndays < ianno(imm+1,n)) EXIT
4741ENDDO
4742igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4743
4744END SUBROUTINE ndyin
4745
4746
4747integer elemental FUNCTION ndays(igg,imm,iaa)
4748
4749!!OMSTART NDAYS
4750! FUNCTION NDAYS(IGG,IMM,IAA)
4751! restituisce il numero di giorni dal 1/1/1
4752! fornendo in input la data
4753!
4754!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4755! nota bene E' SICURO !!!
4756! un anno e' bisestile se divisibile per 4
4757! un anno rimane bisestile se divisibile per 400
4758! un anno NON e' bisestile se divisibile per 100
4759!
4760!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4761!
4762!!omend
4763
4764INTEGER, intent(in) :: igg, imm, iaa
4765
4766INTEGER :: lmonth, lyear
4767
4768! Limito il mese a [1-12] e correggo l'anno coerentemente
4769lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4770lyear = iaa + (imm - lmonth)/12
4771ndays = igg+ianno(lmonth, bisextilis(lyear))
4772ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4773 (lyear-year0)/400
4774
4775END FUNCTION ndays
4776
4777
4778elemental FUNCTION bisextilis(annum)
4779INTEGER,INTENT(in) :: annum
4780INTEGER :: bisextilis
4781
4783 bisextilis = 2
4784ELSE
4785 bisextilis = 1
4786ENDIF
4787END FUNCTION bisextilis
4788
4789
4790ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4791TYPE(cyclicdatetime),INTENT(IN) :: this, that
4792LOGICAL :: res
4793
4794res = .true.
4795if (this%minute /= that%minute) res=.false.
4796if (this%hour /= that%hour) res=.false.
4797if (this%day /= that%day) res=.false.
4798if (this%month /= that%month) res=.false.
4799if (this%tendaysp /= that%tendaysp) res=.false.
4800
4801END FUNCTION cyclicdatetime_eq
4802
4803
4804ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4805TYPE(cyclicdatetime),INTENT(IN) :: this
4806TYPE(datetime),INTENT(IN) :: that
4807LOGICAL :: res
4808
4809integer :: minute,hour,day,month
4810
4812
4813res = .true.
4819 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4820end if
4821
4822END FUNCTION cyclicdatetime_datetime_eq
4823
4824
4825ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4826TYPE(datetime),INTENT(IN) :: this
4827TYPE(cyclicdatetime),INTENT(IN) :: that
4828LOGICAL :: res
4829
4830integer :: minute,hour,day,month
4831
4833
4834res = .true.
4839
4841 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4842end if
4843
4844
4845END FUNCTION datetime_cyclicdatetime_eq
4846
4847ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4848TYPE(cyclicdatetime),INTENT(in) :: this
4849LOGICAL :: res
4850
4851res = .not. this == cyclicdatetime_miss
4852
4853end FUNCTION c_e_cyclicdatetime
4854
4855
4858FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4859INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4860INTEGER,INTENT(IN),OPTIONAL :: month
4861INTEGER,INTENT(IN),OPTIONAL :: day
4862INTEGER,INTENT(IN),OPTIONAL :: hour
4863INTEGER,INTENT(IN),OPTIONAL :: minute
4864CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4865
4866integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4867
4868
4869TYPE(cyclicdatetime) :: this
4870
4871if (present(chardate)) then
4872
4873 ltendaysp=imiss
4874 lmonth=imiss
4875 lday=imiss
4876 lhour=imiss
4877 lminute=imiss
4878
4880 ! TMMGGhhmm
4881 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4882 !print*,chardate(1:1),ios,ltendaysp
4883 if (ios /= 0)ltendaysp=imiss
4884
4885 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4886 !print*,chardate(2:3),ios,lmonth
4887 if (ios /= 0)lmonth=imiss
4888
4889 read(chardate(4:5),'(i2)',iostat=ios)lday
4890 !print*,chardate(4:5),ios,lday
4891 if (ios /= 0)lday=imiss
4892
4893 read(chardate(6:7),'(i2)',iostat=ios)lhour
4894 !print*,chardate(6:7),ios,lhour
4895 if (ios /= 0)lhour=imiss
4896
4897 read(chardate(8:9),'(i2)',iostat=ios)lminute
4898 !print*,chardate(8:9),ios,lminute
4899 if (ios /= 0)lminute=imiss
4900 end if
4901
4902 this%tendaysp=ltendaysp
4903 this%month=lmonth
4904 this%day=lday
4905 this%hour=lhour
4906 this%minute=lminute
4907else
4908 this%tendaysp=optio_l(tendaysp)
4909 this%month=optio_l(month)
4910 this%day=optio_l(day)
4911 this%hour=optio_l(hour)
4912 this%minute=optio_l(minute)
4913end if
4914
4915END FUNCTION cyclicdatetime_new
4916
4919elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4920TYPE(cyclicdatetime),INTENT(IN) :: this
4921
4922CHARACTER(len=80) :: char
4923
4926
4927END FUNCTION cyclicdatetime_to_char
4928
4929
4942FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4943TYPE(cyclicdatetime),INTENT(IN) :: this
4944
4945TYPE(datetime) :: dtc
4946
4947integer :: year,month,day,hour
4948
4949dtc = datetime_miss
4950
4951! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4953 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4954 return
4955end if
4956
4957! minute present -> not good for conventional datetime
4959! day, month and tendaysp present -> no good
4961
4963 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4965 day=(this%tendaysp-1)*10+1
4966 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4968 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4970 ! only day present -> no good
4971 return
4972end if
4973
4976 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4977end if
4978
4979
4980END FUNCTION cyclicdatetime_to_conventional
4981
4982
4983
4984FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4985TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4986
4987CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4988
4989char=cyclicdatetime_to_char(in)
4990
4991END FUNCTION trim_cyclicdatetime_to_char
4992
4993
4994
4995SUBROUTINE display_cyclicdatetime(this)
4996TYPE(cyclicdatetime),INTENT(in) :: this
4997
4999
5000end subroutine display_cyclicdatetime
5001
5002
5003#include "array_utilities_inc.F90"
5004
5006
Quick method to append an element to the array. Definition: datetime_class.F90:622 Restituiscono il valore dell'oggetto nella forma desiderata. Definition: datetime_class.F90:328 Costruttori per le classi datetime e timedelta. Definition: datetime_class.F90:317 Method for inserting elements of the array at a desired position. Definition: datetime_class.F90:613 Method for packing the array object reducing at a minimum the memory occupation, without destroying i... Definition: datetime_class.F90:645 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition: datetime_class.F90:484 Method for removing elements of the array at a desired position. Definition: datetime_class.F90:628 Functions that return a trimmed CHARACTER representation of the input variable. Definition: datetime_class.F90:355 Restituiscono il valore dell'oggetto in forma di stringa stampabile. Definition: datetime_class.F90:333 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition: datetime_class.F90:491 Definition of constants to be used for declaring variables of a desired type. Definition: kinds.F90:251 Definitions of constants and functions for working with missing values. Definition: missing_values.f90:50 Module for quickly interpreting the OPTIONAL parameters passed to a subprogram. Definition: optional_values.f90:28 Class for expressing a cyclic datetime. Definition: datetime_class.F90:261 Class for expressing an absolute time value. Definition: datetime_class.F90:239 Class for expressing a relative time interval. Definition: datetime_class.F90:251 |