libsim Versione 7.2.0

◆ index_sorted_datetime()

recursive integer function index_sorted_datetime ( type(datetime), dimension(:), intent(in)  vect,
type(datetime), intent(in)  search 
)

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
3074MODULE datetime_class
3075USE kinds
3076USE log4fortran
3077USE err_handling
3081IMPLICIT NONE
3082
3083INTEGER, PARAMETER :: dateint=selected_int_kind(13)
3084
3086TYPE datetime
3087 PRIVATE
3088 INTEGER(KIND=int_ll) :: iminuti
3089END TYPE datetime
3090
3098TYPE timedelta
3099 PRIVATE
3100 INTEGER(KIND=int_ll) :: iminuti
3101 INTEGER :: month
3102END TYPE timedelta
3103
3104
3108TYPE cyclicdatetime
3109 PRIVATE
3110 INTEGER :: minute
3111 INTEGER :: hour
3112 INTEGER :: day
3113 INTEGER :: tendaysp
3114 INTEGER :: month
3115END TYPE cyclicdatetime
3116
3117
3119TYPE(datetime), PARAMETER :: datetime_miss=datetime(illmiss)
3121TYPE(timedelta), PARAMETER :: timedelta_miss=timedelta(illmiss, 0)
3123TYPE(timedelta), PARAMETER :: timedelta_0=timedelta(0, 0)
3125INTEGER, PARAMETER :: datetime_utc=1
3127INTEGER, PARAMETER :: datetime_local=2
3129TYPE(datetime), PARAMETER :: datetime_min=datetime(-huge(1_int_ll)-1)
3131TYPE(datetime), PARAMETER :: datetime_max=datetime(huge(1_int_ll)-1)
3133TYPE(timedelta), PARAMETER :: timedelta_min=timedelta(-huge(1_int_ll)-1,0)
3135TYPE(timedelta), PARAMETER :: timedelta_max=timedelta(huge(1_int_ll)-1,0)
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
3164INTERFACE init
3165 MODULE PROCEDURE datetime_init, timedelta_init
3166END INTERFACE
3167
3170INTERFACE delete
3171 MODULE PROCEDURE datetime_delete, timedelta_delete
3172END INTERFACE
3173
3175INTERFACE getval
3176 MODULE PROCEDURE datetime_getval, timedelta_getval
3177END INTERFACE
3178
3180INTERFACE to_char
3181 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
3182END INTERFACE
3183
3184
3202INTERFACE t2c
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
3319INTERFACE mod
3320 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3321END INTERFACE
3322
3325INTERFACE abs
3326 MODULE PROCEDURE timedelta_abs
3327END INTERFACE
3328
3331INTERFACE read_unit
3332 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3333 timedelta_read_unit, timedelta_vect_read_unit
3334END INTERFACE
3335
3338INTERFACE write_unit
3339 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3340 timedelta_write_unit, timedelta_vect_write_unit
3341END INTERFACE
3342
3344INTERFACE display
3345 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3346END INTERFACE
3347
3349INTERFACE c_e
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
3370PUBLIC datetime, datetime_miss, datetime_utc, datetime_local, &
3371 datetime_min, datetime_max, &
3372 datetime_new, datetime_new_now, init, delete, getval, to_char, t2c, &
3374 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3375 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3376 OPERATOR(*), OPERATOR(/), mod, abs, &
3377 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3378 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3379 display, c_e, &
3380 count_distinct, pack_distinct, &
3381 count_distinct_sorted, pack_distinct_sorted, &
3382 count_and_pack_distinct, &
3383 map_distinct, map_inv_distinct, index, index_sorted, sort, &
3384 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
3385PUBLIC insert, append, remove, packarray
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
3446 if (c_e(lday) .and. c_e(lmonth) .and. c_e(lyear) .and. c_e(lhour) &
3447 .and. c_e(lminute) .and. c_e(lmsec)) then
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)
3454 if (c_e(unixtime)) then
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
3462 IF (c_e(isodate) .AND. len_trim(isodate) > 0) THEN
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
3472 CALL delete(this)
3473 RETURN
3474 ELSE
3475 this = datetime_miss
3476 ENDIF
3477
3478ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3479 IF (c_e(simpledate) .AND. len_trim(simpledate) > 0)THEN
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
3489 CALL delete(this)
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
3509IF (c_e(now)) THEN
3510 CALL date_and_time(values=dt)
3511 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3512 CALL init(this, year=dt(1), month=dt(2), day=dt(3), hour=dt(5), minute=dt(6), &
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, &
3643 '.', mod(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
3673CALL getval(this, isodate=char)
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
3692print*,"TIME: ",to_char(this)
3693
3694end subroutine display_datetime
3695
3696
3697
3698SUBROUTINE display_timedelta(this)
3699TYPE(timedelta),INTENT(in) :: this
3700
3701print*,"TIMEDELTA: ",to_char(this)
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
3794 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3795 minute=lminute, msec=lmsec)
3796 CALL init(res, year=lyear, month=lmonth+that%month, day=lday, &
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
3830 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3831 minute=lminute, msec=lmsec)
3832 CALL init(res, year=lyear, month=lmonth-that%month, day=lday, &
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)
3872 CALL init(this(i), isodate=dateiso(i))
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)
3906 CALL getval(this(i), isodate=dateiso(i))
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
3979 n = index(trim(isodate), ' ') ! align blank space separator
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
3998 CALL delete(this)
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
4011 CALL delete(this)
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
4033 if (c_e(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
4041 if (c_e(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
4049 if (c_e(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
4057 if (c_e(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
4065 if (c_e(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
4073 if (c_e(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
4081 if (c_e(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)') &
4169 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), ':', &
4170 mod(this%iminuti/60000_int_ll, 60_int_ll), ':', mod(this%iminuti/1000_int_ll, 60_int_ll), &
4171 '.', mod(this%iminuti, 1000_int_ll)
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), &
4178 mod(this%iminuti/60000_int_ll, 60_int_ll), mod(this%iminuti/1000_int_ll, 60_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, &
4186 mod(this%iminuti/3600000_int_ll, 24_int_ll), mod(this%iminuti/60000_int_ll, 60_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
4199CALL getval(this, isodate=char)
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)
4441 CALL init(this(i), isodate=dateiso(i))
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)
4475 CALL getval(this(i), isodate=dateiso(i))
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
4560IF (mod(iminuti,1440) < 0) igiorno = igiorno-1
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
4572imsec = int(mod(imillisec, 60000_int_ll)) ! partial msec
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
4655IF (mod(annum,4) == 0 .AND. (mod(annum,400) == 0 .EQV. mod(annum,100) == 0)) THEN
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
4684call getval(that,minute=minute,hour=hour,day=day,month=month)
4685
4686res = .true.
4687if (c_e(this%minute) .and. this%minute /= minute) res=.false.
4688if (c_e(this%hour) .and. this%hour /= hour) res=.false.
4689if (c_e(this%day) .and. this%day /= day) res=.false.
4690if (c_e(this%month) .and. this%month /= month) res=.false.
4691if (c_e(this%tendaysp)) then
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
4705call getval(this,minute=minute,hour=hour,day=day,month=month)
4706
4707res = .true.
4708if (c_e(that%minute) .and. that%minute /= minute) res=.false.
4709if (c_e(that%hour) .and. that%hour /= hour) res=.false.
4710if (c_e(that%day) .and. that%day /= day) res=.false.
4711if (c_e(that%month) .and. that%month /= month) res=.false.
4712
4713if (c_e(that%tendaysp)) then
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
4752 if (c_e(chardate))then
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
4797char=to_char(this%tendaysp)//";"//to_char(this%month)//";"//to_char(this%day)//";"//&
4798to_char(this%hour)//";"//to_char(this%minute)
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)
4825if ( .not. c_e(this)) then
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
4831if (c_e(this%minute)) return
4832! day, month and tendaysp present -> no good
4833if (c_e(this%day) .and. c_e(this%month) .and. c_e(this%tendaysp)) return
4834
4835if (c_e(this%day) .and. c_e(this%month)) then
4836 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4837else if (c_e(this%tendaysp) .and. c_e(this%month)) then
4838 day=(this%tendaysp-1)*10+1
4839 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4840else if (c_e(this%month)) then
4841 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4842else if (c_e(this%day)) then
4843 ! only day present -> no good
4844 return
4845end if
4846
4847if (c_e(this%hour)) then
4848 call getval(dtc,year=year,month=month,day=day,hour=hour)
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
4871print*,"CYCLICDATETIME: ",to_char(this)
4872
4873end subroutine display_cyclicdatetime
4874
4875
4876#include "array_utilities_inc.F90"
4877
4878END MODULE datetime_class
4879
Operatore di valore assoluto di un intervallo.
Quick method to append an element to the array.
Distruttori per le 2 classi.
Restituiscono il valore dell'oggetto nella forma desiderata.
Index method with sorted array.
Costruttori per le classi datetime e timedelta.
Method for inserting elements of the array at a desired position.
Operatore di resto della divisione.
Method for packing the array object reducing at a minimum the memory occupation, without destroying i...
Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o...
Method for removing elements of the array at a desired position.
Functions that return a trimmed CHARACTER representation of the input variable.
Restituiscono il valore dell'oggetto in forma di stringa stampabile.
Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ...
Index method.
Utilities for CHARACTER variables.
Classi per la gestione delle coordinate temporali.
Gestione degli errori.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:245
classe per la gestione del logging
Definitions of constants and functions for working with missing values.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Class for expressing a cyclic datetime.
Class for expressing an absolute time value.
Class for expressing a relative time interval.

Generated with Doxygen.