libsim Versione 7.2.1
|
◆ 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 3162 del file datetime_class.F90. 3163! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
3164! authors:
3165! Davide Cesari <dcesari@arpa.emr.it>
3166! Paolo Patruno <ppatruno@arpa.emr.it>
3167
3168! This program is free software; you can redistribute it and/or
3169! modify it under the terms of the GNU General Public License as
3170! published by the Free Software Foundation; either version 2 of
3171! the License, or (at your option) any later version.
3172
3173! This program is distributed in the hope that it will be useful,
3174! but WITHOUT ANY WARRANTY; without even the implied warranty of
3175! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3176! GNU General Public License for more details.
3177
3178! You should have received a copy of the GNU General Public License
3179! along with this program. If not, see <http://www.gnu.org/licenses/>.
3180#include "config.h"
3181
3202IMPLICIT NONE
3203
3204INTEGER, PARAMETER :: dateint=selected_int_kind(13)
3205
3208 PRIVATE
3209 INTEGER(KIND=int_ll) :: iminuti
3211
3220 PRIVATE
3221 INTEGER(KIND=int_ll) :: iminuti
3222 INTEGER :: month
3224
3225
3230 PRIVATE
3231 INTEGER :: minute
3232 INTEGER :: hour
3233 INTEGER :: day
3234 INTEGER :: tendaysp
3235 INTEGER :: month
3237
3238
3246INTEGER, PARAMETER :: datetime_utc=1
3248INTEGER, PARAMETER :: datetime_local=2
3258TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
3259
3260
3261INTEGER(kind=dateint), PARAMETER :: &
3262 sec_in_day=86400, &
3263 sec_in_hour=3600, &
3264 sec_in_min=60, &
3265 min_in_day=1440, &
3266 min_in_hour=60, &
3267 hour_in_day=24
3268
3269INTEGER,PARAMETER :: &
3270 year0=1, & ! anno di origine per iminuti
3271 d1=365, & ! giorni/1 anno nel calendario gregoriano
3272 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
3273 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
3274 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
3275 ianno(13,2)=reshape((/ &
3276 0,31,59,90,120,151,181,212,243,273,304,334,365, &
3277 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
3278
3279INTEGER(KIND=int_ll),PARAMETER :: &
3280 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
3281
3286 MODULE PROCEDURE datetime_init, timedelta_init
3287END INTERFACE
3288
3292 MODULE PROCEDURE datetime_delete, timedelta_delete
3293END INTERFACE
3294
3297 MODULE PROCEDURE datetime_getval, timedelta_getval
3298END INTERFACE
3299
3302 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
3303END INTERFACE
3304
3305
3324 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
3325END INTERFACE
3326
3332INTERFACE OPERATOR (==)
3333 MODULE PROCEDURE datetime_eq, timedelta_eq, &
3334 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
3335END INTERFACE
3336
3342INTERFACE OPERATOR (/=)
3343 MODULE PROCEDURE datetime_ne, timedelta_ne
3344END INTERFACE
3345
3353INTERFACE OPERATOR (>)
3354 MODULE PROCEDURE datetime_gt, timedelta_gt
3355END INTERFACE
3356
3364INTERFACE OPERATOR (<)
3365 MODULE PROCEDURE datetime_lt, timedelta_lt
3366END INTERFACE
3367
3375INTERFACE OPERATOR (>=)
3376 MODULE PROCEDURE datetime_ge, timedelta_ge
3377END INTERFACE
3378
3386INTERFACE OPERATOR (<=)
3387 MODULE PROCEDURE datetime_le, timedelta_le
3388END INTERFACE
3389
3396INTERFACE OPERATOR (+)
3397 MODULE PROCEDURE datetime_add, timedelta_add
3398END INTERFACE
3399
3407INTERFACE OPERATOR (-)
3408 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
3409END INTERFACE
3410
3416INTERFACE OPERATOR (*)
3417 MODULE PROCEDURE timedelta_mult, timedelta_tlum
3418END INTERFACE
3419
3426INTERFACE OPERATOR (/)
3427 MODULE PROCEDURE timedelta_divint, timedelta_divtd
3428END INTERFACE
3429
3441 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3442END INTERFACE
3443
3447 MODULE PROCEDURE timedelta_abs
3448END INTERFACE
3449
3453 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3454 timedelta_read_unit, timedelta_vect_read_unit
3455END INTERFACE
3456
3460 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3461 timedelta_write_unit, timedelta_vect_write_unit
3462END INTERFACE
3463
3466 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3467END INTERFACE
3468
3471 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
3472END INTERFACE
3473
3474#undef VOL7D_POLY_TYPE
3475#undef VOL7D_POLY_TYPES
3476#undef ENABLE_SORT
3477#define VOL7D_POLY_TYPE TYPE(datetime)
3478#define VOL7D_POLY_TYPES _datetime
3479#define ENABLE_SORT
3480#include "array_utilities_pre.F90"
3481
3482
3483#define ARRAYOF_ORIGTYPE TYPE(datetime)
3484#define ARRAYOF_TYPE arrayof_datetime
3485#define ARRAYOF_ORIGEQ 1
3486#include "arrayof_pre.F90"
3487! from arrayof
3488
3489PRIVATE
3490
3492 datetime_min, datetime_max, &
3495 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3496 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3498 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3499 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3501 count_distinct, pack_distinct, &
3502 count_distinct_sorted, pack_distinct_sorted, &
3503 count_and_pack_distinct, &
3505 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
3507PUBLIC insert_unique, append_unique
3508PUBLIC cyclicdatetime_to_conventional
3509
3510CONTAINS
3511
3512
3513! ==============
3514! == datetime ==
3515! ==============
3516
3523ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3524 unixtime, isodate, simpledate) RESULT(this)
3525INTEGER,INTENT(IN),OPTIONAL :: year
3526INTEGER,INTENT(IN),OPTIONAL :: month
3527INTEGER,INTENT(IN),OPTIONAL :: day
3528INTEGER,INTENT(IN),OPTIONAL :: hour
3529INTEGER,INTENT(IN),OPTIONAL :: minute
3530INTEGER,INTENT(IN),OPTIONAL :: msec
3531INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3532CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3533CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3534
3535TYPE(datetime) :: this
3536INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3537CHARACTER(len=23) :: datebuf
3538
3539IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3540 lyear = year
3541 IF (PRESENT(month)) THEN
3542 lmonth = month
3543 ELSE
3544 lmonth = 1
3545 ENDIF
3546 IF (PRESENT(day)) THEN
3547 lday = day
3548 ELSE
3549 lday = 1
3550 ENDIF
3551 IF (PRESENT(hour)) THEN
3552 lhour = hour
3553 ELSE
3554 lhour = 0
3555 ENDIF
3556 IF (PRESENT(minute)) THEN
3557 lminute = minute
3558 ELSE
3559 lminute = 0
3560 ENDIF
3561 IF (PRESENT(msec)) THEN
3562 lmsec = msec
3563 ELSE
3564 lmsec = 0
3565 ENDIF
3566
3569 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3570 else
3571 this=datetime_miss
3572 end if
3573
3574ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3576 this%iminuti = (unixtime + unsec)*1000
3577 else
3578 this=datetime_miss
3579 end if
3580
3581ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3582
3584 datebuf(1:23) = '0001-01-01 00:00:00.000'
3585 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3586 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3587 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3588 lmsec = lmsec + lsec*1000
3589 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3590 RETURN
3591
3592100 CONTINUE ! condizione di errore in isodate
3594 RETURN
3595 ELSE
3596 this = datetime_miss
3597 ENDIF
3598
3599ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3601 datebuf(1:17) = '00010101000000000'
3602 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3603 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3604 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3605 lmsec = lmsec + lsec*1000
3606 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3607 RETURN
3608
3609120 CONTINUE ! condizione di errore in simpledate
3611 RETURN
3612 ELSE
3613 this = datetime_miss
3614 ENDIF
3615
3616ELSE
3617 this = datetime_miss
3618ENDIF
3619
3620END FUNCTION datetime_new
3621
3622
3624FUNCTION datetime_new_now(now) RESULT(this)
3625INTEGER,INTENT(IN) :: now
3626TYPE(datetime) :: this
3627
3628INTEGER :: dt(8)
3629
3631 CALL date_and_time(values=dt)
3632 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3634 msec=dt(7)*1000+dt(8))
3635ELSE
3636 this = datetime_miss
3637ENDIF
3638
3639END FUNCTION datetime_new_now
3640
3641
3648SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3649 unixtime, isodate, simpledate, now)
3650TYPE(datetime),INTENT(INOUT) :: this
3651INTEGER,INTENT(IN),OPTIONAL :: year
3652INTEGER,INTENT(IN),OPTIONAL :: month
3653INTEGER,INTENT(IN),OPTIONAL :: day
3654INTEGER,INTENT(IN),OPTIONAL :: hour
3655INTEGER,INTENT(IN),OPTIONAL :: minute
3656INTEGER,INTENT(IN),OPTIONAL :: msec
3657INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3658CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3659CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3660INTEGER,INTENT(IN),OPTIONAL :: now
3661
3662IF (PRESENT(now)) THEN
3663 this = datetime_new_now(now)
3664ELSE
3665 this = datetime_new(year, month, day, hour, minute, msec, &
3666 unixtime, isodate, simpledate)
3667ENDIF
3668
3669END SUBROUTINE datetime_init
3670
3671
3672ELEMENTAL SUBROUTINE datetime_delete(this)
3673TYPE(datetime),INTENT(INOUT) :: this
3674
3675this%iminuti = illmiss
3676
3677END SUBROUTINE datetime_delete
3678
3679
3684PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3685 unixtime, isodate, simpledate, oraclesimdate)
3686TYPE(datetime),INTENT(IN) :: this
3687INTEGER,INTENT(OUT),OPTIONAL :: year
3688INTEGER,INTENT(OUT),OPTIONAL :: month
3689INTEGER,INTENT(OUT),OPTIONAL :: day
3690INTEGER,INTENT(OUT),OPTIONAL :: hour
3691INTEGER,INTENT(OUT),OPTIONAL :: minute
3692INTEGER,INTENT(OUT),OPTIONAL :: msec
3693INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3694CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3695CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3696CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3697
3698INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3699CHARACTER(len=23) :: datebuf
3700
3701IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3702 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3703 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3704
3705 IF (this == datetime_miss) THEN
3706
3707 IF (PRESENT(msec)) THEN
3708 msec = imiss
3709 ENDIF
3710 IF (PRESENT(minute)) THEN
3711 minute = imiss
3712 ENDIF
3713 IF (PRESENT(hour)) THEN
3714 hour = imiss
3715 ENDIF
3716 IF (PRESENT(day)) THEN
3717 day = imiss
3718 ENDIF
3719 IF (PRESENT(month)) THEN
3720 month = imiss
3721 ENDIF
3722 IF (PRESENT(year)) THEN
3723 year = imiss
3724 ENDIF
3725 IF (PRESENT(isodate)) THEN
3726 isodate = cmiss
3727 ENDIF
3728 IF (PRESENT(simpledate)) THEN
3729 simpledate = cmiss
3730 ENDIF
3731 IF (PRESENT(oraclesimdate)) THEN
3732!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3733!!$ 'obsoleto, usare piuttosto simpledate')
3734 oraclesimdate=cmiss
3735 ENDIF
3736 IF (PRESENT(unixtime)) THEN
3737 unixtime = illmiss
3738 ENDIF
3739
3740 ELSE
3741
3742 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3743 IF (PRESENT(msec)) THEN
3744 msec = lmsec
3745 ENDIF
3746 IF (PRESENT(minute)) THEN
3747 minute = lminute
3748 ENDIF
3749 IF (PRESENT(hour)) THEN
3750 hour = lhour
3751 ENDIF
3752 IF (PRESENT(day)) THEN
3753 day = lday
3754 ENDIF
3755 IF (PRESENT(month)) THEN
3756 month = lmonth
3757 ENDIF
3758 IF (PRESENT(year)) THEN
3759 year = lyear
3760 ENDIF
3761 IF (PRESENT(isodate)) THEN
3762 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3763 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3765 isodate = datebuf(1:min(len(isodate),23))
3766 ENDIF
3767 IF (PRESENT(simpledate)) THEN
3768 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3769 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3770 simpledate = datebuf(1:min(len(simpledate),17))
3771 ENDIF
3772 IF (PRESENT(oraclesimdate)) THEN
3773!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3774!!$ 'obsoleto, usare piuttosto simpledate')
3775 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3776 ENDIF
3777 IF (PRESENT(unixtime)) THEN
3778 unixtime = this%iminuti/1000_int_ll-unsec
3779 ENDIF
3780
3781 ENDIF
3782ENDIF
3783
3784END SUBROUTINE datetime_getval
3785
3786
3789elemental FUNCTION datetime_to_char(this) RESULT(char)
3790TYPE(datetime),INTENT(IN) :: this
3791
3792CHARACTER(len=23) :: char
3793
3795
3796END FUNCTION datetime_to_char
3797
3798
3799FUNCTION trim_datetime_to_char(in) RESULT(char)
3800TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3801
3802CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3803
3804char=datetime_to_char(in)
3805
3806END FUNCTION trim_datetime_to_char
3807
3808
3809
3810SUBROUTINE display_datetime(this)
3811TYPE(datetime),INTENT(in) :: this
3812
3814
3815end subroutine display_datetime
3816
3817
3818
3819SUBROUTINE display_timedelta(this)
3820TYPE(timedelta),INTENT(in) :: this
3821
3823
3824end subroutine display_timedelta
3825
3826
3827
3828ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3829TYPE(datetime),INTENT(in) :: this
3830LOGICAL :: res
3831
3832res = .not. this == datetime_miss
3833
3834end FUNCTION c_e_datetime
3835
3836
3837ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3838TYPE(datetime),INTENT(IN) :: this, that
3839LOGICAL :: res
3840
3841res = this%iminuti == that%iminuti
3842
3843END FUNCTION datetime_eq
3844
3845
3846ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3847TYPE(datetime),INTENT(IN) :: this, that
3848LOGICAL :: res
3849
3850res = .NOT.(this == that)
3851
3852END FUNCTION datetime_ne
3853
3854
3855ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3856TYPE(datetime),INTENT(IN) :: this, that
3857LOGICAL :: res
3858
3859res = this%iminuti > that%iminuti
3860
3861END FUNCTION datetime_gt
3862
3863
3864ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3865TYPE(datetime),INTENT(IN) :: this, that
3866LOGICAL :: res
3867
3868res = this%iminuti < that%iminuti
3869
3870END FUNCTION datetime_lt
3871
3872
3873ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3874TYPE(datetime),INTENT(IN) :: this, that
3875LOGICAL :: res
3876
3877IF (this == that) THEN
3878 res = .true.
3879ELSE IF (this > that) THEN
3880 res = .true.
3881ELSE
3882 res = .false.
3883ENDIF
3884
3885END FUNCTION datetime_ge
3886
3887
3888ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3889TYPE(datetime),INTENT(IN) :: this, that
3890LOGICAL :: res
3891
3892IF (this == that) THEN
3893 res = .true.
3894ELSE IF (this < that) THEN
3895 res = .true.
3896ELSE
3897 res = .false.
3898ENDIF
3899
3900END FUNCTION datetime_le
3901
3902
3903FUNCTION datetime_add(this, that) RESULT(res)
3904TYPE(datetime),INTENT(IN) :: this
3905TYPE(timedelta),INTENT(IN) :: that
3906TYPE(datetime) :: res
3907
3908INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3909
3910IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3911 res = datetime_miss
3912ELSE
3913 res%iminuti = this%iminuti + that%iminuti
3914 IF (that%month /= 0) THEN
3916 minute=lminute, msec=lmsec)
3918 hour=lhour, minute=lminute, msec=lmsec)
3919 ENDIF
3920ENDIF
3921
3922END FUNCTION datetime_add
3923
3924
3925ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3926TYPE(datetime),INTENT(IN) :: this, that
3927TYPE(timedelta) :: res
3928
3929IF (this == datetime_miss .OR. that == datetime_miss) THEN
3930 res = timedelta_miss
3931ELSE
3932 res%iminuti = this%iminuti - that%iminuti
3933 res%month = 0
3934ENDIF
3935
3936END FUNCTION datetime_subdt
3937
3938
3939FUNCTION datetime_subtd(this, that) RESULT(res)
3940TYPE(datetime),INTENT(IN) :: this
3941TYPE(timedelta),INTENT(IN) :: that
3942TYPE(datetime) :: res
3943
3944INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3945
3946IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3947 res = datetime_miss
3948ELSE
3949 res%iminuti = this%iminuti - that%iminuti
3950 IF (that%month /= 0) THEN
3952 minute=lminute, msec=lmsec)
3954 hour=lhour, minute=lminute, msec=lmsec)
3955 ENDIF
3956ENDIF
3957
3958END FUNCTION datetime_subtd
3959
3960
3965SUBROUTINE datetime_read_unit(this, unit)
3966TYPE(datetime),INTENT(out) :: this
3967INTEGER, INTENT(in) :: unit
3968CALL datetime_vect_read_unit((/this/), unit)
3969
3970END SUBROUTINE datetime_read_unit
3971
3972
3977SUBROUTINE datetime_vect_read_unit(this, unit)
3978TYPE(datetime) :: this(:)
3979INTEGER, INTENT(in) :: unit
3980
3981CHARACTER(len=40) :: form
3982CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3983INTEGER :: i
3984
3985ALLOCATE(dateiso(SIZE(this)))
3986INQUIRE(unit, form=form)
3987IF (form == 'FORMATTED') THEN
3988 READ(unit,'(A23,1X)')dateiso
3989ELSE
3990 READ(unit)dateiso
3991ENDIF
3992DO i = 1, SIZE(dateiso)
3994ENDDO
3995DEALLOCATE(dateiso)
3996
3997END SUBROUTINE datetime_vect_read_unit
3998
3999
4004SUBROUTINE datetime_write_unit(this, unit)
4005TYPE(datetime),INTENT(in) :: this
4006INTEGER, INTENT(in) :: unit
4007
4008CALL datetime_vect_write_unit((/this/), unit)
4009
4010END SUBROUTINE datetime_write_unit
4011
4012
4017SUBROUTINE datetime_vect_write_unit(this, unit)
4018TYPE(datetime),INTENT(in) :: this(:)
4019INTEGER, INTENT(in) :: unit
4020
4021CHARACTER(len=40) :: form
4022CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4023INTEGER :: i
4024
4025ALLOCATE(dateiso(SIZE(this)))
4026DO i = 1, SIZE(dateiso)
4028ENDDO
4029INQUIRE(unit, form=form)
4030IF (form == 'FORMATTED') THEN
4031 WRITE(unit,'(A23,1X)')dateiso
4032ELSE
4033 WRITE(unit)dateiso
4034ENDIF
4035DEALLOCATE(dateiso)
4036
4037END SUBROUTINE datetime_vect_write_unit
4038
4039
4040#include "arrayof_post.F90"
4041
4042
4043! ===============
4044! == timedelta ==
4045! ===============
4052FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
4053 isodate, simpledate, oraclesimdate) RESULT (this)
4054INTEGER,INTENT(IN),OPTIONAL :: year
4055INTEGER,INTENT(IN),OPTIONAL :: month
4056INTEGER,INTENT(IN),OPTIONAL :: day
4057INTEGER,INTENT(IN),OPTIONAL :: hour
4058INTEGER,INTENT(IN),OPTIONAL :: minute
4059INTEGER,INTENT(IN),OPTIONAL :: sec
4060INTEGER,INTENT(IN),OPTIONAL :: msec
4061CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
4062CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
4063CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
4064
4065TYPE(timedelta) :: this
4066
4067CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
4068 isodate, simpledate, oraclesimdate)
4069
4070END FUNCTION timedelta_new
4071
4072
4077SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
4078 isodate, simpledate, oraclesimdate)
4079TYPE(timedelta),INTENT(INOUT) :: this
4080INTEGER,INTENT(IN),OPTIONAL :: year
4081INTEGER,INTENT(IN),OPTIONAL :: month
4082INTEGER,INTENT(IN),OPTIONAL :: day
4083INTEGER,INTENT(IN),OPTIONAL :: hour
4084INTEGER,INTENT(IN),OPTIONAL :: minute
4085INTEGER,INTENT(IN),OPTIONAL :: sec
4086INTEGER,INTENT(IN),OPTIONAL :: msec
4087CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
4088CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
4089CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
4090
4091INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
4092CHARACTER(len=23) :: datebuf
4093
4094this%month = 0
4095
4096IF (PRESENT(isodate)) THEN
4097 datebuf(1:23) = '0000000000 00:00:00.000'
4098 l = len_trim(isodate)
4099! IF (l > 0) THEN
4101 IF (n > 0) THEN
4102 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
4103 datebuf(12-n:12-n+l-1) = isodate(:l)
4104 ELSE
4105 datebuf(1:l) = isodate(1:l)
4106 ENDIF
4107! ENDIF
4108
4109! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
4110 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
4111 h, m, s, ms
4112 this%month = lmonth + 12*lyear
4113 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4114 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4115 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4116 RETURN
4117
4118200 CONTINUE ! condizione di errore in isodate
4120 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
4121 CALL raise_error()
4122
4123ELSE IF (PRESENT(simpledate)) THEN
4124 datebuf(1:17) = '00000000000000000'
4125 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
4126 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
4127 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4128 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4129 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4130
4131220 CONTINUE ! condizione di errore in simpledate
4133 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
4134 CALL raise_error()
4135 RETURN
4136
4137ELSE IF (PRESENT(oraclesimdate)) THEN
4138 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
4139 'obsoleto, usare piuttosto simpledate')
4140 READ(oraclesimdate, '(I8,2I2)')d, h, m
4141 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4142 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
4143
4144ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
4145 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
4146 .and. .not. present(msec) .and. .not. present(isodate) &
4147 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
4148
4149 this=timedelta_miss
4150
4151ELSE
4152 this%iminuti = 0
4153 IF (PRESENT(year)) THEN
4155 this%month = this%month + year*12
4156 else
4157 this=timedelta_miss
4158 return
4159 end if
4160 ENDIF
4161 IF (PRESENT(month)) THEN
4163 this%month = this%month + month
4164 else
4165 this=timedelta_miss
4166 return
4167 end if
4168 ENDIF
4169 IF (PRESENT(day)) THEN
4171 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
4172 else
4173 this=timedelta_miss
4174 return
4175 end if
4176 ENDIF
4177 IF (PRESENT(hour)) THEN
4179 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
4180 else
4181 this=timedelta_miss
4182 return
4183 end if
4184 ENDIF
4185 IF (PRESENT(minute)) THEN
4187 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
4188 else
4189 this=timedelta_miss
4190 return
4191 end if
4192 ENDIF
4193 IF (PRESENT(sec)) THEN
4195 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
4196 else
4197 this=timedelta_miss
4198 return
4199 end if
4200 ENDIF
4201 IF (PRESENT(msec)) THEN
4203 this%iminuti = this%iminuti + msec
4204 else
4205 this=timedelta_miss
4206 return
4207 end if
4208 ENDIF
4209ENDIF
4210
4211
4212
4213
4214END SUBROUTINE timedelta_init
4215
4216
4217SUBROUTINE timedelta_delete(this)
4218TYPE(timedelta),INTENT(INOUT) :: this
4219
4220this%iminuti = imiss
4221this%month = 0
4222
4223END SUBROUTINE timedelta_delete
4224
4225
4230PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
4231 day, hour, minute, sec, msec, &
4232 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
4233TYPE(timedelta),INTENT(IN) :: this
4234INTEGER,INTENT(OUT),OPTIONAL :: year
4235INTEGER,INTENT(OUT),OPTIONAL :: month
4236INTEGER,INTENT(OUT),OPTIONAL :: amonth
4237INTEGER,INTENT(OUT),OPTIONAL :: day
4238INTEGER,INTENT(OUT),OPTIONAL :: hour
4239INTEGER,INTENT(OUT),OPTIONAL :: minute
4240INTEGER,INTENT(OUT),OPTIONAL :: sec
4241INTEGER,INTENT(OUT),OPTIONAL :: msec
4242INTEGER,INTENT(OUT),OPTIONAL :: ahour
4243INTEGER,INTENT(OUT),OPTIONAL :: aminute
4244INTEGER,INTENT(OUT),OPTIONAL :: asec
4245INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
4246CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
4247CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
4248CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
4249
4250CHARACTER(len=23) :: datebuf
4251
4252IF (PRESENT(amsec)) THEN
4253 amsec = this%iminuti
4254ENDIF
4255IF (PRESENT(asec)) THEN
4256 asec = int(this%iminuti/1000_int_ll)
4257ENDIF
4258IF (PRESENT(aminute)) THEN
4259 aminute = int(this%iminuti/60000_int_ll)
4260ENDIF
4261IF (PRESENT(ahour)) THEN
4262 ahour = int(this%iminuti/3600000_int_ll)
4263ENDIF
4264IF (PRESENT(msec)) THEN
4265 msec = int(mod(this%iminuti, 1000_int_ll))
4266ENDIF
4267IF (PRESENT(sec)) THEN
4268 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
4269ENDIF
4270IF (PRESENT(minute)) THEN
4271 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
4272ENDIF
4273IF (PRESENT(hour)) THEN
4274 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
4275ENDIF
4276IF (PRESENT(day)) THEN
4277 day = int(this%iminuti/86400000_int_ll)
4278ENDIF
4279IF (PRESENT(amonth)) THEN
4280 amonth = this%month
4281ENDIF
4282IF (PRESENT(month)) THEN
4283 month = mod(this%month-1,12)+1
4284ENDIF
4285IF (PRESENT(year)) THEN
4286 year = this%month/12
4287ENDIF
4288IF (PRESENT(isodate)) THEN ! Non standard, inventato!
4289 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
4293 isodate = datebuf(1:min(len(isodate),23))
4294
4295ENDIF
4296IF (PRESENT(simpledate)) THEN
4297 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
4298 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
4300 mod(this%iminuti, 1000_int_ll)
4301 simpledate = datebuf(1:min(len(simpledate),17))
4302ENDIF
4303IF (PRESENT(oraclesimdate)) THEN
4304!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
4305!!$ 'obsoleto, usare piuttosto simpledate')
4306 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
4308ENDIF
4309
4310END SUBROUTINE timedelta_getval
4311
4312
4315elemental FUNCTION timedelta_to_char(this) RESULT(char)
4316TYPE(timedelta),INTENT(IN) :: this
4317
4318CHARACTER(len=23) :: char
4319
4321
4322END FUNCTION timedelta_to_char
4323
4324
4325FUNCTION trim_timedelta_to_char(in) RESULT(char)
4326TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
4327
4328CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
4329
4330char=timedelta_to_char(in)
4331
4332END FUNCTION trim_timedelta_to_char
4333
4334
4336elemental FUNCTION timedelta_getamsec(this)
4337TYPE(timedelta),INTENT(IN) :: this
4338INTEGER(kind=int_ll) :: timedelta_getamsec
4339
4340timedelta_getamsec = this%iminuti
4341
4342END FUNCTION timedelta_getamsec
4343
4344
4350FUNCTION timedelta_depop(this)
4351TYPE(timedelta),INTENT(IN) :: this
4352TYPE(timedelta) :: timedelta_depop
4353
4354TYPE(datetime) :: tmpdt
4355
4356IF (this%month == 0) THEN
4357 timedelta_depop = this
4358ELSE
4359 tmpdt = datetime_new(1970, 1, 1)
4360 timedelta_depop = (tmpdt + this) - tmpdt
4361ENDIF
4362
4363END FUNCTION timedelta_depop
4364
4365
4366elemental FUNCTION timedelta_eq(this, that) RESULT(res)
4367TYPE(timedelta),INTENT(IN) :: this, that
4368LOGICAL :: res
4369
4370res = (this%iminuti == that%iminuti .AND. this%month == that%month)
4371
4372END FUNCTION timedelta_eq
4373
4374
4375ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
4376TYPE(timedelta),INTENT(IN) :: this, that
4377LOGICAL :: res
4378
4379res = .NOT.(this == that)
4380
4381END FUNCTION timedelta_ne
4382
4383
4384ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
4385TYPE(timedelta),INTENT(IN) :: this, that
4386LOGICAL :: res
4387
4388res = this%iminuti > that%iminuti
4389
4390END FUNCTION timedelta_gt
4391
4392
4393ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
4394TYPE(timedelta),INTENT(IN) :: this, that
4395LOGICAL :: res
4396
4397res = this%iminuti < that%iminuti
4398
4399END FUNCTION timedelta_lt
4400
4401
4402ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
4403TYPE(timedelta),INTENT(IN) :: this, that
4404LOGICAL :: res
4405
4406IF (this == that) THEN
4407 res = .true.
4408ELSE IF (this > that) THEN
4409 res = .true.
4410ELSE
4411 res = .false.
4412ENDIF
4413
4414END FUNCTION timedelta_ge
4415
4416
4417elemental FUNCTION timedelta_le(this, that) RESULT(res)
4418TYPE(timedelta),INTENT(IN) :: this, that
4419LOGICAL :: res
4420
4421IF (this == that) THEN
4422 res = .true.
4423ELSE IF (this < that) THEN
4424 res = .true.
4425ELSE
4426 res = .false.
4427ENDIF
4428
4429END FUNCTION timedelta_le
4430
4431
4432ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
4433TYPE(timedelta),INTENT(IN) :: this, that
4434TYPE(timedelta) :: res
4435
4436res%iminuti = this%iminuti + that%iminuti
4437res%month = this%month + that%month
4438
4439END FUNCTION timedelta_add
4440
4441
4442ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
4443TYPE(timedelta),INTENT(IN) :: this, that
4444TYPE(timedelta) :: res
4445
4446res%iminuti = this%iminuti - that%iminuti
4447res%month = this%month - that%month
4448
4449END FUNCTION timedelta_sub
4450
4451
4452ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
4453TYPE(timedelta),INTENT(IN) :: this
4454INTEGER,INTENT(IN) :: n
4455TYPE(timedelta) :: res
4456
4457res%iminuti = this%iminuti*n
4458res%month = this%month*n
4459
4460END FUNCTION timedelta_mult
4461
4462
4463ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
4464INTEGER,INTENT(IN) :: n
4465TYPE(timedelta),INTENT(IN) :: this
4466TYPE(timedelta) :: res
4467
4468res%iminuti = this%iminuti*n
4469res%month = this%month*n
4470
4471END FUNCTION timedelta_tlum
4472
4473
4474ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
4475TYPE(timedelta),INTENT(IN) :: this
4476INTEGER,INTENT(IN) :: n
4477TYPE(timedelta) :: res
4478
4479res%iminuti = this%iminuti/n
4480res%month = this%month/n
4481
4482END FUNCTION timedelta_divint
4483
4484
4485ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
4486TYPE(timedelta),INTENT(IN) :: this, that
4487INTEGER :: res
4488
4489res = int(this%iminuti/that%iminuti)
4490
4491END FUNCTION timedelta_divtd
4492
4493
4494elemental FUNCTION timedelta_mod(this, that) RESULT(res)
4495TYPE(timedelta),INTENT(IN) :: this, that
4496TYPE(timedelta) :: res
4497
4498res%iminuti = mod(this%iminuti, that%iminuti)
4499res%month = 0
4500
4501END FUNCTION timedelta_mod
4502
4503
4504ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
4505TYPE(datetime),INTENT(IN) :: this
4506TYPE(timedelta),INTENT(IN) :: that
4507TYPE(timedelta) :: res
4508
4509IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
4510 res = timedelta_0
4511ELSE
4512 res%iminuti = mod(this%iminuti, that%iminuti)
4513 res%month = 0
4514ENDIF
4515
4516END FUNCTION datetime_timedelta_mod
4517
4518
4519ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
4520TYPE(timedelta),INTENT(IN) :: this
4521TYPE(timedelta) :: res
4522
4523res%iminuti = abs(this%iminuti)
4524res%month = abs(this%month)
4525
4526END FUNCTION timedelta_abs
4527
4528
4533SUBROUTINE timedelta_read_unit(this, unit)
4534TYPE(timedelta),INTENT(out) :: this
4535INTEGER, INTENT(in) :: unit
4536
4537CALL timedelta_vect_read_unit((/this/), unit)
4538
4539END SUBROUTINE timedelta_read_unit
4540
4541
4546SUBROUTINE timedelta_vect_read_unit(this, unit)
4547TYPE(timedelta) :: this(:)
4548INTEGER, INTENT(in) :: unit
4549
4550CHARACTER(len=40) :: form
4551CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4552INTEGER :: i
4553
4554ALLOCATE(dateiso(SIZE(this)))
4555INQUIRE(unit, form=form)
4556IF (form == 'FORMATTED') THEN
4557 READ(unit,'(3(A23,1X))')dateiso
4558ELSE
4559 READ(unit)dateiso
4560ENDIF
4561DO i = 1, SIZE(dateiso)
4563ENDDO
4564DEALLOCATE(dateiso)
4565
4566END SUBROUTINE timedelta_vect_read_unit
4567
4568
4573SUBROUTINE timedelta_write_unit(this, unit)
4574TYPE(timedelta),INTENT(in) :: this
4575INTEGER, INTENT(in) :: unit
4576
4577CALL timedelta_vect_write_unit((/this/), unit)
4578
4579END SUBROUTINE timedelta_write_unit
4580
4581
4586SUBROUTINE timedelta_vect_write_unit(this, unit)
4587TYPE(timedelta),INTENT(in) :: this(:)
4588INTEGER, INTENT(in) :: unit
4589
4590CHARACTER(len=40) :: form
4591CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4592INTEGER :: i
4593
4594ALLOCATE(dateiso(SIZE(this)))
4595DO i = 1, SIZE(dateiso)
4597ENDDO
4598INQUIRE(unit, form=form)
4599IF (form == 'FORMATTED') THEN
4600 WRITE(unit,'(3(A23,1X))')dateiso
4601ELSE
4602 WRITE(unit)dateiso
4603ENDIF
4604DEALLOCATE(dateiso)
4605
4606END SUBROUTINE timedelta_vect_write_unit
4607
4608
4609ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4610TYPE(timedelta),INTENT(in) :: this
4611LOGICAL :: res
4612
4613res = .not. this == timedelta_miss
4614
4615end FUNCTION c_e_timedelta
4616
4617
4618elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4619
4620!!omstart JELADATA5
4621! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4622! 1 IMINUTI)
4623!
4624! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4625!
4626! variabili integer*4
4627! IN:
4628! IDAY,IMONTH,IYEAR, I*4
4629! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4630!
4631! OUT:
4632! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4633!!OMEND
4634
4635INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4636INTEGER,intent(out) :: iminuti
4637
4638iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4639
4640END SUBROUTINE jeladata5
4641
4642
4643elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4644INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4645INTEGER(KIND=int_ll),intent(out) :: imillisec
4646
4647imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4648 + imsec
4649
4650END SUBROUTINE jeladata5_1
4651
4652
4653
4654elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4655
4656!!omstart JELADATA6
4657! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4658! 1 IMINUTI)
4659!
4660! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4661! 1/1/1
4662!
4663! variabili integer*4
4664! IN:
4665! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4666!
4667! OUT:
4668! IDAY,IMONTH,IYEAR, I*4
4669! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4670!!OMEND
4671
4672
4673INTEGER,intent(in) :: iminuti
4674INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4675
4676INTEGER ::igiorno
4677
4678imin = mod(iminuti,60)
4679ihour = mod(iminuti,1440)/60
4680igiorno = iminuti/1440
4682CALL ndyin(igiorno,iday,imonth,iyear)
4683
4684END SUBROUTINE jeladata6
4685
4686
4687elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4688INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4689INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4690
4691INTEGER :: igiorno
4692
4694!imin = MOD(imillisec/60000_int_ll, 60)
4695!ihour = MOD(imillisec/3600000_int_ll, 24)
4696imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4697ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4698igiorno = int(imillisec/86400000_int_ll)
4699!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4700CALL ndyin(igiorno,iday,imonth,iyear)
4701
4702END SUBROUTINE jeladata6_1
4703
4704
4705elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4706
4707!!OMSTART NDYIN
4708! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4709! restituisce la data fornendo in input il numero di
4710! giorni dal 1/1/1
4711!
4712!!omend
4713
4714INTEGER,intent(in) :: ndays
4715INTEGER,intent(out) :: igg, imm, iaa
4716integer :: n,lndays
4717
4718lndays=ndays
4719
4720n = lndays/d400
4721lndays = lndays - n*d400
4722iaa = year0 + n*400
4723n = min(lndays/d100, 3)
4724lndays = lndays - n*d100
4725iaa = iaa + n*100
4726n = lndays/d4
4727lndays = lndays - n*d4
4728iaa = iaa + n*4
4729n = min(lndays/d1, 3)
4730lndays = lndays - n*d1
4731iaa = iaa + n
4732n = bisextilis(iaa)
4733DO imm = 1, 12
4734 IF (lndays < ianno(imm+1,n)) EXIT
4735ENDDO
4736igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4737
4738END SUBROUTINE ndyin
4739
4740
4741integer elemental FUNCTION ndays(igg,imm,iaa)
4742
4743!!OMSTART NDAYS
4744! FUNCTION NDAYS(IGG,IMM,IAA)
4745! restituisce il numero di giorni dal 1/1/1
4746! fornendo in input la data
4747!
4748!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4749! nota bene E' SICURO !!!
4750! un anno e' bisestile se divisibile per 4
4751! un anno rimane bisestile se divisibile per 400
4752! un anno NON e' bisestile se divisibile per 100
4753!
4754!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4755!
4756!!omend
4757
4758INTEGER, intent(in) :: igg, imm, iaa
4759
4760INTEGER :: lmonth, lyear
4761
4762! Limito il mese a [1-12] e correggo l'anno coerentemente
4763lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4764lyear = iaa + (imm - lmonth)/12
4765ndays = igg+ianno(lmonth, bisextilis(lyear))
4766ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4767 (lyear-year0)/400
4768
4769END FUNCTION ndays
4770
4771
4772elemental FUNCTION bisextilis(annum)
4773INTEGER,INTENT(in) :: annum
4774INTEGER :: bisextilis
4775
4777 bisextilis = 2
4778ELSE
4779 bisextilis = 1
4780ENDIF
4781END FUNCTION bisextilis
4782
4783
4784ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4785TYPE(cyclicdatetime),INTENT(IN) :: this, that
4786LOGICAL :: res
4787
4788res = .true.
4789if (this%minute /= that%minute) res=.false.
4790if (this%hour /= that%hour) res=.false.
4791if (this%day /= that%day) res=.false.
4792if (this%month /= that%month) res=.false.
4793if (this%tendaysp /= that%tendaysp) res=.false.
4794
4795END FUNCTION cyclicdatetime_eq
4796
4797
4798ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4799TYPE(cyclicdatetime),INTENT(IN) :: this
4800TYPE(datetime),INTENT(IN) :: that
4801LOGICAL :: res
4802
4803integer :: minute,hour,day,month
4804
4806
4807res = .true.
4813 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4814end if
4815
4816END FUNCTION cyclicdatetime_datetime_eq
4817
4818
4819ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4820TYPE(datetime),INTENT(IN) :: this
4821TYPE(cyclicdatetime),INTENT(IN) :: that
4822LOGICAL :: res
4823
4824integer :: minute,hour,day,month
4825
4827
4828res = .true.
4833
4835 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4836end if
4837
4838
4839END FUNCTION datetime_cyclicdatetime_eq
4840
4841ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4842TYPE(cyclicdatetime),INTENT(in) :: this
4843LOGICAL :: res
4844
4845res = .not. this == cyclicdatetime_miss
4846
4847end FUNCTION c_e_cyclicdatetime
4848
4849
4852FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4853INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4854INTEGER,INTENT(IN),OPTIONAL :: month
4855INTEGER,INTENT(IN),OPTIONAL :: day
4856INTEGER,INTENT(IN),OPTIONAL :: hour
4857INTEGER,INTENT(IN),OPTIONAL :: minute
4858CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4859
4860integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4861
4862
4863TYPE(cyclicdatetime) :: this
4864
4865if (present(chardate)) then
4866
4867 ltendaysp=imiss
4868 lmonth=imiss
4869 lday=imiss
4870 lhour=imiss
4871 lminute=imiss
4872
4874 ! TMMGGhhmm
4875 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4876 !print*,chardate(1:1),ios,ltendaysp
4877 if (ios /= 0)ltendaysp=imiss
4878
4879 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4880 !print*,chardate(2:3),ios,lmonth
4881 if (ios /= 0)lmonth=imiss
4882
4883 read(chardate(4:5),'(i2)',iostat=ios)lday
4884 !print*,chardate(4:5),ios,lday
4885 if (ios /= 0)lday=imiss
4886
4887 read(chardate(6:7),'(i2)',iostat=ios)lhour
4888 !print*,chardate(6:7),ios,lhour
4889 if (ios /= 0)lhour=imiss
4890
4891 read(chardate(8:9),'(i2)',iostat=ios)lminute
4892 !print*,chardate(8:9),ios,lminute
4893 if (ios /= 0)lminute=imiss
4894 end if
4895
4896 this%tendaysp=ltendaysp
4897 this%month=lmonth
4898 this%day=lday
4899 this%hour=lhour
4900 this%minute=lminute
4901else
4902 this%tendaysp=optio_l(tendaysp)
4903 this%month=optio_l(month)
4904 this%day=optio_l(day)
4905 this%hour=optio_l(hour)
4906 this%minute=optio_l(minute)
4907end if
4908
4909END FUNCTION cyclicdatetime_new
4910
4913elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4914TYPE(cyclicdatetime),INTENT(IN) :: this
4915
4916CHARACTER(len=80) :: char
4917
4920
4921END FUNCTION cyclicdatetime_to_char
4922
4923
4936FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4937TYPE(cyclicdatetime),INTENT(IN) :: this
4938
4939TYPE(datetime) :: dtc
4940
4941integer :: year,month,day,hour
4942
4943dtc = datetime_miss
4944
4945! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4947 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4948 return
4949end if
4950
4951! minute present -> not good for conventional datetime
4953! day, month and tendaysp present -> no good
4955
4957 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4959 day=(this%tendaysp-1)*10+1
4960 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4962 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4964 ! only day present -> no good
4965 return
4966end if
4967
4970 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4971end if
4972
4973
4974END FUNCTION cyclicdatetime_to_conventional
4975
4976
4977
4978FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4979TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4980
4981CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4982
4983char=cyclicdatetime_to_char(in)
4984
4985END FUNCTION trim_cyclicdatetime_to_char
4986
4987
4988
4989SUBROUTINE display_cyclicdatetime(this)
4990TYPE(cyclicdatetime),INTENT(in) :: this
4991
4993
4994end subroutine display_cyclicdatetime
4995
4996
4997#include "array_utilities_inc.F90"
4998
5000
Quick method to append an element to the array. Definition datetime_class.F90:616 Restituiscono il valore dell'oggetto nella forma desiderata. Definition datetime_class.F90:322 Costruttori per le classi datetime e timedelta. Definition datetime_class.F90:311 Method for inserting elements of the array at a desired position. Definition datetime_class.F90:607 Method for packing the array object reducing at a minimum the memory occupation, without destroying i... Definition datetime_class.F90:639 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition datetime_class.F90:478 Method for removing elements of the array at a desired position. Definition datetime_class.F90:622 Functions that return a trimmed CHARACTER representation of the input variable. Definition datetime_class.F90:349 Restituiscono il valore dell'oggetto in forma di stringa stampabile. Definition datetime_class.F90:327 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition datetime_class.F90:485 Definition of constants to be used for declaring variables of a desired type. Definition kinds.F90:245 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:255 Class for expressing an absolute time value. Definition datetime_class.F90:233 Class for expressing a relative time interval. Definition datetime_class.F90:245 |