libsim Versione 7.1.11

◆ index_sorted_datetime()

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

Cerca l'indice del primo o ultimo elemento di vect uguale a search.

Definizione alla linea 3046 del file datetime_class.F90.

3048! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
3049! authors:
3050! Davide Cesari <dcesari@arpa.emr.it>
3051! Paolo Patruno <ppatruno@arpa.emr.it>
3052
3053! This program is free software; you can redistribute it and/or
3054! modify it under the terms of the GNU General Public License as
3055! published by the Free Software Foundation; either version 2 of
3056! the License, or (at your option) any later version.
3057
3058! This program is distributed in the hope that it will be useful,
3059! but WITHOUT ANY WARRANTY; without even the implied warranty of
3060! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3061! GNU General Public License for more details.
3062
3063! You should have received a copy of the GNU General Public License
3064! along with this program. If not, see <http://www.gnu.org/licenses/>.
3065#include "config.h"
3066
3080MODULE datetime_class
3081USE kinds
3082USE log4fortran
3083USE err_handling
3087IMPLICIT NONE
3088
3089INTEGER, PARAMETER :: dateint=selected_int_kind(13)
3090
3092TYPE datetime
3093 PRIVATE
3094 INTEGER(KIND=int_ll) :: iminuti
3095END TYPE datetime
3096
3104TYPE timedelta
3105 PRIVATE
3106 INTEGER(KIND=int_ll) :: iminuti
3107 INTEGER :: month
3108END TYPE timedelta
3109
3110
3114TYPE cyclicdatetime
3115 PRIVATE
3116 INTEGER :: minute
3117 INTEGER :: hour
3118 INTEGER :: day
3119 INTEGER :: tendaysp
3120 INTEGER :: month
3121END TYPE cyclicdatetime
3122
3123
3125TYPE(datetime), PARAMETER :: datetime_miss=datetime(illmiss)
3127TYPE(timedelta), PARAMETER :: timedelta_miss=timedelta(illmiss, 0)
3129TYPE(timedelta), PARAMETER :: timedelta_0=timedelta(0, 0)
3131INTEGER, PARAMETER :: datetime_utc=1
3133INTEGER, PARAMETER :: datetime_local=2
3135TYPE(datetime), PARAMETER :: datetime_min=datetime(-huge(1_int_ll)-1)
3137TYPE(datetime), PARAMETER :: datetime_max=datetime(huge(1_int_ll)-1)
3139TYPE(timedelta), PARAMETER :: timedelta_min=timedelta(-huge(1_int_ll)-1,0)
3141TYPE(timedelta), PARAMETER :: timedelta_max=timedelta(huge(1_int_ll)-1,0)
3143TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
3144
3145
3146INTEGER(kind=dateint), PARAMETER :: &
3147 sec_in_day=86400, &
3148 sec_in_hour=3600, &
3149 sec_in_min=60, &
3150 min_in_day=1440, &
3151 min_in_hour=60, &
3152 hour_in_day=24
3153
3154INTEGER,PARAMETER :: &
3155 year0=1, & ! anno di origine per iminuti
3156 d1=365, & ! giorni/1 anno nel calendario gregoriano
3157 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
3158 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
3159 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
3160 ianno(13,2)=reshape((/ &
3161 0,31,59,90,120,151,181,212,243,273,304,334,365, &
3162 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
3163
3164INTEGER(KIND=int_ll),PARAMETER :: &
3165 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
3166
3170INTERFACE init
3171 MODULE PROCEDURE datetime_init, timedelta_init
3172END INTERFACE
3173
3176INTERFACE delete
3177 MODULE PROCEDURE datetime_delete, timedelta_delete
3178END INTERFACE
3179
3181INTERFACE getval
3182 MODULE PROCEDURE datetime_getval, timedelta_getval
3183END INTERFACE
3184
3186INTERFACE to_char
3187 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
3188END INTERFACE
3189
3190
3208INTERFACE t2c
3209 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
3210END INTERFACE
3211
3217INTERFACE OPERATOR (==)
3218 MODULE PROCEDURE datetime_eq, timedelta_eq, &
3219 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
3220END INTERFACE
3221
3227INTERFACE OPERATOR (/=)
3228 MODULE PROCEDURE datetime_ne, timedelta_ne
3229END INTERFACE
3230
3238INTERFACE OPERATOR (>)
3239 MODULE PROCEDURE datetime_gt, timedelta_gt
3240END INTERFACE
3241
3249INTERFACE OPERATOR (<)
3250 MODULE PROCEDURE datetime_lt, timedelta_lt
3251END INTERFACE
3252
3260INTERFACE OPERATOR (>=)
3261 MODULE PROCEDURE datetime_ge, timedelta_ge
3262END INTERFACE
3263
3271INTERFACE OPERATOR (<=)
3272 MODULE PROCEDURE datetime_le, timedelta_le
3273END INTERFACE
3274
3281INTERFACE OPERATOR (+)
3282 MODULE PROCEDURE datetime_add, timedelta_add
3283END INTERFACE
3284
3292INTERFACE OPERATOR (-)
3293 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
3294END INTERFACE
3295
3301INTERFACE OPERATOR (*)
3302 MODULE PROCEDURE timedelta_mult, timedelta_tlum
3303END INTERFACE
3304
3311INTERFACE OPERATOR (/)
3312 MODULE PROCEDURE timedelta_divint, timedelta_divtd
3313END INTERFACE
3314
3325INTERFACE mod
3326 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3327END INTERFACE
3328
3331INTERFACE abs
3332 MODULE PROCEDURE timedelta_abs
3333END INTERFACE
3334
3337INTERFACE read_unit
3338 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3339 timedelta_read_unit, timedelta_vect_read_unit
3340END INTERFACE
3341
3344INTERFACE write_unit
3345 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3346 timedelta_write_unit, timedelta_vect_write_unit
3347END INTERFACE
3348
3350INTERFACE display
3351 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3352END INTERFACE
3353
3355INTERFACE c_e
3356 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
3357END INTERFACE
3358
3359#undef VOL7D_POLY_TYPE
3360#undef VOL7D_POLY_TYPES
3361#undef ENABLE_SORT
3362#define VOL7D_POLY_TYPE TYPE(datetime)
3363#define VOL7D_POLY_TYPES _datetime
3364#define ENABLE_SORT
3365#include "array_utilities_pre.F90"
3366
3367
3368#define ARRAYOF_ORIGTYPE TYPE(datetime)
3369#define ARRAYOF_TYPE arrayof_datetime
3370#define ARRAYOF_ORIGEQ 1
3371#include "arrayof_pre.F90"
3372! from arrayof
3373
3374PRIVATE
3375
3376PUBLIC datetime, datetime_miss, datetime_utc, datetime_local, &
3377 datetime_min, datetime_max, &
3378 datetime_new, datetime_new_now, init, delete, getval, to_char, t2c, &
3380 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3381 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3382 OPERATOR(*), OPERATOR(/), mod, abs, &
3383 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3384 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3385 display, c_e, &
3386 count_distinct, pack_distinct, &
3387 count_distinct_sorted, pack_distinct_sorted, &
3388 count_and_pack_distinct, &
3389 map_distinct, map_inv_distinct, index, index_sorted, sort, &
3390 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
3391PUBLIC insert, append, remove, packarray
3392PUBLIC insert_unique, append_unique
3393PUBLIC cyclicdatetime_to_conventional
3394
3395CONTAINS
3396
3397
3398! ==============
3399! == datetime ==
3400! ==============
3401
3408ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3409 unixtime, isodate, simpledate) RESULT(this)
3410INTEGER,INTENT(IN),OPTIONAL :: year
3411INTEGER,INTENT(IN),OPTIONAL :: month
3412INTEGER,INTENT(IN),OPTIONAL :: day
3413INTEGER,INTENT(IN),OPTIONAL :: hour
3414INTEGER,INTENT(IN),OPTIONAL :: minute
3415INTEGER,INTENT(IN),OPTIONAL :: msec
3416INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3417CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3418CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3419
3420TYPE(datetime) :: this
3421INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3422CHARACTER(len=23) :: datebuf
3423
3424IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3425 lyear = year
3426 IF (PRESENT(month)) THEN
3427 lmonth = month
3428 ELSE
3429 lmonth = 1
3430 ENDIF
3431 IF (PRESENT(day)) THEN
3432 lday = day
3433 ELSE
3434 lday = 1
3435 ENDIF
3436 IF (PRESENT(hour)) THEN
3437 lhour = hour
3438 ELSE
3439 lhour = 0
3440 ENDIF
3441 IF (PRESENT(minute)) THEN
3442 lminute = minute
3443 ELSE
3444 lminute = 0
3445 ENDIF
3446 IF (PRESENT(msec)) THEN
3447 lmsec = msec
3448 ELSE
3449 lmsec = 0
3450 ENDIF
3451
3452 if (c_e(lday) .and. c_e(lmonth) .and. c_e(lyear) .and. c_e(lhour) &
3453 .and. c_e(lminute) .and. c_e(lmsec)) then
3454 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3455 else
3456 this=datetime_miss
3457 end if
3458
3459ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3460 if (c_e(unixtime)) then
3461 this%iminuti = (unixtime + unsec)*1000
3462 else
3463 this=datetime_miss
3464 end if
3465
3466ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3467
3468 IF (c_e(isodate) .AND. len_trim(isodate) > 0) THEN
3469 datebuf(1:23) = '0001-01-01 00:00:00.000'
3470 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3471 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3472 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3473 lmsec = lmsec + lsec*1000
3474 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3475 RETURN
3476
3477100 CONTINUE ! condizione di errore in isodate
3478 CALL delete(this)
3479 RETURN
3480 ELSE
3481 this = datetime_miss
3482 ENDIF
3483
3484ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3485 IF (c_e(simpledate) .AND. len_trim(simpledate) > 0)THEN
3486 datebuf(1:17) = '00010101000000000'
3487 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3488 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3489 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3490 lmsec = lmsec + lsec*1000
3491 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3492 RETURN
3493
3494120 CONTINUE ! condizione di errore in simpledate
3495 CALL delete(this)
3496 RETURN
3497 ELSE
3498 this = datetime_miss
3499 ENDIF
3500
3501ELSE
3502 this = datetime_miss
3503ENDIF
3504
3505END FUNCTION datetime_new
3506
3507
3509FUNCTION datetime_new_now(now) RESULT(this)
3510INTEGER,INTENT(IN) :: now
3511TYPE(datetime) :: this
3512
3513INTEGER :: dt(8)
3514
3515IF (c_e(now)) THEN
3516 CALL date_and_time(values=dt)
3517 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3518 CALL init(this, year=dt(1), month=dt(2), day=dt(3), hour=dt(5), minute=dt(6), &
3519 msec=dt(7)*1000+dt(8))
3520ELSE
3521 this = datetime_miss
3522ENDIF
3523
3524END FUNCTION datetime_new_now
3525
3526
3533SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3534 unixtime, isodate, simpledate, now)
3535TYPE(datetime),INTENT(INOUT) :: this
3536INTEGER,INTENT(IN),OPTIONAL :: year
3537INTEGER,INTENT(IN),OPTIONAL :: month
3538INTEGER,INTENT(IN),OPTIONAL :: day
3539INTEGER,INTENT(IN),OPTIONAL :: hour
3540INTEGER,INTENT(IN),OPTIONAL :: minute
3541INTEGER,INTENT(IN),OPTIONAL :: msec
3542INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3543CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3544CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3545INTEGER,INTENT(IN),OPTIONAL :: now
3546
3547IF (PRESENT(now)) THEN
3548 this = datetime_new_now(now)
3549ELSE
3550 this = datetime_new(year, month, day, hour, minute, msec, &
3551 unixtime, isodate, simpledate)
3552ENDIF
3553
3554END SUBROUTINE datetime_init
3555
3556
3557ELEMENTAL SUBROUTINE datetime_delete(this)
3558TYPE(datetime),INTENT(INOUT) :: this
3559
3560this%iminuti = illmiss
3561
3562END SUBROUTINE datetime_delete
3563
3564
3569PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3570 unixtime, isodate, simpledate, oraclesimdate)
3571TYPE(datetime),INTENT(IN) :: this
3572INTEGER,INTENT(OUT),OPTIONAL :: year
3573INTEGER,INTENT(OUT),OPTIONAL :: month
3574INTEGER,INTENT(OUT),OPTIONAL :: day
3575INTEGER,INTENT(OUT),OPTIONAL :: hour
3576INTEGER,INTENT(OUT),OPTIONAL :: minute
3577INTEGER,INTENT(OUT),OPTIONAL :: msec
3578INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3579CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3580CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3581CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3582
3583INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3584CHARACTER(len=23) :: datebuf
3585
3586IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3587 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3588 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3589
3590 IF (this == datetime_miss) THEN
3591
3592 IF (PRESENT(msec)) THEN
3593 msec = imiss
3594 ENDIF
3595 IF (PRESENT(minute)) THEN
3596 minute = imiss
3597 ENDIF
3598 IF (PRESENT(hour)) THEN
3599 hour = imiss
3600 ENDIF
3601 IF (PRESENT(day)) THEN
3602 day = imiss
3603 ENDIF
3604 IF (PRESENT(month)) THEN
3605 month = imiss
3606 ENDIF
3607 IF (PRESENT(year)) THEN
3608 year = imiss
3609 ENDIF
3610 IF (PRESENT(isodate)) THEN
3611 isodate = cmiss
3612 ENDIF
3613 IF (PRESENT(simpledate)) THEN
3614 simpledate = cmiss
3615 ENDIF
3616 IF (PRESENT(oraclesimdate)) THEN
3617!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3618!!$ 'obsoleto, usare piuttosto simpledate')
3619 oraclesimdate=cmiss
3620 ENDIF
3621 IF (PRESENT(unixtime)) THEN
3622 unixtime = illmiss
3623 ENDIF
3624
3625 ELSE
3626
3627 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3628 IF (PRESENT(msec)) THEN
3629 msec = lmsec
3630 ENDIF
3631 IF (PRESENT(minute)) THEN
3632 minute = lminute
3633 ENDIF
3634 IF (PRESENT(hour)) THEN
3635 hour = lhour
3636 ENDIF
3637 IF (PRESENT(day)) THEN
3638 day = lday
3639 ENDIF
3640 IF (PRESENT(month)) THEN
3641 month = lmonth
3642 ENDIF
3643 IF (PRESENT(year)) THEN
3644 year = lyear
3645 ENDIF
3646 IF (PRESENT(isodate)) THEN
3647 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3648 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3649 '.', mod(lmsec, 1000)
3650 isodate = datebuf(1:min(len(isodate),23))
3651 ENDIF
3652 IF (PRESENT(simpledate)) THEN
3653 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3654 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3655 simpledate = datebuf(1:min(len(simpledate),17))
3656 ENDIF
3657 IF (PRESENT(oraclesimdate)) THEN
3658!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3659!!$ 'obsoleto, usare piuttosto simpledate')
3660 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3661 ENDIF
3662 IF (PRESENT(unixtime)) THEN
3663 unixtime = this%iminuti/1000_int_ll-unsec
3664 ENDIF
3665
3666 ENDIF
3667ENDIF
3668
3669END SUBROUTINE datetime_getval
3670
3671
3674elemental FUNCTION datetime_to_char(this) RESULT(char)
3675TYPE(datetime),INTENT(IN) :: this
3676
3677CHARACTER(len=23) :: char
3678
3679CALL getval(this, isodate=char)
3680
3681END FUNCTION datetime_to_char
3682
3683
3684FUNCTION trim_datetime_to_char(in) RESULT(char)
3685TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3686
3687CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3688
3689char=datetime_to_char(in)
3690
3691END FUNCTION trim_datetime_to_char
3692
3693
3694
3695SUBROUTINE display_datetime(this)
3696TYPE(datetime),INTENT(in) :: this
3697
3698print*,"TIME: ",to_char(this)
3699
3700end subroutine display_datetime
3701
3702
3703
3704SUBROUTINE display_timedelta(this)
3705TYPE(timedelta),INTENT(in) :: this
3706
3707print*,"TIMEDELTA: ",to_char(this)
3708
3709end subroutine display_timedelta
3710
3711
3712
3713ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3714TYPE(datetime),INTENT(in) :: this
3715LOGICAL :: res
3716
3717res = .not. this == datetime_miss
3718
3719end FUNCTION c_e_datetime
3720
3721
3722ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3723TYPE(datetime),INTENT(IN) :: this, that
3724LOGICAL :: res
3725
3726res = this%iminuti == that%iminuti
3727
3728END FUNCTION datetime_eq
3729
3730
3731ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3732TYPE(datetime),INTENT(IN) :: this, that
3733LOGICAL :: res
3734
3735res = .NOT.(this == that)
3736
3737END FUNCTION datetime_ne
3738
3739
3740ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3741TYPE(datetime),INTENT(IN) :: this, that
3742LOGICAL :: res
3743
3744res = this%iminuti > that%iminuti
3745
3746END FUNCTION datetime_gt
3747
3748
3749ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3750TYPE(datetime),INTENT(IN) :: this, that
3751LOGICAL :: res
3752
3753res = this%iminuti < that%iminuti
3754
3755END FUNCTION datetime_lt
3756
3757
3758ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3759TYPE(datetime),INTENT(IN) :: this, that
3760LOGICAL :: res
3761
3762IF (this == that) THEN
3763 res = .true.
3764ELSE IF (this > that) THEN
3765 res = .true.
3766ELSE
3767 res = .false.
3768ENDIF
3769
3770END FUNCTION datetime_ge
3771
3772
3773ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3774TYPE(datetime),INTENT(IN) :: this, that
3775LOGICAL :: res
3776
3777IF (this == that) THEN
3778 res = .true.
3779ELSE IF (this < that) THEN
3780 res = .true.
3781ELSE
3782 res = .false.
3783ENDIF
3784
3785END FUNCTION datetime_le
3786
3787
3788FUNCTION datetime_add(this, that) RESULT(res)
3789TYPE(datetime),INTENT(IN) :: this
3790TYPE(timedelta),INTENT(IN) :: that
3791TYPE(datetime) :: res
3792
3793INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3794
3795IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3796 res = datetime_miss
3797ELSE
3798 res%iminuti = this%iminuti + that%iminuti
3799 IF (that%month /= 0) THEN
3800 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3801 minute=lminute, msec=lmsec)
3802 CALL init(res, year=lyear, month=lmonth+that%month, day=lday, &
3803 hour=lhour, minute=lminute, msec=lmsec)
3804 ENDIF
3805ENDIF
3806
3807END FUNCTION datetime_add
3808
3809
3810ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3811TYPE(datetime),INTENT(IN) :: this, that
3812TYPE(timedelta) :: res
3813
3814IF (this == datetime_miss .OR. that == datetime_miss) THEN
3815 res = timedelta_miss
3816ELSE
3817 res%iminuti = this%iminuti - that%iminuti
3818 res%month = 0
3819ENDIF
3820
3821END FUNCTION datetime_subdt
3822
3823
3824FUNCTION datetime_subtd(this, that) RESULT(res)
3825TYPE(datetime),INTENT(IN) :: this
3826TYPE(timedelta),INTENT(IN) :: that
3827TYPE(datetime) :: res
3828
3829INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3830
3831IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3832 res = datetime_miss
3833ELSE
3834 res%iminuti = this%iminuti - that%iminuti
3835 IF (that%month /= 0) THEN
3836 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3837 minute=lminute, msec=lmsec)
3838 CALL init(res, year=lyear, month=lmonth-that%month, day=lday, &
3839 hour=lhour, minute=lminute, msec=lmsec)
3840 ENDIF
3841ENDIF
3842
3843END FUNCTION datetime_subtd
3844
3845
3850SUBROUTINE datetime_read_unit(this, unit)
3851TYPE(datetime),INTENT(out) :: this
3852INTEGER, INTENT(in) :: unit
3853CALL datetime_vect_read_unit((/this/), unit)
3854
3855END SUBROUTINE datetime_read_unit
3856
3857
3862SUBROUTINE datetime_vect_read_unit(this, unit)
3863TYPE(datetime) :: this(:)
3864INTEGER, INTENT(in) :: unit
3865
3866CHARACTER(len=40) :: form
3867CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3868INTEGER :: i
3869
3870ALLOCATE(dateiso(SIZE(this)))
3871INQUIRE(unit, form=form)
3872IF (form == 'FORMATTED') THEN
3873 READ(unit,'(A23,1X)')dateiso
3874ELSE
3875 READ(unit)dateiso
3876ENDIF
3877DO i = 1, SIZE(dateiso)
3878 CALL init(this(i), isodate=dateiso(i))
3879ENDDO
3880DEALLOCATE(dateiso)
3881
3882END SUBROUTINE datetime_vect_read_unit
3883
3884
3889SUBROUTINE datetime_write_unit(this, unit)
3890TYPE(datetime),INTENT(in) :: this
3891INTEGER, INTENT(in) :: unit
3892
3893CALL datetime_vect_write_unit((/this/), unit)
3894
3895END SUBROUTINE datetime_write_unit
3896
3897
3902SUBROUTINE datetime_vect_write_unit(this, unit)
3903TYPE(datetime),INTENT(in) :: this(:)
3904INTEGER, INTENT(in) :: unit
3905
3906CHARACTER(len=40) :: form
3907CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3908INTEGER :: i
3909
3910ALLOCATE(dateiso(SIZE(this)))
3911DO i = 1, SIZE(dateiso)
3912 CALL getval(this(i), isodate=dateiso(i))
3913ENDDO
3914INQUIRE(unit, form=form)
3915IF (form == 'FORMATTED') THEN
3916 WRITE(unit,'(A23,1X)')dateiso
3917ELSE
3918 WRITE(unit)dateiso
3919ENDIF
3920DEALLOCATE(dateiso)
3921
3922END SUBROUTINE datetime_vect_write_unit
3923
3924
3925#include "arrayof_post.F90"
3926
3927
3928! ===============
3929! == timedelta ==
3930! ===============
3937FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3938 isodate, simpledate, oraclesimdate) RESULT (this)
3939INTEGER,INTENT(IN),OPTIONAL :: year
3940INTEGER,INTENT(IN),OPTIONAL :: month
3941INTEGER,INTENT(IN),OPTIONAL :: day
3942INTEGER,INTENT(IN),OPTIONAL :: hour
3943INTEGER,INTENT(IN),OPTIONAL :: minute
3944INTEGER,INTENT(IN),OPTIONAL :: sec
3945INTEGER,INTENT(IN),OPTIONAL :: msec
3946CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3947CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3948CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3949
3950TYPE(timedelta) :: this
3951
3952CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3953 isodate, simpledate, oraclesimdate)
3954
3955END FUNCTION timedelta_new
3956
3957
3962SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3963 isodate, simpledate, oraclesimdate)
3964TYPE(timedelta),INTENT(INOUT) :: this
3965INTEGER,INTENT(IN),OPTIONAL :: year
3966INTEGER,INTENT(IN),OPTIONAL :: month
3967INTEGER,INTENT(IN),OPTIONAL :: day
3968INTEGER,INTENT(IN),OPTIONAL :: hour
3969INTEGER,INTENT(IN),OPTIONAL :: minute
3970INTEGER,INTENT(IN),OPTIONAL :: sec
3971INTEGER,INTENT(IN),OPTIONAL :: msec
3972CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3973CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3974CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3975
3976INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3977CHARACTER(len=23) :: datebuf
3978
3979this%month = 0
3980
3981IF (PRESENT(isodate)) THEN
3982 datebuf(1:23) = '0000000000 00:00:00.000'
3983 l = len_trim(isodate)
3984! IF (l > 0) THEN
3985 n = index(trim(isodate), ' ') ! align blank space separator
3986 IF (n > 0) THEN
3987 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3988 datebuf(12-n:12-n+l-1) = isodate(:l)
3989 ELSE
3990 datebuf(1:l) = isodate(1:l)
3991 ENDIF
3992! ENDIF
3993
3994! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3995 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3996 h, m, s, ms
3997 this%month = lmonth + 12*lyear
3998 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3999 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4000 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4001 RETURN
4002
4003200 CONTINUE ! condizione di errore in isodate
4004 CALL delete(this)
4005 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
4006 CALL raise_error()
4007
4008ELSE IF (PRESENT(simpledate)) THEN
4009 datebuf(1:17) = '00000000000000000'
4010 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
4011 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
4012 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4013 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4014 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4015
4016220 CONTINUE ! condizione di errore in simpledate
4017 CALL delete(this)
4018 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
4019 CALL raise_error()
4020 RETURN
4021
4022ELSE IF (PRESENT(oraclesimdate)) THEN
4023 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
4024 'obsoleto, usare piuttosto simpledate')
4025 READ(oraclesimdate, '(I8,2I2)')d, h, m
4026 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4027 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
4028
4029ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
4030 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
4031 .and. .not. present(msec) .and. .not. present(isodate) &
4032 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
4033
4034 this=timedelta_miss
4035
4036ELSE
4037 this%iminuti = 0
4038 IF (PRESENT(year)) THEN
4039 if (c_e(year))then
4040 this%month = this%month + year*12
4041 else
4042 this=timedelta_miss
4043 return
4044 end if
4045 ENDIF
4046 IF (PRESENT(month)) THEN
4047 if (c_e(month))then
4048 this%month = this%month + month
4049 else
4050 this=timedelta_miss
4051 return
4052 end if
4053 ENDIF
4054 IF (PRESENT(day)) THEN
4055 if (c_e(day))then
4056 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
4057 else
4058 this=timedelta_miss
4059 return
4060 end if
4061 ENDIF
4062 IF (PRESENT(hour)) THEN
4063 if (c_e(hour))then
4064 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
4065 else
4066 this=timedelta_miss
4067 return
4068 end if
4069 ENDIF
4070 IF (PRESENT(minute)) THEN
4071 if (c_e(minute))then
4072 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
4073 else
4074 this=timedelta_miss
4075 return
4076 end if
4077 ENDIF
4078 IF (PRESENT(sec)) THEN
4079 if (c_e(sec))then
4080 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
4081 else
4082 this=timedelta_miss
4083 return
4084 end if
4085 ENDIF
4086 IF (PRESENT(msec)) THEN
4087 if (c_e(msec))then
4088 this%iminuti = this%iminuti + msec
4089 else
4090 this=timedelta_miss
4091 return
4092 end if
4093 ENDIF
4094ENDIF
4095
4096
4097
4098
4099END SUBROUTINE timedelta_init
4100
4101
4102SUBROUTINE timedelta_delete(this)
4103TYPE(timedelta),INTENT(INOUT) :: this
4104
4105this%iminuti = imiss
4106this%month = 0
4107
4108END SUBROUTINE timedelta_delete
4109
4110
4115PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
4116 day, hour, minute, sec, msec, &
4117 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
4118TYPE(timedelta),INTENT(IN) :: this
4119INTEGER,INTENT(OUT),OPTIONAL :: year
4120INTEGER,INTENT(OUT),OPTIONAL :: month
4121INTEGER,INTENT(OUT),OPTIONAL :: amonth
4122INTEGER,INTENT(OUT),OPTIONAL :: day
4123INTEGER,INTENT(OUT),OPTIONAL :: hour
4124INTEGER,INTENT(OUT),OPTIONAL :: minute
4125INTEGER,INTENT(OUT),OPTIONAL :: sec
4126INTEGER,INTENT(OUT),OPTIONAL :: msec
4127INTEGER,INTENT(OUT),OPTIONAL :: ahour
4128INTEGER,INTENT(OUT),OPTIONAL :: aminute
4129INTEGER,INTENT(OUT),OPTIONAL :: asec
4130INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
4131CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
4132CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
4133CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
4134
4135CHARACTER(len=23) :: datebuf
4136
4137IF (PRESENT(amsec)) THEN
4138 amsec = this%iminuti
4139ENDIF
4140IF (PRESENT(asec)) THEN
4141 asec = int(this%iminuti/1000_int_ll)
4142ENDIF
4143IF (PRESENT(aminute)) THEN
4144 aminute = int(this%iminuti/60000_int_ll)
4145ENDIF
4146IF (PRESENT(ahour)) THEN
4147 ahour = int(this%iminuti/3600000_int_ll)
4148ENDIF
4149IF (PRESENT(msec)) THEN
4150 msec = int(mod(this%iminuti, 1000_int_ll))
4151ENDIF
4152IF (PRESENT(sec)) THEN
4153 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
4154ENDIF
4155IF (PRESENT(minute)) THEN
4156 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
4157ENDIF
4158IF (PRESENT(hour)) THEN
4159 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
4160ENDIF
4161IF (PRESENT(day)) THEN
4162 day = int(this%iminuti/86400000_int_ll)
4163ENDIF
4164IF (PRESENT(amonth)) THEN
4165 amonth = this%month
4166ENDIF
4167IF (PRESENT(month)) THEN
4168 month = mod(this%month-1,12)+1
4169ENDIF
4170IF (PRESENT(year)) THEN
4171 year = this%month/12
4172ENDIF
4173IF (PRESENT(isodate)) THEN ! Non standard, inventato!
4174 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
4175 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), ':', &
4176 mod(this%iminuti/60000_int_ll, 60_int_ll), ':', mod(this%iminuti/1000_int_ll, 60_int_ll), &
4177 '.', mod(this%iminuti, 1000_int_ll)
4178 isodate = datebuf(1:min(len(isodate),23))
4179
4180ENDIF
4181IF (PRESENT(simpledate)) THEN
4182 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
4183 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
4184 mod(this%iminuti/60000_int_ll, 60_int_ll), mod(this%iminuti/1000_int_ll, 60_int_ll), &
4185 mod(this%iminuti, 1000_int_ll)
4186 simpledate = datebuf(1:min(len(simpledate),17))
4187ENDIF
4188IF (PRESENT(oraclesimdate)) THEN
4189!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
4190!!$ 'obsoleto, usare piuttosto simpledate')
4191 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
4192 mod(this%iminuti/3600000_int_ll, 24_int_ll), mod(this%iminuti/60000_int_ll, 60_int_ll)
4193ENDIF
4194
4195END SUBROUTINE timedelta_getval
4196
4197
4200elemental FUNCTION timedelta_to_char(this) RESULT(char)
4201TYPE(timedelta),INTENT(IN) :: this
4202
4203CHARACTER(len=23) :: char
4204
4205CALL getval(this, isodate=char)
4206
4207END FUNCTION timedelta_to_char
4208
4209
4210FUNCTION trim_timedelta_to_char(in) RESULT(char)
4211TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
4212
4213CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
4214
4215char=timedelta_to_char(in)
4216
4217END FUNCTION trim_timedelta_to_char
4218
4219
4221elemental FUNCTION timedelta_getamsec(this)
4222TYPE(timedelta),INTENT(IN) :: this
4223INTEGER(kind=int_ll) :: timedelta_getamsec
4224
4225timedelta_getamsec = this%iminuti
4226
4227END FUNCTION timedelta_getamsec
4228
4229
4235FUNCTION timedelta_depop(this)
4236TYPE(timedelta),INTENT(IN) :: this
4237TYPE(timedelta) :: timedelta_depop
4238
4239TYPE(datetime) :: tmpdt
4240
4241IF (this%month == 0) THEN
4242 timedelta_depop = this
4243ELSE
4244 tmpdt = datetime_new(1970, 1, 1)
4245 timedelta_depop = (tmpdt + this) - tmpdt
4246ENDIF
4247
4248END FUNCTION timedelta_depop
4249
4250
4251elemental FUNCTION timedelta_eq(this, that) RESULT(res)
4252TYPE(timedelta),INTENT(IN) :: this, that
4253LOGICAL :: res
4254
4255res = (this%iminuti == that%iminuti .AND. this%month == that%month)
4256
4257END FUNCTION timedelta_eq
4258
4259
4260ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
4261TYPE(timedelta),INTENT(IN) :: this, that
4262LOGICAL :: res
4263
4264res = .NOT.(this == that)
4265
4266END FUNCTION timedelta_ne
4267
4268
4269ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
4270TYPE(timedelta),INTENT(IN) :: this, that
4271LOGICAL :: res
4272
4273res = this%iminuti > that%iminuti
4274
4275END FUNCTION timedelta_gt
4276
4277
4278ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
4279TYPE(timedelta),INTENT(IN) :: this, that
4280LOGICAL :: res
4281
4282res = this%iminuti < that%iminuti
4283
4284END FUNCTION timedelta_lt
4285
4286
4287ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
4288TYPE(timedelta),INTENT(IN) :: this, that
4289LOGICAL :: res
4290
4291IF (this == that) THEN
4292 res = .true.
4293ELSE IF (this > that) THEN
4294 res = .true.
4295ELSE
4296 res = .false.
4297ENDIF
4298
4299END FUNCTION timedelta_ge
4300
4301
4302elemental FUNCTION timedelta_le(this, that) RESULT(res)
4303TYPE(timedelta),INTENT(IN) :: this, that
4304LOGICAL :: res
4305
4306IF (this == that) THEN
4307 res = .true.
4308ELSE IF (this < that) THEN
4309 res = .true.
4310ELSE
4311 res = .false.
4312ENDIF
4313
4314END FUNCTION timedelta_le
4315
4316
4317ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
4318TYPE(timedelta),INTENT(IN) :: this, that
4319TYPE(timedelta) :: res
4320
4321res%iminuti = this%iminuti + that%iminuti
4322res%month = this%month + that%month
4323
4324END FUNCTION timedelta_add
4325
4326
4327ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
4328TYPE(timedelta),INTENT(IN) :: this, that
4329TYPE(timedelta) :: res
4330
4331res%iminuti = this%iminuti - that%iminuti
4332res%month = this%month - that%month
4333
4334END FUNCTION timedelta_sub
4335
4336
4337ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
4338TYPE(timedelta),INTENT(IN) :: this
4339INTEGER,INTENT(IN) :: n
4340TYPE(timedelta) :: res
4341
4342res%iminuti = this%iminuti*n
4343res%month = this%month*n
4344
4345END FUNCTION timedelta_mult
4346
4347
4348ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
4349INTEGER,INTENT(IN) :: n
4350TYPE(timedelta),INTENT(IN) :: this
4351TYPE(timedelta) :: res
4352
4353res%iminuti = this%iminuti*n
4354res%month = this%month*n
4355
4356END FUNCTION timedelta_tlum
4357
4358
4359ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
4360TYPE(timedelta),INTENT(IN) :: this
4361INTEGER,INTENT(IN) :: n
4362TYPE(timedelta) :: res
4363
4364res%iminuti = this%iminuti/n
4365res%month = this%month/n
4366
4367END FUNCTION timedelta_divint
4368
4369
4370ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
4371TYPE(timedelta),INTENT(IN) :: this, that
4372INTEGER :: res
4373
4374res = int(this%iminuti/that%iminuti)
4375
4376END FUNCTION timedelta_divtd
4377
4378
4379elemental FUNCTION timedelta_mod(this, that) RESULT(res)
4380TYPE(timedelta),INTENT(IN) :: this, that
4381TYPE(timedelta) :: res
4382
4383res%iminuti = mod(this%iminuti, that%iminuti)
4384res%month = 0
4385
4386END FUNCTION timedelta_mod
4387
4388
4389ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
4390TYPE(datetime),INTENT(IN) :: this
4391TYPE(timedelta),INTENT(IN) :: that
4392TYPE(timedelta) :: res
4393
4394IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
4395 res = timedelta_0
4396ELSE
4397 res%iminuti = mod(this%iminuti, that%iminuti)
4398 res%month = 0
4399ENDIF
4400
4401END FUNCTION datetime_timedelta_mod
4402
4403
4404ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
4405TYPE(timedelta),INTENT(IN) :: this
4406TYPE(timedelta) :: res
4407
4408res%iminuti = abs(this%iminuti)
4409res%month = abs(this%month)
4410
4411END FUNCTION timedelta_abs
4412
4413
4418SUBROUTINE timedelta_read_unit(this, unit)
4419TYPE(timedelta),INTENT(out) :: this
4420INTEGER, INTENT(in) :: unit
4421
4422CALL timedelta_vect_read_unit((/this/), unit)
4423
4424END SUBROUTINE timedelta_read_unit
4425
4426
4431SUBROUTINE timedelta_vect_read_unit(this, unit)
4432TYPE(timedelta) :: this(:)
4433INTEGER, INTENT(in) :: unit
4434
4435CHARACTER(len=40) :: form
4436CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4437INTEGER :: i
4438
4439ALLOCATE(dateiso(SIZE(this)))
4440INQUIRE(unit, form=form)
4441IF (form == 'FORMATTED') THEN
4442 READ(unit,'(3(A23,1X))')dateiso
4443ELSE
4444 READ(unit)dateiso
4445ENDIF
4446DO i = 1, SIZE(dateiso)
4447 CALL init(this(i), isodate=dateiso(i))
4448ENDDO
4449DEALLOCATE(dateiso)
4450
4451END SUBROUTINE timedelta_vect_read_unit
4452
4453
4458SUBROUTINE timedelta_write_unit(this, unit)
4459TYPE(timedelta),INTENT(in) :: this
4460INTEGER, INTENT(in) :: unit
4461
4462CALL timedelta_vect_write_unit((/this/), unit)
4463
4464END SUBROUTINE timedelta_write_unit
4465
4466
4471SUBROUTINE timedelta_vect_write_unit(this, unit)
4472TYPE(timedelta),INTENT(in) :: this(:)
4473INTEGER, INTENT(in) :: unit
4474
4475CHARACTER(len=40) :: form
4476CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4477INTEGER :: i
4478
4479ALLOCATE(dateiso(SIZE(this)))
4480DO i = 1, SIZE(dateiso)
4481 CALL getval(this(i), isodate=dateiso(i))
4482ENDDO
4483INQUIRE(unit, form=form)
4484IF (form == 'FORMATTED') THEN
4485 WRITE(unit,'(3(A23,1X))')dateiso
4486ELSE
4487 WRITE(unit)dateiso
4488ENDIF
4489DEALLOCATE(dateiso)
4490
4491END SUBROUTINE timedelta_vect_write_unit
4492
4493
4494ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4495TYPE(timedelta),INTENT(in) :: this
4496LOGICAL :: res
4497
4498res = .not. this == timedelta_miss
4499
4500end FUNCTION c_e_timedelta
4501
4502
4503elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4504
4505!!omstart JELADATA5
4506! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4507! 1 IMINUTI)
4508!
4509! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4510!
4511! variabili integer*4
4512! IN:
4513! IDAY,IMONTH,IYEAR, I*4
4514! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4515!
4516! OUT:
4517! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4518!!OMEND
4519
4520INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4521INTEGER,intent(out) :: iminuti
4522
4523iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4524
4525END SUBROUTINE jeladata5
4526
4527
4528elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4529INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4530INTEGER(KIND=int_ll),intent(out) :: imillisec
4531
4532imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4533 + imsec
4534
4535END SUBROUTINE jeladata5_1
4536
4537
4538
4539elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4540
4541!!omstart JELADATA6
4542! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4543! 1 IMINUTI)
4544!
4545! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4546! 1/1/1
4547!
4548! variabili integer*4
4549! IN:
4550! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4551!
4552! OUT:
4553! IDAY,IMONTH,IYEAR, I*4
4554! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4555!!OMEND
4556
4557
4558INTEGER,intent(in) :: iminuti
4559INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4560
4561INTEGER ::igiorno
4562
4563imin = mod(iminuti,60)
4564ihour = mod(iminuti,1440)/60
4565igiorno = iminuti/1440
4566IF (mod(iminuti,1440) < 0) igiorno = igiorno-1
4567CALL ndyin(igiorno,iday,imonth,iyear)
4568
4569END SUBROUTINE jeladata6
4570
4571
4572elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4573INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4574INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4575
4576INTEGER :: igiorno
4577
4578imsec = int(mod(imillisec, 60000_int_ll)) ! partial msec
4579!imin = MOD(imillisec/60000_int_ll, 60)
4580!ihour = MOD(imillisec/3600000_int_ll, 24)
4581imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4582ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4583igiorno = int(imillisec/86400000_int_ll)
4584!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4585CALL ndyin(igiorno,iday,imonth,iyear)
4586
4587END SUBROUTINE jeladata6_1
4588
4589
4590elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4591
4592!!OMSTART NDYIN
4593! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4594! restituisce la data fornendo in input il numero di
4595! giorni dal 1/1/1
4596!
4597!!omend
4598
4599INTEGER,intent(in) :: ndays
4600INTEGER,intent(out) :: igg, imm, iaa
4601integer :: n,lndays
4602
4603lndays=ndays
4604
4605n = lndays/d400
4606lndays = lndays - n*d400
4607iaa = year0 + n*400
4608n = min(lndays/d100, 3)
4609lndays = lndays - n*d100
4610iaa = iaa + n*100
4611n = lndays/d4
4612lndays = lndays - n*d4
4613iaa = iaa + n*4
4614n = min(lndays/d1, 3)
4615lndays = lndays - n*d1
4616iaa = iaa + n
4617n = bisextilis(iaa)
4618DO imm = 1, 12
4619 IF (lndays < ianno(imm+1,n)) EXIT
4620ENDDO
4621igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4622
4623END SUBROUTINE ndyin
4624
4625
4626integer elemental FUNCTION ndays(igg,imm,iaa)
4627
4628!!OMSTART NDAYS
4629! FUNCTION NDAYS(IGG,IMM,IAA)
4630! restituisce il numero di giorni dal 1/1/1
4631! fornendo in input la data
4632!
4633!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4634! nota bene E' SICURO !!!
4635! un anno e' bisestile se divisibile per 4
4636! un anno rimane bisestile se divisibile per 400
4637! un anno NON e' bisestile se divisibile per 100
4638!
4639!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4640!
4641!!omend
4642
4643INTEGER, intent(in) :: igg, imm, iaa
4644
4645INTEGER :: lmonth, lyear
4646
4647! Limito il mese a [1-12] e correggo l'anno coerentemente
4648lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4649lyear = iaa + (imm - lmonth)/12
4650ndays = igg+ianno(lmonth, bisextilis(lyear))
4651ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4652 (lyear-year0)/400
4653
4654END FUNCTION ndays
4655
4656
4657elemental FUNCTION bisextilis(annum)
4658INTEGER,INTENT(in) :: annum
4659INTEGER :: bisextilis
4660
4661IF (mod(annum,4) == 0 .AND. (mod(annum,400) == 0 .EQV. mod(annum,100) == 0)) THEN
4662 bisextilis = 2
4663ELSE
4664 bisextilis = 1
4665ENDIF
4666END FUNCTION bisextilis
4667
4668
4669ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4670TYPE(cyclicdatetime),INTENT(IN) :: this, that
4671LOGICAL :: res
4672
4673res = .true.
4674if (this%minute /= that%minute) res=.false.
4675if (this%hour /= that%hour) res=.false.
4676if (this%day /= that%day) res=.false.
4677if (this%month /= that%month) res=.false.
4678if (this%tendaysp /= that%tendaysp) res=.false.
4679
4680END FUNCTION cyclicdatetime_eq
4681
4682
4683ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4684TYPE(cyclicdatetime),INTENT(IN) :: this
4685TYPE(datetime),INTENT(IN) :: that
4686LOGICAL :: res
4687
4688integer :: minute,hour,day,month
4689
4690call getval(that,minute=minute,hour=hour,day=day,month=month)
4691
4692res = .true.
4693if (c_e(this%minute) .and. this%minute /= minute) res=.false.
4694if (c_e(this%hour) .and. this%hour /= hour) res=.false.
4695if (c_e(this%day) .and. this%day /= day) res=.false.
4696if (c_e(this%month) .and. this%month /= month) res=.false.
4697if (c_e(this%tendaysp)) then
4698 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4699end if
4700
4701END FUNCTION cyclicdatetime_datetime_eq
4702
4703
4704ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4705TYPE(datetime),INTENT(IN) :: this
4706TYPE(cyclicdatetime),INTENT(IN) :: that
4707LOGICAL :: res
4708
4709integer :: minute,hour,day,month
4710
4711call getval(this,minute=minute,hour=hour,day=day,month=month)
4712
4713res = .true.
4714if (c_e(that%minute) .and. that%minute /= minute) res=.false.
4715if (c_e(that%hour) .and. that%hour /= hour) res=.false.
4716if (c_e(that%day) .and. that%day /= day) res=.false.
4717if (c_e(that%month) .and. that%month /= month) res=.false.
4718
4719if (c_e(that%tendaysp)) then
4720 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4721end if
4722
4723
4724END FUNCTION datetime_cyclicdatetime_eq
4725
4726ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4727TYPE(cyclicdatetime),INTENT(in) :: this
4728LOGICAL :: res
4729
4730res = .not. this == cyclicdatetime_miss
4731
4732end FUNCTION c_e_cyclicdatetime
4733
4734
4737FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4738INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4739INTEGER,INTENT(IN),OPTIONAL :: month
4740INTEGER,INTENT(IN),OPTIONAL :: day
4741INTEGER,INTENT(IN),OPTIONAL :: hour
4742INTEGER,INTENT(IN),OPTIONAL :: minute
4743CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4744
4745integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4746
4747
4748TYPE(cyclicdatetime) :: this
4749
4750if (present(chardate)) then
4751
4752 ltendaysp=imiss
4753 lmonth=imiss
4754 lday=imiss
4755 lhour=imiss
4756 lminute=imiss
4757
4758 if (c_e(chardate))then
4759 ! TMMGGhhmm
4760 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4761 !print*,chardate(1:1),ios,ltendaysp
4762 if (ios /= 0)ltendaysp=imiss
4763
4764 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4765 !print*,chardate(2:3),ios,lmonth
4766 if (ios /= 0)lmonth=imiss
4767
4768 read(chardate(4:5),'(i2)',iostat=ios)lday
4769 !print*,chardate(4:5),ios,lday
4770 if (ios /= 0)lday=imiss
4771
4772 read(chardate(6:7),'(i2)',iostat=ios)lhour
4773 !print*,chardate(6:7),ios,lhour
4774 if (ios /= 0)lhour=imiss
4775
4776 read(chardate(8:9),'(i2)',iostat=ios)lminute
4777 !print*,chardate(8:9),ios,lminute
4778 if (ios /= 0)lminute=imiss
4779 end if
4780
4781 this%tendaysp=ltendaysp
4782 this%month=lmonth
4783 this%day=lday
4784 this%hour=lhour
4785 this%minute=lminute
4786else
4787 this%tendaysp=optio_l(tendaysp)
4788 this%month=optio_l(month)
4789 this%day=optio_l(day)
4790 this%hour=optio_l(hour)
4791 this%minute=optio_l(minute)
4792end if
4793
4794END FUNCTION cyclicdatetime_new
4795
4798elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4799TYPE(cyclicdatetime),INTENT(IN) :: this
4800
4801CHARACTER(len=80) :: char
4802
4803char=to_char(this%tendaysp)//";"//to_char(this%month)//";"//to_char(this%day)//";"//&
4804to_char(this%hour)//";"//to_char(this%minute)
4805
4806END FUNCTION cyclicdatetime_to_char
4807
4808
4821FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4822TYPE(cyclicdatetime),INTENT(IN) :: this
4823
4824TYPE(datetime) :: dtc
4825
4826integer :: year,month,day,hour
4827
4828dtc = datetime_miss
4829
4830! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4831if ( .not. c_e(this)) then
4832 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4833 return
4834end if
4835
4836! minute present -> not good for conventional datetime
4837if (c_e(this%minute)) return
4838! day, month and tendaysp present -> no good
4839if (c_e(this%day) .and. c_e(this%month) .and. c_e(this%tendaysp)) return
4840
4841if (c_e(this%day) .and. c_e(this%month)) then
4842 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4843else if (c_e(this%tendaysp) .and. c_e(this%month)) then
4844 day=(this%tendaysp-1)*10+1
4845 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4846else if (c_e(this%month)) then
4847 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4848else if (c_e(this%day)) then
4849 ! only day present -> no good
4850 return
4851end if
4852
4853if (c_e(this%hour)) then
4854 call getval(dtc,year=year,month=month,day=day,hour=hour)
4855 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4856end if
4857
4858
4859END FUNCTION cyclicdatetime_to_conventional
4860
4861
4862
4863FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4864TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4865
4866CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4867
4868char=cyclicdatetime_to_char(in)
4869
4870END FUNCTION trim_cyclicdatetime_to_char
4871
4872
4873
4874SUBROUTINE display_cyclicdatetime(this)
4875TYPE(cyclicdatetime),INTENT(in) :: this
4876
4877print*,"CYCLICDATETIME: ",to_char(this)
4878
4879end subroutine display_cyclicdatetime
4880
4881
4882#include "array_utilities_inc.F90"
4883
4884END MODULE datetime_class
4885
Operatore di valore assoluto di un intervallo.
Quick method to append an element to the array.
Distruttori per le 2 classi.
Restituiscono il valore dell'oggetto nella forma desiderata.
Index method with sorted array.
Costruttori per le classi datetime e timedelta.
Method for inserting elements of the array at a desired position.
Operatore di resto della divisione.
Method for packing the array object reducing at a minimum the memory occupation, without destroying i...
Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o...
Method for removing elements of the array at a desired position.
Functions that return a trimmed CHARACTER representation of the input variable.
Restituiscono il valore dell'oggetto in forma di stringa stampabile.
Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ...
Index method.
Utilities for CHARACTER variables.
Classi per la gestione delle coordinate temporali.
Gestione degli errori.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:251
classe per la gestione del logging
Definitions of constants and functions for working with missing values.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Class for expressing a cyclic datetime.
Class for expressing an absolute time value.
Class for expressing a relative time interval.

Generated with Doxygen.