libsim Versione 7.2.0
|
◆ index_sorted_datetime()
Cerca l'indice del primo o ultimo elemento di vect uguale a search. Definizione alla linea 3040 del file datetime_class.F90. 3042! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
3043! authors:
3044! Davide Cesari <dcesari@arpa.emr.it>
3045! Paolo Patruno <ppatruno@arpa.emr.it>
3046
3047! This program is free software; you can redistribute it and/or
3048! modify it under the terms of the GNU General Public License as
3049! published by the Free Software Foundation; either version 2 of
3050! the License, or (at your option) any later version.
3051
3052! This program is distributed in the hope that it will be useful,
3053! but WITHOUT ANY WARRANTY; without even the implied warranty of
3054! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3055! GNU General Public License for more details.
3056
3057! You should have received a copy of the GNU General Public License
3058! along with this program. If not, see <http://www.gnu.org/licenses/>.
3059#include "config.h"
3060
3081IMPLICIT NONE
3082
3083INTEGER, PARAMETER :: dateint=selected_int_kind(13)
3084
3087 PRIVATE
3088 INTEGER(KIND=int_ll) :: iminuti
3090
3099 PRIVATE
3100 INTEGER(KIND=int_ll) :: iminuti
3101 INTEGER :: month
3103
3104
3109 PRIVATE
3110 INTEGER :: minute
3111 INTEGER :: hour
3112 INTEGER :: day
3113 INTEGER :: tendaysp
3114 INTEGER :: month
3116
3117
3125INTEGER, PARAMETER :: datetime_utc=1
3127INTEGER, PARAMETER :: datetime_local=2
3137TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
3138
3139
3140INTEGER(kind=dateint), PARAMETER :: &
3141 sec_in_day=86400, &
3142 sec_in_hour=3600, &
3143 sec_in_min=60, &
3144 min_in_day=1440, &
3145 min_in_hour=60, &
3146 hour_in_day=24
3147
3148INTEGER,PARAMETER :: &
3149 year0=1, & ! anno di origine per iminuti
3150 d1=365, & ! giorni/1 anno nel calendario gregoriano
3151 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
3152 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
3153 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
3154 ianno(13,2)=reshape((/ &
3155 0,31,59,90,120,151,181,212,243,273,304,334,365, &
3156 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
3157
3158INTEGER(KIND=int_ll),PARAMETER :: &
3159 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
3160
3165 MODULE PROCEDURE datetime_init, timedelta_init
3166END INTERFACE
3167
3171 MODULE PROCEDURE datetime_delete, timedelta_delete
3172END INTERFACE
3173
3176 MODULE PROCEDURE datetime_getval, timedelta_getval
3177END INTERFACE
3178
3181 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
3182END INTERFACE
3183
3184
3203 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
3204END INTERFACE
3205
3211INTERFACE OPERATOR (==)
3212 MODULE PROCEDURE datetime_eq, timedelta_eq, &
3213 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
3214END INTERFACE
3215
3221INTERFACE OPERATOR (/=)
3222 MODULE PROCEDURE datetime_ne, timedelta_ne
3223END INTERFACE
3224
3232INTERFACE OPERATOR (>)
3233 MODULE PROCEDURE datetime_gt, timedelta_gt
3234END INTERFACE
3235
3243INTERFACE OPERATOR (<)
3244 MODULE PROCEDURE datetime_lt, timedelta_lt
3245END INTERFACE
3246
3254INTERFACE OPERATOR (>=)
3255 MODULE PROCEDURE datetime_ge, timedelta_ge
3256END INTERFACE
3257
3265INTERFACE OPERATOR (<=)
3266 MODULE PROCEDURE datetime_le, timedelta_le
3267END INTERFACE
3268
3275INTERFACE OPERATOR (+)
3276 MODULE PROCEDURE datetime_add, timedelta_add
3277END INTERFACE
3278
3286INTERFACE OPERATOR (-)
3287 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
3288END INTERFACE
3289
3295INTERFACE OPERATOR (*)
3296 MODULE PROCEDURE timedelta_mult, timedelta_tlum
3297END INTERFACE
3298
3305INTERFACE OPERATOR (/)
3306 MODULE PROCEDURE timedelta_divint, timedelta_divtd
3307END INTERFACE
3308
3320 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3321END INTERFACE
3322
3326 MODULE PROCEDURE timedelta_abs
3327END INTERFACE
3328
3332 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3333 timedelta_read_unit, timedelta_vect_read_unit
3334END INTERFACE
3335
3339 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3340 timedelta_write_unit, timedelta_vect_write_unit
3341END INTERFACE
3342
3345 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3346END INTERFACE
3347
3350 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
3351END INTERFACE
3352
3353#undef VOL7D_POLY_TYPE
3354#undef VOL7D_POLY_TYPES
3355#undef ENABLE_SORT
3356#define VOL7D_POLY_TYPE TYPE(datetime)
3357#define VOL7D_POLY_TYPES _datetime
3358#define ENABLE_SORT
3359#include "array_utilities_pre.F90"
3360
3361
3362#define ARRAYOF_ORIGTYPE TYPE(datetime)
3363#define ARRAYOF_TYPE arrayof_datetime
3364#define ARRAYOF_ORIGEQ 1
3365#include "arrayof_pre.F90"
3366! from arrayof
3367
3368PRIVATE
3369
3371 datetime_min, datetime_max, &
3374 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3375 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3377 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3378 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3380 count_distinct, pack_distinct, &
3381 count_distinct_sorted, pack_distinct_sorted, &
3382 count_and_pack_distinct, &
3384 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
3386PUBLIC insert_unique, append_unique
3387PUBLIC cyclicdatetime_to_conventional
3388
3389CONTAINS
3390
3391
3392! ==============
3393! == datetime ==
3394! ==============
3395
3402ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3403 unixtime, isodate, simpledate) RESULT(this)
3404INTEGER,INTENT(IN),OPTIONAL :: year
3405INTEGER,INTENT(IN),OPTIONAL :: month
3406INTEGER,INTENT(IN),OPTIONAL :: day
3407INTEGER,INTENT(IN),OPTIONAL :: hour
3408INTEGER,INTENT(IN),OPTIONAL :: minute
3409INTEGER,INTENT(IN),OPTIONAL :: msec
3410INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3411CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3412CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3413
3414TYPE(datetime) :: this
3415INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3416CHARACTER(len=23) :: datebuf
3417
3418IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3419 lyear = year
3420 IF (PRESENT(month)) THEN
3421 lmonth = month
3422 ELSE
3423 lmonth = 1
3424 ENDIF
3425 IF (PRESENT(day)) THEN
3426 lday = day
3427 ELSE
3428 lday = 1
3429 ENDIF
3430 IF (PRESENT(hour)) THEN
3431 lhour = hour
3432 ELSE
3433 lhour = 0
3434 ENDIF
3435 IF (PRESENT(minute)) THEN
3436 lminute = minute
3437 ELSE
3438 lminute = 0
3439 ENDIF
3440 IF (PRESENT(msec)) THEN
3441 lmsec = msec
3442 ELSE
3443 lmsec = 0
3444 ENDIF
3445
3448 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3449 else
3450 this=datetime_miss
3451 end if
3452
3453ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3455 this%iminuti = (unixtime + unsec)*1000
3456 else
3457 this=datetime_miss
3458 end if
3459
3460ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3461
3463 datebuf(1:23) = '0001-01-01 00:00:00.000'
3464 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3465 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3466 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3467 lmsec = lmsec + lsec*1000
3468 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3469 RETURN
3470
3471100 CONTINUE ! condizione di errore in isodate
3473 RETURN
3474 ELSE
3475 this = datetime_miss
3476 ENDIF
3477
3478ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3480 datebuf(1:17) = '00010101000000000'
3481 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3482 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3483 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3484 lmsec = lmsec + lsec*1000
3485 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3486 RETURN
3487
3488120 CONTINUE ! condizione di errore in simpledate
3490 RETURN
3491 ELSE
3492 this = datetime_miss
3493 ENDIF
3494
3495ELSE
3496 this = datetime_miss
3497ENDIF
3498
3499END FUNCTION datetime_new
3500
3501
3503FUNCTION datetime_new_now(now) RESULT(this)
3504INTEGER,INTENT(IN) :: now
3505TYPE(datetime) :: this
3506
3507INTEGER :: dt(8)
3508
3510 CALL date_and_time(values=dt)
3511 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3513 msec=dt(7)*1000+dt(8))
3514ELSE
3515 this = datetime_miss
3516ENDIF
3517
3518END FUNCTION datetime_new_now
3519
3520
3527SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3528 unixtime, isodate, simpledate, now)
3529TYPE(datetime),INTENT(INOUT) :: this
3530INTEGER,INTENT(IN),OPTIONAL :: year
3531INTEGER,INTENT(IN),OPTIONAL :: month
3532INTEGER,INTENT(IN),OPTIONAL :: day
3533INTEGER,INTENT(IN),OPTIONAL :: hour
3534INTEGER,INTENT(IN),OPTIONAL :: minute
3535INTEGER,INTENT(IN),OPTIONAL :: msec
3536INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3537CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3538CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3539INTEGER,INTENT(IN),OPTIONAL :: now
3540
3541IF (PRESENT(now)) THEN
3542 this = datetime_new_now(now)
3543ELSE
3544 this = datetime_new(year, month, day, hour, minute, msec, &
3545 unixtime, isodate, simpledate)
3546ENDIF
3547
3548END SUBROUTINE datetime_init
3549
3550
3551ELEMENTAL SUBROUTINE datetime_delete(this)
3552TYPE(datetime),INTENT(INOUT) :: this
3553
3554this%iminuti = illmiss
3555
3556END SUBROUTINE datetime_delete
3557
3558
3563PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3564 unixtime, isodate, simpledate, oraclesimdate)
3565TYPE(datetime),INTENT(IN) :: this
3566INTEGER,INTENT(OUT),OPTIONAL :: year
3567INTEGER,INTENT(OUT),OPTIONAL :: month
3568INTEGER,INTENT(OUT),OPTIONAL :: day
3569INTEGER,INTENT(OUT),OPTIONAL :: hour
3570INTEGER,INTENT(OUT),OPTIONAL :: minute
3571INTEGER,INTENT(OUT),OPTIONAL :: msec
3572INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3573CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3574CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3575CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3576
3577INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3578CHARACTER(len=23) :: datebuf
3579
3580IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3581 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3582 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3583
3584 IF (this == datetime_miss) THEN
3585
3586 IF (PRESENT(msec)) THEN
3587 msec = imiss
3588 ENDIF
3589 IF (PRESENT(minute)) THEN
3590 minute = imiss
3591 ENDIF
3592 IF (PRESENT(hour)) THEN
3593 hour = imiss
3594 ENDIF
3595 IF (PRESENT(day)) THEN
3596 day = imiss
3597 ENDIF
3598 IF (PRESENT(month)) THEN
3599 month = imiss
3600 ENDIF
3601 IF (PRESENT(year)) THEN
3602 year = imiss
3603 ENDIF
3604 IF (PRESENT(isodate)) THEN
3605 isodate = cmiss
3606 ENDIF
3607 IF (PRESENT(simpledate)) THEN
3608 simpledate = cmiss
3609 ENDIF
3610 IF (PRESENT(oraclesimdate)) THEN
3611!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3612!!$ 'obsoleto, usare piuttosto simpledate')
3613 oraclesimdate=cmiss
3614 ENDIF
3615 IF (PRESENT(unixtime)) THEN
3616 unixtime = illmiss
3617 ENDIF
3618
3619 ELSE
3620
3621 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3622 IF (PRESENT(msec)) THEN
3623 msec = lmsec
3624 ENDIF
3625 IF (PRESENT(minute)) THEN
3626 minute = lminute
3627 ENDIF
3628 IF (PRESENT(hour)) THEN
3629 hour = lhour
3630 ENDIF
3631 IF (PRESENT(day)) THEN
3632 day = lday
3633 ENDIF
3634 IF (PRESENT(month)) THEN
3635 month = lmonth
3636 ENDIF
3637 IF (PRESENT(year)) THEN
3638 year = lyear
3639 ENDIF
3640 IF (PRESENT(isodate)) THEN
3641 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3642 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3644 isodate = datebuf(1:min(len(isodate),23))
3645 ENDIF
3646 IF (PRESENT(simpledate)) THEN
3647 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3648 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3649 simpledate = datebuf(1:min(len(simpledate),17))
3650 ENDIF
3651 IF (PRESENT(oraclesimdate)) THEN
3652!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3653!!$ 'obsoleto, usare piuttosto simpledate')
3654 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3655 ENDIF
3656 IF (PRESENT(unixtime)) THEN
3657 unixtime = this%iminuti/1000_int_ll-unsec
3658 ENDIF
3659
3660 ENDIF
3661ENDIF
3662
3663END SUBROUTINE datetime_getval
3664
3665
3668elemental FUNCTION datetime_to_char(this) RESULT(char)
3669TYPE(datetime),INTENT(IN) :: this
3670
3671CHARACTER(len=23) :: char
3672
3674
3675END FUNCTION datetime_to_char
3676
3677
3678FUNCTION trim_datetime_to_char(in) RESULT(char)
3679TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3680
3681CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3682
3683char=datetime_to_char(in)
3684
3685END FUNCTION trim_datetime_to_char
3686
3687
3688
3689SUBROUTINE display_datetime(this)
3690TYPE(datetime),INTENT(in) :: this
3691
3693
3694end subroutine display_datetime
3695
3696
3697
3698SUBROUTINE display_timedelta(this)
3699TYPE(timedelta),INTENT(in) :: this
3700
3702
3703end subroutine display_timedelta
3704
3705
3706
3707ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3708TYPE(datetime),INTENT(in) :: this
3709LOGICAL :: res
3710
3711res = .not. this == datetime_miss
3712
3713end FUNCTION c_e_datetime
3714
3715
3716ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3717TYPE(datetime),INTENT(IN) :: this, that
3718LOGICAL :: res
3719
3720res = this%iminuti == that%iminuti
3721
3722END FUNCTION datetime_eq
3723
3724
3725ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3726TYPE(datetime),INTENT(IN) :: this, that
3727LOGICAL :: res
3728
3729res = .NOT.(this == that)
3730
3731END FUNCTION datetime_ne
3732
3733
3734ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3735TYPE(datetime),INTENT(IN) :: this, that
3736LOGICAL :: res
3737
3738res = this%iminuti > that%iminuti
3739
3740END FUNCTION datetime_gt
3741
3742
3743ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3744TYPE(datetime),INTENT(IN) :: this, that
3745LOGICAL :: res
3746
3747res = this%iminuti < that%iminuti
3748
3749END FUNCTION datetime_lt
3750
3751
3752ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3753TYPE(datetime),INTENT(IN) :: this, that
3754LOGICAL :: res
3755
3756IF (this == that) THEN
3757 res = .true.
3758ELSE IF (this > that) THEN
3759 res = .true.
3760ELSE
3761 res = .false.
3762ENDIF
3763
3764END FUNCTION datetime_ge
3765
3766
3767ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3768TYPE(datetime),INTENT(IN) :: this, that
3769LOGICAL :: res
3770
3771IF (this == that) THEN
3772 res = .true.
3773ELSE IF (this < that) THEN
3774 res = .true.
3775ELSE
3776 res = .false.
3777ENDIF
3778
3779END FUNCTION datetime_le
3780
3781
3782FUNCTION datetime_add(this, that) RESULT(res)
3783TYPE(datetime),INTENT(IN) :: this
3784TYPE(timedelta),INTENT(IN) :: that
3785TYPE(datetime) :: res
3786
3787INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3788
3789IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3790 res = datetime_miss
3791ELSE
3792 res%iminuti = this%iminuti + that%iminuti
3793 IF (that%month /= 0) THEN
3795 minute=lminute, msec=lmsec)
3797 hour=lhour, minute=lminute, msec=lmsec)
3798 ENDIF
3799ENDIF
3800
3801END FUNCTION datetime_add
3802
3803
3804ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3805TYPE(datetime),INTENT(IN) :: this, that
3806TYPE(timedelta) :: res
3807
3808IF (this == datetime_miss .OR. that == datetime_miss) THEN
3809 res = timedelta_miss
3810ELSE
3811 res%iminuti = this%iminuti - that%iminuti
3812 res%month = 0
3813ENDIF
3814
3815END FUNCTION datetime_subdt
3816
3817
3818FUNCTION datetime_subtd(this, that) RESULT(res)
3819TYPE(datetime),INTENT(IN) :: this
3820TYPE(timedelta),INTENT(IN) :: that
3821TYPE(datetime) :: res
3822
3823INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3824
3825IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3826 res = datetime_miss
3827ELSE
3828 res%iminuti = this%iminuti - that%iminuti
3829 IF (that%month /= 0) THEN
3831 minute=lminute, msec=lmsec)
3833 hour=lhour, minute=lminute, msec=lmsec)
3834 ENDIF
3835ENDIF
3836
3837END FUNCTION datetime_subtd
3838
3839
3844SUBROUTINE datetime_read_unit(this, unit)
3845TYPE(datetime),INTENT(out) :: this
3846INTEGER, INTENT(in) :: unit
3847CALL datetime_vect_read_unit((/this/), unit)
3848
3849END SUBROUTINE datetime_read_unit
3850
3851
3856SUBROUTINE datetime_vect_read_unit(this, unit)
3857TYPE(datetime) :: this(:)
3858INTEGER, INTENT(in) :: unit
3859
3860CHARACTER(len=40) :: form
3861CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3862INTEGER :: i
3863
3864ALLOCATE(dateiso(SIZE(this)))
3865INQUIRE(unit, form=form)
3866IF (form == 'FORMATTED') THEN
3867 READ(unit,'(A23,1X)')dateiso
3868ELSE
3869 READ(unit)dateiso
3870ENDIF
3871DO i = 1, SIZE(dateiso)
3873ENDDO
3874DEALLOCATE(dateiso)
3875
3876END SUBROUTINE datetime_vect_read_unit
3877
3878
3883SUBROUTINE datetime_write_unit(this, unit)
3884TYPE(datetime),INTENT(in) :: this
3885INTEGER, INTENT(in) :: unit
3886
3887CALL datetime_vect_write_unit((/this/), unit)
3888
3889END SUBROUTINE datetime_write_unit
3890
3891
3896SUBROUTINE datetime_vect_write_unit(this, unit)
3897TYPE(datetime),INTENT(in) :: this(:)
3898INTEGER, INTENT(in) :: unit
3899
3900CHARACTER(len=40) :: form
3901CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3902INTEGER :: i
3903
3904ALLOCATE(dateiso(SIZE(this)))
3905DO i = 1, SIZE(dateiso)
3907ENDDO
3908INQUIRE(unit, form=form)
3909IF (form == 'FORMATTED') THEN
3910 WRITE(unit,'(A23,1X)')dateiso
3911ELSE
3912 WRITE(unit)dateiso
3913ENDIF
3914DEALLOCATE(dateiso)
3915
3916END SUBROUTINE datetime_vect_write_unit
3917
3918
3919#include "arrayof_post.F90"
3920
3921
3922! ===============
3923! == timedelta ==
3924! ===============
3931FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3932 isodate, simpledate, oraclesimdate) RESULT (this)
3933INTEGER,INTENT(IN),OPTIONAL :: year
3934INTEGER,INTENT(IN),OPTIONAL :: month
3935INTEGER,INTENT(IN),OPTIONAL :: day
3936INTEGER,INTENT(IN),OPTIONAL :: hour
3937INTEGER,INTENT(IN),OPTIONAL :: minute
3938INTEGER,INTENT(IN),OPTIONAL :: sec
3939INTEGER,INTENT(IN),OPTIONAL :: msec
3940CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3941CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3942CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3943
3944TYPE(timedelta) :: this
3945
3946CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3947 isodate, simpledate, oraclesimdate)
3948
3949END FUNCTION timedelta_new
3950
3951
3956SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3957 isodate, simpledate, oraclesimdate)
3958TYPE(timedelta),INTENT(INOUT) :: this
3959INTEGER,INTENT(IN),OPTIONAL :: year
3960INTEGER,INTENT(IN),OPTIONAL :: month
3961INTEGER,INTENT(IN),OPTIONAL :: day
3962INTEGER,INTENT(IN),OPTIONAL :: hour
3963INTEGER,INTENT(IN),OPTIONAL :: minute
3964INTEGER,INTENT(IN),OPTIONAL :: sec
3965INTEGER,INTENT(IN),OPTIONAL :: msec
3966CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3967CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3968CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3969
3970INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3971CHARACTER(len=23) :: datebuf
3972
3973this%month = 0
3974
3975IF (PRESENT(isodate)) THEN
3976 datebuf(1:23) = '0000000000 00:00:00.000'
3977 l = len_trim(isodate)
3978! IF (l > 0) THEN
3980 IF (n > 0) THEN
3981 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3982 datebuf(12-n:12-n+l-1) = isodate(:l)
3983 ELSE
3984 datebuf(1:l) = isodate(1:l)
3985 ENDIF
3986! ENDIF
3987
3988! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3989 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3990 h, m, s, ms
3991 this%month = lmonth + 12*lyear
3992 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3993 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3994 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3995 RETURN
3996
3997200 CONTINUE ! condizione di errore in isodate
3999 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
4000 CALL raise_error()
4001
4002ELSE IF (PRESENT(simpledate)) THEN
4003 datebuf(1:17) = '00000000000000000'
4004 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
4005 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
4006 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4007 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4008 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4009
4010220 CONTINUE ! condizione di errore in simpledate
4012 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
4013 CALL raise_error()
4014 RETURN
4015
4016ELSE IF (PRESENT(oraclesimdate)) THEN
4017 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
4018 'obsoleto, usare piuttosto simpledate')
4019 READ(oraclesimdate, '(I8,2I2)')d, h, m
4020 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4021 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
4022
4023ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
4024 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
4025 .and. .not. present(msec) .and. .not. present(isodate) &
4026 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
4027
4028 this=timedelta_miss
4029
4030ELSE
4031 this%iminuti = 0
4032 IF (PRESENT(year)) THEN
4034 this%month = this%month + year*12
4035 else
4036 this=timedelta_miss
4037 return
4038 end if
4039 ENDIF
4040 IF (PRESENT(month)) THEN
4042 this%month = this%month + month
4043 else
4044 this=timedelta_miss
4045 return
4046 end if
4047 ENDIF
4048 IF (PRESENT(day)) THEN
4050 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
4051 else
4052 this=timedelta_miss
4053 return
4054 end if
4055 ENDIF
4056 IF (PRESENT(hour)) THEN
4058 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
4059 else
4060 this=timedelta_miss
4061 return
4062 end if
4063 ENDIF
4064 IF (PRESENT(minute)) THEN
4066 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
4067 else
4068 this=timedelta_miss
4069 return
4070 end if
4071 ENDIF
4072 IF (PRESENT(sec)) THEN
4074 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
4075 else
4076 this=timedelta_miss
4077 return
4078 end if
4079 ENDIF
4080 IF (PRESENT(msec)) THEN
4082 this%iminuti = this%iminuti + msec
4083 else
4084 this=timedelta_miss
4085 return
4086 end if
4087 ENDIF
4088ENDIF
4089
4090
4091
4092
4093END SUBROUTINE timedelta_init
4094
4095
4096SUBROUTINE timedelta_delete(this)
4097TYPE(timedelta),INTENT(INOUT) :: this
4098
4099this%iminuti = imiss
4100this%month = 0
4101
4102END SUBROUTINE timedelta_delete
4103
4104
4109PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
4110 day, hour, minute, sec, msec, &
4111 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
4112TYPE(timedelta),INTENT(IN) :: this
4113INTEGER,INTENT(OUT),OPTIONAL :: year
4114INTEGER,INTENT(OUT),OPTIONAL :: month
4115INTEGER,INTENT(OUT),OPTIONAL :: amonth
4116INTEGER,INTENT(OUT),OPTIONAL :: day
4117INTEGER,INTENT(OUT),OPTIONAL :: hour
4118INTEGER,INTENT(OUT),OPTIONAL :: minute
4119INTEGER,INTENT(OUT),OPTIONAL :: sec
4120INTEGER,INTENT(OUT),OPTIONAL :: msec
4121INTEGER,INTENT(OUT),OPTIONAL :: ahour
4122INTEGER,INTENT(OUT),OPTIONAL :: aminute
4123INTEGER,INTENT(OUT),OPTIONAL :: asec
4124INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
4125CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
4126CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
4127CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
4128
4129CHARACTER(len=23) :: datebuf
4130
4131IF (PRESENT(amsec)) THEN
4132 amsec = this%iminuti
4133ENDIF
4134IF (PRESENT(asec)) THEN
4135 asec = int(this%iminuti/1000_int_ll)
4136ENDIF
4137IF (PRESENT(aminute)) THEN
4138 aminute = int(this%iminuti/60000_int_ll)
4139ENDIF
4140IF (PRESENT(ahour)) THEN
4141 ahour = int(this%iminuti/3600000_int_ll)
4142ENDIF
4143IF (PRESENT(msec)) THEN
4144 msec = int(mod(this%iminuti, 1000_int_ll))
4145ENDIF
4146IF (PRESENT(sec)) THEN
4147 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
4148ENDIF
4149IF (PRESENT(minute)) THEN
4150 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
4151ENDIF
4152IF (PRESENT(hour)) THEN
4153 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
4154ENDIF
4155IF (PRESENT(day)) THEN
4156 day = int(this%iminuti/86400000_int_ll)
4157ENDIF
4158IF (PRESENT(amonth)) THEN
4159 amonth = this%month
4160ENDIF
4161IF (PRESENT(month)) THEN
4162 month = mod(this%month-1,12)+1
4163ENDIF
4164IF (PRESENT(year)) THEN
4165 year = this%month/12
4166ENDIF
4167IF (PRESENT(isodate)) THEN ! Non standard, inventato!
4168 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
4172 isodate = datebuf(1:min(len(isodate),23))
4173
4174ENDIF
4175IF (PRESENT(simpledate)) THEN
4176 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
4177 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
4179 mod(this%iminuti, 1000_int_ll)
4180 simpledate = datebuf(1:min(len(simpledate),17))
4181ENDIF
4182IF (PRESENT(oraclesimdate)) THEN
4183!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
4184!!$ 'obsoleto, usare piuttosto simpledate')
4185 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
4187ENDIF
4188
4189END SUBROUTINE timedelta_getval
4190
4191
4194elemental FUNCTION timedelta_to_char(this) RESULT(char)
4195TYPE(timedelta),INTENT(IN) :: this
4196
4197CHARACTER(len=23) :: char
4198
4200
4201END FUNCTION timedelta_to_char
4202
4203
4204FUNCTION trim_timedelta_to_char(in) RESULT(char)
4205TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
4206
4207CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
4208
4209char=timedelta_to_char(in)
4210
4211END FUNCTION trim_timedelta_to_char
4212
4213
4215elemental FUNCTION timedelta_getamsec(this)
4216TYPE(timedelta),INTENT(IN) :: this
4217INTEGER(kind=int_ll) :: timedelta_getamsec
4218
4219timedelta_getamsec = this%iminuti
4220
4221END FUNCTION timedelta_getamsec
4222
4223
4229FUNCTION timedelta_depop(this)
4230TYPE(timedelta),INTENT(IN) :: this
4231TYPE(timedelta) :: timedelta_depop
4232
4233TYPE(datetime) :: tmpdt
4234
4235IF (this%month == 0) THEN
4236 timedelta_depop = this
4237ELSE
4238 tmpdt = datetime_new(1970, 1, 1)
4239 timedelta_depop = (tmpdt + this) - tmpdt
4240ENDIF
4241
4242END FUNCTION timedelta_depop
4243
4244
4245elemental FUNCTION timedelta_eq(this, that) RESULT(res)
4246TYPE(timedelta),INTENT(IN) :: this, that
4247LOGICAL :: res
4248
4249res = (this%iminuti == that%iminuti .AND. this%month == that%month)
4250
4251END FUNCTION timedelta_eq
4252
4253
4254ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
4255TYPE(timedelta),INTENT(IN) :: this, that
4256LOGICAL :: res
4257
4258res = .NOT.(this == that)
4259
4260END FUNCTION timedelta_ne
4261
4262
4263ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
4264TYPE(timedelta),INTENT(IN) :: this, that
4265LOGICAL :: res
4266
4267res = this%iminuti > that%iminuti
4268
4269END FUNCTION timedelta_gt
4270
4271
4272ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
4273TYPE(timedelta),INTENT(IN) :: this, that
4274LOGICAL :: res
4275
4276res = this%iminuti < that%iminuti
4277
4278END FUNCTION timedelta_lt
4279
4280
4281ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
4282TYPE(timedelta),INTENT(IN) :: this, that
4283LOGICAL :: res
4284
4285IF (this == that) THEN
4286 res = .true.
4287ELSE IF (this > that) THEN
4288 res = .true.
4289ELSE
4290 res = .false.
4291ENDIF
4292
4293END FUNCTION timedelta_ge
4294
4295
4296elemental FUNCTION timedelta_le(this, that) RESULT(res)
4297TYPE(timedelta),INTENT(IN) :: this, that
4298LOGICAL :: res
4299
4300IF (this == that) THEN
4301 res = .true.
4302ELSE IF (this < that) THEN
4303 res = .true.
4304ELSE
4305 res = .false.
4306ENDIF
4307
4308END FUNCTION timedelta_le
4309
4310
4311ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
4312TYPE(timedelta),INTENT(IN) :: this, that
4313TYPE(timedelta) :: res
4314
4315res%iminuti = this%iminuti + that%iminuti
4316res%month = this%month + that%month
4317
4318END FUNCTION timedelta_add
4319
4320
4321ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
4322TYPE(timedelta),INTENT(IN) :: this, that
4323TYPE(timedelta) :: res
4324
4325res%iminuti = this%iminuti - that%iminuti
4326res%month = this%month - that%month
4327
4328END FUNCTION timedelta_sub
4329
4330
4331ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
4332TYPE(timedelta),INTENT(IN) :: this
4333INTEGER,INTENT(IN) :: n
4334TYPE(timedelta) :: res
4335
4336res%iminuti = this%iminuti*n
4337res%month = this%month*n
4338
4339END FUNCTION timedelta_mult
4340
4341
4342ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
4343INTEGER,INTENT(IN) :: n
4344TYPE(timedelta),INTENT(IN) :: this
4345TYPE(timedelta) :: res
4346
4347res%iminuti = this%iminuti*n
4348res%month = this%month*n
4349
4350END FUNCTION timedelta_tlum
4351
4352
4353ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
4354TYPE(timedelta),INTENT(IN) :: this
4355INTEGER,INTENT(IN) :: n
4356TYPE(timedelta) :: res
4357
4358res%iminuti = this%iminuti/n
4359res%month = this%month/n
4360
4361END FUNCTION timedelta_divint
4362
4363
4364ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
4365TYPE(timedelta),INTENT(IN) :: this, that
4366INTEGER :: res
4367
4368res = int(this%iminuti/that%iminuti)
4369
4370END FUNCTION timedelta_divtd
4371
4372
4373elemental FUNCTION timedelta_mod(this, that) RESULT(res)
4374TYPE(timedelta),INTENT(IN) :: this, that
4375TYPE(timedelta) :: res
4376
4377res%iminuti = mod(this%iminuti, that%iminuti)
4378res%month = 0
4379
4380END FUNCTION timedelta_mod
4381
4382
4383ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
4384TYPE(datetime),INTENT(IN) :: this
4385TYPE(timedelta),INTENT(IN) :: that
4386TYPE(timedelta) :: res
4387
4388IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
4389 res = timedelta_0
4390ELSE
4391 res%iminuti = mod(this%iminuti, that%iminuti)
4392 res%month = 0
4393ENDIF
4394
4395END FUNCTION datetime_timedelta_mod
4396
4397
4398ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
4399TYPE(timedelta),INTENT(IN) :: this
4400TYPE(timedelta) :: res
4401
4402res%iminuti = abs(this%iminuti)
4403res%month = abs(this%month)
4404
4405END FUNCTION timedelta_abs
4406
4407
4412SUBROUTINE timedelta_read_unit(this, unit)
4413TYPE(timedelta),INTENT(out) :: this
4414INTEGER, INTENT(in) :: unit
4415
4416CALL timedelta_vect_read_unit((/this/), unit)
4417
4418END SUBROUTINE timedelta_read_unit
4419
4420
4425SUBROUTINE timedelta_vect_read_unit(this, unit)
4426TYPE(timedelta) :: this(:)
4427INTEGER, INTENT(in) :: unit
4428
4429CHARACTER(len=40) :: form
4430CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4431INTEGER :: i
4432
4433ALLOCATE(dateiso(SIZE(this)))
4434INQUIRE(unit, form=form)
4435IF (form == 'FORMATTED') THEN
4436 READ(unit,'(3(A23,1X))')dateiso
4437ELSE
4438 READ(unit)dateiso
4439ENDIF
4440DO i = 1, SIZE(dateiso)
4442ENDDO
4443DEALLOCATE(dateiso)
4444
4445END SUBROUTINE timedelta_vect_read_unit
4446
4447
4452SUBROUTINE timedelta_write_unit(this, unit)
4453TYPE(timedelta),INTENT(in) :: this
4454INTEGER, INTENT(in) :: unit
4455
4456CALL timedelta_vect_write_unit((/this/), unit)
4457
4458END SUBROUTINE timedelta_write_unit
4459
4460
4465SUBROUTINE timedelta_vect_write_unit(this, unit)
4466TYPE(timedelta),INTENT(in) :: this(:)
4467INTEGER, INTENT(in) :: unit
4468
4469CHARACTER(len=40) :: form
4470CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4471INTEGER :: i
4472
4473ALLOCATE(dateiso(SIZE(this)))
4474DO i = 1, SIZE(dateiso)
4476ENDDO
4477INQUIRE(unit, form=form)
4478IF (form == 'FORMATTED') THEN
4479 WRITE(unit,'(3(A23,1X))')dateiso
4480ELSE
4481 WRITE(unit)dateiso
4482ENDIF
4483DEALLOCATE(dateiso)
4484
4485END SUBROUTINE timedelta_vect_write_unit
4486
4487
4488ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4489TYPE(timedelta),INTENT(in) :: this
4490LOGICAL :: res
4491
4492res = .not. this == timedelta_miss
4493
4494end FUNCTION c_e_timedelta
4495
4496
4497elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4498
4499!!omstart JELADATA5
4500! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4501! 1 IMINUTI)
4502!
4503! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4504!
4505! variabili integer*4
4506! IN:
4507! IDAY,IMONTH,IYEAR, I*4
4508! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4509!
4510! OUT:
4511! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4512!!OMEND
4513
4514INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4515INTEGER,intent(out) :: iminuti
4516
4517iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4518
4519END SUBROUTINE jeladata5
4520
4521
4522elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4523INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4524INTEGER(KIND=int_ll),intent(out) :: imillisec
4525
4526imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4527 + imsec
4528
4529END SUBROUTINE jeladata5_1
4530
4531
4532
4533elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4534
4535!!omstart JELADATA6
4536! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4537! 1 IMINUTI)
4538!
4539! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4540! 1/1/1
4541!
4542! variabili integer*4
4543! IN:
4544! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4545!
4546! OUT:
4547! IDAY,IMONTH,IYEAR, I*4
4548! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4549!!OMEND
4550
4551
4552INTEGER,intent(in) :: iminuti
4553INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4554
4555INTEGER ::igiorno
4556
4557imin = mod(iminuti,60)
4558ihour = mod(iminuti,1440)/60
4559igiorno = iminuti/1440
4561CALL ndyin(igiorno,iday,imonth,iyear)
4562
4563END SUBROUTINE jeladata6
4564
4565
4566elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4567INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4568INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4569
4570INTEGER :: igiorno
4571
4573!imin = MOD(imillisec/60000_int_ll, 60)
4574!ihour = MOD(imillisec/3600000_int_ll, 24)
4575imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4576ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4577igiorno = int(imillisec/86400000_int_ll)
4578!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4579CALL ndyin(igiorno,iday,imonth,iyear)
4580
4581END SUBROUTINE jeladata6_1
4582
4583
4584elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4585
4586!!OMSTART NDYIN
4587! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4588! restituisce la data fornendo in input il numero di
4589! giorni dal 1/1/1
4590!
4591!!omend
4592
4593INTEGER,intent(in) :: ndays
4594INTEGER,intent(out) :: igg, imm, iaa
4595integer :: n,lndays
4596
4597lndays=ndays
4598
4599n = lndays/d400
4600lndays = lndays - n*d400
4601iaa = year0 + n*400
4602n = min(lndays/d100, 3)
4603lndays = lndays - n*d100
4604iaa = iaa + n*100
4605n = lndays/d4
4606lndays = lndays - n*d4
4607iaa = iaa + n*4
4608n = min(lndays/d1, 3)
4609lndays = lndays - n*d1
4610iaa = iaa + n
4611n = bisextilis(iaa)
4612DO imm = 1, 12
4613 IF (lndays < ianno(imm+1,n)) EXIT
4614ENDDO
4615igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4616
4617END SUBROUTINE ndyin
4618
4619
4620integer elemental FUNCTION ndays(igg,imm,iaa)
4621
4622!!OMSTART NDAYS
4623! FUNCTION NDAYS(IGG,IMM,IAA)
4624! restituisce il numero di giorni dal 1/1/1
4625! fornendo in input la data
4626!
4627!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4628! nota bene E' SICURO !!!
4629! un anno e' bisestile se divisibile per 4
4630! un anno rimane bisestile se divisibile per 400
4631! un anno NON e' bisestile se divisibile per 100
4632!
4633!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4634!
4635!!omend
4636
4637INTEGER, intent(in) :: igg, imm, iaa
4638
4639INTEGER :: lmonth, lyear
4640
4641! Limito il mese a [1-12] e correggo l'anno coerentemente
4642lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4643lyear = iaa + (imm - lmonth)/12
4644ndays = igg+ianno(lmonth, bisextilis(lyear))
4645ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4646 (lyear-year0)/400
4647
4648END FUNCTION ndays
4649
4650
4651elemental FUNCTION bisextilis(annum)
4652INTEGER,INTENT(in) :: annum
4653INTEGER :: bisextilis
4654
4656 bisextilis = 2
4657ELSE
4658 bisextilis = 1
4659ENDIF
4660END FUNCTION bisextilis
4661
4662
4663ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4664TYPE(cyclicdatetime),INTENT(IN) :: this, that
4665LOGICAL :: res
4666
4667res = .true.
4668if (this%minute /= that%minute) res=.false.
4669if (this%hour /= that%hour) res=.false.
4670if (this%day /= that%day) res=.false.
4671if (this%month /= that%month) res=.false.
4672if (this%tendaysp /= that%tendaysp) res=.false.
4673
4674END FUNCTION cyclicdatetime_eq
4675
4676
4677ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4678TYPE(cyclicdatetime),INTENT(IN) :: this
4679TYPE(datetime),INTENT(IN) :: that
4680LOGICAL :: res
4681
4682integer :: minute,hour,day,month
4683
4685
4686res = .true.
4692 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4693end if
4694
4695END FUNCTION cyclicdatetime_datetime_eq
4696
4697
4698ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4699TYPE(datetime),INTENT(IN) :: this
4700TYPE(cyclicdatetime),INTENT(IN) :: that
4701LOGICAL :: res
4702
4703integer :: minute,hour,day,month
4704
4706
4707res = .true.
4712
4714 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4715end if
4716
4717
4718END FUNCTION datetime_cyclicdatetime_eq
4719
4720ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4721TYPE(cyclicdatetime),INTENT(in) :: this
4722LOGICAL :: res
4723
4724res = .not. this == cyclicdatetime_miss
4725
4726end FUNCTION c_e_cyclicdatetime
4727
4728
4731FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4732INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4733INTEGER,INTENT(IN),OPTIONAL :: month
4734INTEGER,INTENT(IN),OPTIONAL :: day
4735INTEGER,INTENT(IN),OPTIONAL :: hour
4736INTEGER,INTENT(IN),OPTIONAL :: minute
4737CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4738
4739integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4740
4741
4742TYPE(cyclicdatetime) :: this
4743
4744if (present(chardate)) then
4745
4746 ltendaysp=imiss
4747 lmonth=imiss
4748 lday=imiss
4749 lhour=imiss
4750 lminute=imiss
4751
4753 ! TMMGGhhmm
4754 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4755 !print*,chardate(1:1),ios,ltendaysp
4756 if (ios /= 0)ltendaysp=imiss
4757
4758 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4759 !print*,chardate(2:3),ios,lmonth
4760 if (ios /= 0)lmonth=imiss
4761
4762 read(chardate(4:5),'(i2)',iostat=ios)lday
4763 !print*,chardate(4:5),ios,lday
4764 if (ios /= 0)lday=imiss
4765
4766 read(chardate(6:7),'(i2)',iostat=ios)lhour
4767 !print*,chardate(6:7),ios,lhour
4768 if (ios /= 0)lhour=imiss
4769
4770 read(chardate(8:9),'(i2)',iostat=ios)lminute
4771 !print*,chardate(8:9),ios,lminute
4772 if (ios /= 0)lminute=imiss
4773 end if
4774
4775 this%tendaysp=ltendaysp
4776 this%month=lmonth
4777 this%day=lday
4778 this%hour=lhour
4779 this%minute=lminute
4780else
4781 this%tendaysp=optio_l(tendaysp)
4782 this%month=optio_l(month)
4783 this%day=optio_l(day)
4784 this%hour=optio_l(hour)
4785 this%minute=optio_l(minute)
4786end if
4787
4788END FUNCTION cyclicdatetime_new
4789
4792elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4793TYPE(cyclicdatetime),INTENT(IN) :: this
4794
4795CHARACTER(len=80) :: char
4796
4799
4800END FUNCTION cyclicdatetime_to_char
4801
4802
4815FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4816TYPE(cyclicdatetime),INTENT(IN) :: this
4817
4818TYPE(datetime) :: dtc
4819
4820integer :: year,month,day,hour
4821
4822dtc = datetime_miss
4823
4824! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4826 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4827 return
4828end if
4829
4830! minute present -> not good for conventional datetime
4832! day, month and tendaysp present -> no good
4834
4836 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4838 day=(this%tendaysp-1)*10+1
4839 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4841 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4843 ! only day present -> no good
4844 return
4845end if
4846
4849 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4850end if
4851
4852
4853END FUNCTION cyclicdatetime_to_conventional
4854
4855
4856
4857FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4858TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4859
4860CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4861
4862char=cyclicdatetime_to_char(in)
4863
4864END FUNCTION trim_cyclicdatetime_to_char
4865
4866
4867
4868SUBROUTINE display_cyclicdatetime(this)
4869TYPE(cyclicdatetime),INTENT(in) :: this
4870
4872
4873end subroutine display_cyclicdatetime
4874
4875
4876#include "array_utilities_inc.F90"
4877
4879
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 |