libsim Versione 7.1.11

◆ index_datetime()

integer function index_datetime ( type(datetime), dimension(:), intent(in)  vect,
type(datetime), intent(in)  search,
logical, dimension(:), intent(in), optional  mask,
logical, intent(in), optional  back,
integer, intent(in), optional  cache 
)
private

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

Definizione alla linea 2969 del file datetime_class.F90.

2971! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2972! authors:
2973! Davide Cesari <dcesari@arpa.emr.it>
2974! Paolo Patruno <ppatruno@arpa.emr.it>
2975
2976! This program is free software; you can redistribute it and/or
2977! modify it under the terms of the GNU General Public License as
2978! published by the Free Software Foundation; either version 2 of
2979! the License, or (at your option) any later version.
2980
2981! This program is distributed in the hope that it will be useful,
2982! but WITHOUT ANY WARRANTY; without even the implied warranty of
2983! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2984! GNU General Public License for more details.
2985
2986! You should have received a copy of the GNU General Public License
2987! along with this program. If not, see <http://www.gnu.org/licenses/>.
2988#include "config.h"
2989
3003MODULE datetime_class
3004USE kinds
3005USE log4fortran
3006USE err_handling
3010IMPLICIT NONE
3011
3012INTEGER, PARAMETER :: dateint=selected_int_kind(13)
3013
3015TYPE datetime
3016 PRIVATE
3017 INTEGER(KIND=int_ll) :: iminuti
3018END TYPE datetime
3019
3027TYPE timedelta
3028 PRIVATE
3029 INTEGER(KIND=int_ll) :: iminuti
3030 INTEGER :: month
3031END TYPE timedelta
3032
3033
3037TYPE cyclicdatetime
3038 PRIVATE
3039 INTEGER :: minute
3040 INTEGER :: hour
3041 INTEGER :: day
3042 INTEGER :: tendaysp
3043 INTEGER :: month
3044END TYPE cyclicdatetime
3045
3046
3048TYPE(datetime), PARAMETER :: datetime_miss=datetime(illmiss)
3050TYPE(timedelta), PARAMETER :: timedelta_miss=timedelta(illmiss, 0)
3052TYPE(timedelta), PARAMETER :: timedelta_0=timedelta(0, 0)
3054INTEGER, PARAMETER :: datetime_utc=1
3056INTEGER, PARAMETER :: datetime_local=2
3058TYPE(datetime), PARAMETER :: datetime_min=datetime(-huge(1_int_ll)-1)
3060TYPE(datetime), PARAMETER :: datetime_max=datetime(huge(1_int_ll)-1)
3062TYPE(timedelta), PARAMETER :: timedelta_min=timedelta(-huge(1_int_ll)-1,0)
3064TYPE(timedelta), PARAMETER :: timedelta_max=timedelta(huge(1_int_ll)-1,0)
3066TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
3067
3068
3069INTEGER(kind=dateint), PARAMETER :: &
3070 sec_in_day=86400, &
3071 sec_in_hour=3600, &
3072 sec_in_min=60, &
3073 min_in_day=1440, &
3074 min_in_hour=60, &
3075 hour_in_day=24
3076
3077INTEGER,PARAMETER :: &
3078 year0=1, & ! anno di origine per iminuti
3079 d1=365, & ! giorni/1 anno nel calendario gregoriano
3080 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
3081 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
3082 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
3083 ianno(13,2)=reshape((/ &
3084 0,31,59,90,120,151,181,212,243,273,304,334,365, &
3085 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
3086
3087INTEGER(KIND=int_ll),PARAMETER :: &
3088 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
3089
3093INTERFACE init
3094 MODULE PROCEDURE datetime_init, timedelta_init
3095END INTERFACE
3096
3099INTERFACE delete
3100 MODULE PROCEDURE datetime_delete, timedelta_delete
3101END INTERFACE
3102
3104INTERFACE getval
3105 MODULE PROCEDURE datetime_getval, timedelta_getval
3106END INTERFACE
3107
3109INTERFACE to_char
3110 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
3111END INTERFACE
3112
3113
3131INTERFACE t2c
3132 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
3133END INTERFACE
3134
3140INTERFACE OPERATOR (==)
3141 MODULE PROCEDURE datetime_eq, timedelta_eq, &
3142 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
3143END INTERFACE
3144
3150INTERFACE OPERATOR (/=)
3151 MODULE PROCEDURE datetime_ne, timedelta_ne
3152END INTERFACE
3153
3161INTERFACE OPERATOR (>)
3162 MODULE PROCEDURE datetime_gt, timedelta_gt
3163END INTERFACE
3164
3172INTERFACE OPERATOR (<)
3173 MODULE PROCEDURE datetime_lt, timedelta_lt
3174END INTERFACE
3175
3183INTERFACE OPERATOR (>=)
3184 MODULE PROCEDURE datetime_ge, timedelta_ge
3185END INTERFACE
3186
3194INTERFACE OPERATOR (<=)
3195 MODULE PROCEDURE datetime_le, timedelta_le
3196END INTERFACE
3197
3204INTERFACE OPERATOR (+)
3205 MODULE PROCEDURE datetime_add, timedelta_add
3206END INTERFACE
3207
3215INTERFACE OPERATOR (-)
3216 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
3217END INTERFACE
3218
3224INTERFACE OPERATOR (*)
3225 MODULE PROCEDURE timedelta_mult, timedelta_tlum
3226END INTERFACE
3227
3234INTERFACE OPERATOR (/)
3235 MODULE PROCEDURE timedelta_divint, timedelta_divtd
3236END INTERFACE
3237
3248INTERFACE mod
3249 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3250END INTERFACE
3251
3254INTERFACE abs
3255 MODULE PROCEDURE timedelta_abs
3256END INTERFACE
3257
3260INTERFACE read_unit
3261 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3262 timedelta_read_unit, timedelta_vect_read_unit
3263END INTERFACE
3264
3267INTERFACE write_unit
3268 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3269 timedelta_write_unit, timedelta_vect_write_unit
3270END INTERFACE
3271
3273INTERFACE display
3274 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3275END INTERFACE
3276
3278INTERFACE c_e
3279 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
3280END INTERFACE
3281
3282#undef VOL7D_POLY_TYPE
3283#undef VOL7D_POLY_TYPES
3284#undef ENABLE_SORT
3285#define VOL7D_POLY_TYPE TYPE(datetime)
3286#define VOL7D_POLY_TYPES _datetime
3287#define ENABLE_SORT
3288#include "array_utilities_pre.F90"
3289
3290
3291#define ARRAYOF_ORIGTYPE TYPE(datetime)
3292#define ARRAYOF_TYPE arrayof_datetime
3293#define ARRAYOF_ORIGEQ 1
3294#include "arrayof_pre.F90"
3295! from arrayof
3296
3297PRIVATE
3298
3299PUBLIC datetime, datetime_miss, datetime_utc, datetime_local, &
3300 datetime_min, datetime_max, &
3301 datetime_new, datetime_new_now, init, delete, getval, to_char, t2c, &
3303 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3304 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3305 OPERATOR(*), OPERATOR(/), mod, abs, &
3306 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3307 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3308 display, c_e, &
3309 count_distinct, pack_distinct, &
3310 count_distinct_sorted, pack_distinct_sorted, &
3311 count_and_pack_distinct, &
3312 map_distinct, map_inv_distinct, index, index_sorted, sort, &
3313 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
3314PUBLIC insert, append, remove, packarray
3315PUBLIC insert_unique, append_unique
3316PUBLIC cyclicdatetime_to_conventional
3317
3318CONTAINS
3319
3320
3321! ==============
3322! == datetime ==
3323! ==============
3324
3331ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3332 unixtime, isodate, simpledate) RESULT(this)
3333INTEGER,INTENT(IN),OPTIONAL :: year
3334INTEGER,INTENT(IN),OPTIONAL :: month
3335INTEGER,INTENT(IN),OPTIONAL :: day
3336INTEGER,INTENT(IN),OPTIONAL :: hour
3337INTEGER,INTENT(IN),OPTIONAL :: minute
3338INTEGER,INTENT(IN),OPTIONAL :: msec
3339INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3340CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3341CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3342
3343TYPE(datetime) :: this
3344INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3345CHARACTER(len=23) :: datebuf
3346
3347IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3348 lyear = year
3349 IF (PRESENT(month)) THEN
3350 lmonth = month
3351 ELSE
3352 lmonth = 1
3353 ENDIF
3354 IF (PRESENT(day)) THEN
3355 lday = day
3356 ELSE
3357 lday = 1
3358 ENDIF
3359 IF (PRESENT(hour)) THEN
3360 lhour = hour
3361 ELSE
3362 lhour = 0
3363 ENDIF
3364 IF (PRESENT(minute)) THEN
3365 lminute = minute
3366 ELSE
3367 lminute = 0
3368 ENDIF
3369 IF (PRESENT(msec)) THEN
3370 lmsec = msec
3371 ELSE
3372 lmsec = 0
3373 ENDIF
3374
3375 if (c_e(lday) .and. c_e(lmonth) .and. c_e(lyear) .and. c_e(lhour) &
3376 .and. c_e(lminute) .and. c_e(lmsec)) then
3377 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3378 else
3379 this=datetime_miss
3380 end if
3381
3382ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3383 if (c_e(unixtime)) then
3384 this%iminuti = (unixtime + unsec)*1000
3385 else
3386 this=datetime_miss
3387 end if
3388
3389ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3390
3391 IF (c_e(isodate) .AND. len_trim(isodate) > 0) THEN
3392 datebuf(1:23) = '0001-01-01 00:00:00.000'
3393 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3394 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3395 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3396 lmsec = lmsec + lsec*1000
3397 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3398 RETURN
3399
3400100 CONTINUE ! condizione di errore in isodate
3401 CALL delete(this)
3402 RETURN
3403 ELSE
3404 this = datetime_miss
3405 ENDIF
3406
3407ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3408 IF (c_e(simpledate) .AND. len_trim(simpledate) > 0)THEN
3409 datebuf(1:17) = '00010101000000000'
3410 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3411 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3412 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3413 lmsec = lmsec + lsec*1000
3414 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3415 RETURN
3416
3417120 CONTINUE ! condizione di errore in simpledate
3418 CALL delete(this)
3419 RETURN
3420 ELSE
3421 this = datetime_miss
3422 ENDIF
3423
3424ELSE
3425 this = datetime_miss
3426ENDIF
3427
3428END FUNCTION datetime_new
3429
3430
3432FUNCTION datetime_new_now(now) RESULT(this)
3433INTEGER,INTENT(IN) :: now
3434TYPE(datetime) :: this
3435
3436INTEGER :: dt(8)
3437
3438IF (c_e(now)) THEN
3439 CALL date_and_time(values=dt)
3440 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3441 CALL init(this, year=dt(1), month=dt(2), day=dt(3), hour=dt(5), minute=dt(6), &
3442 msec=dt(7)*1000+dt(8))
3443ELSE
3444 this = datetime_miss
3445ENDIF
3446
3447END FUNCTION datetime_new_now
3448
3449
3456SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3457 unixtime, isodate, simpledate, now)
3458TYPE(datetime),INTENT(INOUT) :: this
3459INTEGER,INTENT(IN),OPTIONAL :: year
3460INTEGER,INTENT(IN),OPTIONAL :: month
3461INTEGER,INTENT(IN),OPTIONAL :: day
3462INTEGER,INTENT(IN),OPTIONAL :: hour
3463INTEGER,INTENT(IN),OPTIONAL :: minute
3464INTEGER,INTENT(IN),OPTIONAL :: msec
3465INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3466CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3467CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3468INTEGER,INTENT(IN),OPTIONAL :: now
3469
3470IF (PRESENT(now)) THEN
3471 this = datetime_new_now(now)
3472ELSE
3473 this = datetime_new(year, month, day, hour, minute, msec, &
3474 unixtime, isodate, simpledate)
3475ENDIF
3476
3477END SUBROUTINE datetime_init
3478
3479
3480ELEMENTAL SUBROUTINE datetime_delete(this)
3481TYPE(datetime),INTENT(INOUT) :: this
3482
3483this%iminuti = illmiss
3484
3485END SUBROUTINE datetime_delete
3486
3487
3492PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3493 unixtime, isodate, simpledate, oraclesimdate)
3494TYPE(datetime),INTENT(IN) :: this
3495INTEGER,INTENT(OUT),OPTIONAL :: year
3496INTEGER,INTENT(OUT),OPTIONAL :: month
3497INTEGER,INTENT(OUT),OPTIONAL :: day
3498INTEGER,INTENT(OUT),OPTIONAL :: hour
3499INTEGER,INTENT(OUT),OPTIONAL :: minute
3500INTEGER,INTENT(OUT),OPTIONAL :: msec
3501INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3502CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3503CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3504CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3505
3506INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3507CHARACTER(len=23) :: datebuf
3508
3509IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3510 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3511 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3512
3513 IF (this == datetime_miss) THEN
3514
3515 IF (PRESENT(msec)) THEN
3516 msec = imiss
3517 ENDIF
3518 IF (PRESENT(minute)) THEN
3519 minute = imiss
3520 ENDIF
3521 IF (PRESENT(hour)) THEN
3522 hour = imiss
3523 ENDIF
3524 IF (PRESENT(day)) THEN
3525 day = imiss
3526 ENDIF
3527 IF (PRESENT(month)) THEN
3528 month = imiss
3529 ENDIF
3530 IF (PRESENT(year)) THEN
3531 year = imiss
3532 ENDIF
3533 IF (PRESENT(isodate)) THEN
3534 isodate = cmiss
3535 ENDIF
3536 IF (PRESENT(simpledate)) THEN
3537 simpledate = cmiss
3538 ENDIF
3539 IF (PRESENT(oraclesimdate)) THEN
3540!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3541!!$ 'obsoleto, usare piuttosto simpledate')
3542 oraclesimdate=cmiss
3543 ENDIF
3544 IF (PRESENT(unixtime)) THEN
3545 unixtime = illmiss
3546 ENDIF
3547
3548 ELSE
3549
3550 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3551 IF (PRESENT(msec)) THEN
3552 msec = lmsec
3553 ENDIF
3554 IF (PRESENT(minute)) THEN
3555 minute = lminute
3556 ENDIF
3557 IF (PRESENT(hour)) THEN
3558 hour = lhour
3559 ENDIF
3560 IF (PRESENT(day)) THEN
3561 day = lday
3562 ENDIF
3563 IF (PRESENT(month)) THEN
3564 month = lmonth
3565 ENDIF
3566 IF (PRESENT(year)) THEN
3567 year = lyear
3568 ENDIF
3569 IF (PRESENT(isodate)) THEN
3570 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3571 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3572 '.', mod(lmsec, 1000)
3573 isodate = datebuf(1:min(len(isodate),23))
3574 ENDIF
3575 IF (PRESENT(simpledate)) THEN
3576 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3577 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3578 simpledate = datebuf(1:min(len(simpledate),17))
3579 ENDIF
3580 IF (PRESENT(oraclesimdate)) THEN
3581!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3582!!$ 'obsoleto, usare piuttosto simpledate')
3583 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3584 ENDIF
3585 IF (PRESENT(unixtime)) THEN
3586 unixtime = this%iminuti/1000_int_ll-unsec
3587 ENDIF
3588
3589 ENDIF
3590ENDIF
3591
3592END SUBROUTINE datetime_getval
3593
3594
3597elemental FUNCTION datetime_to_char(this) RESULT(char)
3598TYPE(datetime),INTENT(IN) :: this
3599
3600CHARACTER(len=23) :: char
3601
3602CALL getval(this, isodate=char)
3603
3604END FUNCTION datetime_to_char
3605
3606
3607FUNCTION trim_datetime_to_char(in) RESULT(char)
3608TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3609
3610CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3611
3612char=datetime_to_char(in)
3613
3614END FUNCTION trim_datetime_to_char
3615
3616
3617
3618SUBROUTINE display_datetime(this)
3619TYPE(datetime),INTENT(in) :: this
3620
3621print*,"TIME: ",to_char(this)
3622
3623end subroutine display_datetime
3624
3625
3626
3627SUBROUTINE display_timedelta(this)
3628TYPE(timedelta),INTENT(in) :: this
3629
3630print*,"TIMEDELTA: ",to_char(this)
3631
3632end subroutine display_timedelta
3633
3634
3635
3636ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3637TYPE(datetime),INTENT(in) :: this
3638LOGICAL :: res
3639
3640res = .not. this == datetime_miss
3641
3642end FUNCTION c_e_datetime
3643
3644
3645ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3646TYPE(datetime),INTENT(IN) :: this, that
3647LOGICAL :: res
3648
3649res = this%iminuti == that%iminuti
3650
3651END FUNCTION datetime_eq
3652
3653
3654ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3655TYPE(datetime),INTENT(IN) :: this, that
3656LOGICAL :: res
3657
3658res = .NOT.(this == that)
3659
3660END FUNCTION datetime_ne
3661
3662
3663ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3664TYPE(datetime),INTENT(IN) :: this, that
3665LOGICAL :: res
3666
3667res = this%iminuti > that%iminuti
3668
3669END FUNCTION datetime_gt
3670
3671
3672ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3673TYPE(datetime),INTENT(IN) :: this, that
3674LOGICAL :: res
3675
3676res = this%iminuti < that%iminuti
3677
3678END FUNCTION datetime_lt
3679
3680
3681ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3682TYPE(datetime),INTENT(IN) :: this, that
3683LOGICAL :: res
3684
3685IF (this == that) THEN
3686 res = .true.
3687ELSE IF (this > that) THEN
3688 res = .true.
3689ELSE
3690 res = .false.
3691ENDIF
3692
3693END FUNCTION datetime_ge
3694
3695
3696ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3697TYPE(datetime),INTENT(IN) :: this, that
3698LOGICAL :: res
3699
3700IF (this == that) THEN
3701 res = .true.
3702ELSE IF (this < that) THEN
3703 res = .true.
3704ELSE
3705 res = .false.
3706ENDIF
3707
3708END FUNCTION datetime_le
3709
3710
3711FUNCTION datetime_add(this, that) RESULT(res)
3712TYPE(datetime),INTENT(IN) :: this
3713TYPE(timedelta),INTENT(IN) :: that
3714TYPE(datetime) :: res
3715
3716INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3717
3718IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3719 res = datetime_miss
3720ELSE
3721 res%iminuti = this%iminuti + that%iminuti
3722 IF (that%month /= 0) THEN
3723 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3724 minute=lminute, msec=lmsec)
3725 CALL init(res, year=lyear, month=lmonth+that%month, day=lday, &
3726 hour=lhour, minute=lminute, msec=lmsec)
3727 ENDIF
3728ENDIF
3729
3730END FUNCTION datetime_add
3731
3732
3733ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3734TYPE(datetime),INTENT(IN) :: this, that
3735TYPE(timedelta) :: res
3736
3737IF (this == datetime_miss .OR. that == datetime_miss) THEN
3738 res = timedelta_miss
3739ELSE
3740 res%iminuti = this%iminuti - that%iminuti
3741 res%month = 0
3742ENDIF
3743
3744END FUNCTION datetime_subdt
3745
3746
3747FUNCTION datetime_subtd(this, that) RESULT(res)
3748TYPE(datetime),INTENT(IN) :: this
3749TYPE(timedelta),INTENT(IN) :: that
3750TYPE(datetime) :: res
3751
3752INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3753
3754IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3755 res = datetime_miss
3756ELSE
3757 res%iminuti = this%iminuti - that%iminuti
3758 IF (that%month /= 0) THEN
3759 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3760 minute=lminute, msec=lmsec)
3761 CALL init(res, year=lyear, month=lmonth-that%month, day=lday, &
3762 hour=lhour, minute=lminute, msec=lmsec)
3763 ENDIF
3764ENDIF
3765
3766END FUNCTION datetime_subtd
3767
3768
3773SUBROUTINE datetime_read_unit(this, unit)
3774TYPE(datetime),INTENT(out) :: this
3775INTEGER, INTENT(in) :: unit
3776CALL datetime_vect_read_unit((/this/), unit)
3777
3778END SUBROUTINE datetime_read_unit
3779
3780
3785SUBROUTINE datetime_vect_read_unit(this, unit)
3786TYPE(datetime) :: this(:)
3787INTEGER, INTENT(in) :: unit
3788
3789CHARACTER(len=40) :: form
3790CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3791INTEGER :: i
3792
3793ALLOCATE(dateiso(SIZE(this)))
3794INQUIRE(unit, form=form)
3795IF (form == 'FORMATTED') THEN
3796 READ(unit,'(A23,1X)')dateiso
3797ELSE
3798 READ(unit)dateiso
3799ENDIF
3800DO i = 1, SIZE(dateiso)
3801 CALL init(this(i), isodate=dateiso(i))
3802ENDDO
3803DEALLOCATE(dateiso)
3804
3805END SUBROUTINE datetime_vect_read_unit
3806
3807
3812SUBROUTINE datetime_write_unit(this, unit)
3813TYPE(datetime),INTENT(in) :: this
3814INTEGER, INTENT(in) :: unit
3815
3816CALL datetime_vect_write_unit((/this/), unit)
3817
3818END SUBROUTINE datetime_write_unit
3819
3820
3825SUBROUTINE datetime_vect_write_unit(this, unit)
3826TYPE(datetime),INTENT(in) :: this(:)
3827INTEGER, INTENT(in) :: unit
3828
3829CHARACTER(len=40) :: form
3830CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3831INTEGER :: i
3832
3833ALLOCATE(dateiso(SIZE(this)))
3834DO i = 1, SIZE(dateiso)
3835 CALL getval(this(i), isodate=dateiso(i))
3836ENDDO
3837INQUIRE(unit, form=form)
3838IF (form == 'FORMATTED') THEN
3839 WRITE(unit,'(A23,1X)')dateiso
3840ELSE
3841 WRITE(unit)dateiso
3842ENDIF
3843DEALLOCATE(dateiso)
3844
3845END SUBROUTINE datetime_vect_write_unit
3846
3847
3848#include "arrayof_post.F90"
3849
3850
3851! ===============
3852! == timedelta ==
3853! ===============
3860FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3861 isodate, simpledate, oraclesimdate) RESULT (this)
3862INTEGER,INTENT(IN),OPTIONAL :: year
3863INTEGER,INTENT(IN),OPTIONAL :: month
3864INTEGER,INTENT(IN),OPTIONAL :: day
3865INTEGER,INTENT(IN),OPTIONAL :: hour
3866INTEGER,INTENT(IN),OPTIONAL :: minute
3867INTEGER,INTENT(IN),OPTIONAL :: sec
3868INTEGER,INTENT(IN),OPTIONAL :: msec
3869CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3870CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3871CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3872
3873TYPE(timedelta) :: this
3874
3875CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3876 isodate, simpledate, oraclesimdate)
3877
3878END FUNCTION timedelta_new
3879
3880
3885SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3886 isodate, simpledate, oraclesimdate)
3887TYPE(timedelta),INTENT(INOUT) :: this
3888INTEGER,INTENT(IN),OPTIONAL :: year
3889INTEGER,INTENT(IN),OPTIONAL :: month
3890INTEGER,INTENT(IN),OPTIONAL :: day
3891INTEGER,INTENT(IN),OPTIONAL :: hour
3892INTEGER,INTENT(IN),OPTIONAL :: minute
3893INTEGER,INTENT(IN),OPTIONAL :: sec
3894INTEGER,INTENT(IN),OPTIONAL :: msec
3895CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3896CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3897CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3898
3899INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3900CHARACTER(len=23) :: datebuf
3901
3902this%month = 0
3903
3904IF (PRESENT(isodate)) THEN
3905 datebuf(1:23) = '0000000000 00:00:00.000'
3906 l = len_trim(isodate)
3907! IF (l > 0) THEN
3908 n = index(trim(isodate), ' ') ! align blank space separator
3909 IF (n > 0) THEN
3910 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3911 datebuf(12-n:12-n+l-1) = isodate(:l)
3912 ELSE
3913 datebuf(1:l) = isodate(1:l)
3914 ENDIF
3915! ENDIF
3916
3917! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3918 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3919 h, m, s, ms
3920 this%month = lmonth + 12*lyear
3921 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3922 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3923 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3924 RETURN
3925
3926200 CONTINUE ! condizione di errore in isodate
3927 CALL delete(this)
3928 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3929 CALL raise_error()
3930
3931ELSE IF (PRESENT(simpledate)) THEN
3932 datebuf(1:17) = '00000000000000000'
3933 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3934 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3935 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3936 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3937 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3938
3939220 CONTINUE ! condizione di errore in simpledate
3940 CALL delete(this)
3941 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3942 CALL raise_error()
3943 RETURN
3944
3945ELSE IF (PRESENT(oraclesimdate)) THEN
3946 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3947 'obsoleto, usare piuttosto simpledate')
3948 READ(oraclesimdate, '(I8,2I2)')d, h, m
3949 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3950 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3951
3952ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3953 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3954 .and. .not. present(msec) .and. .not. present(isodate) &
3955 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3956
3957 this=timedelta_miss
3958
3959ELSE
3960 this%iminuti = 0
3961 IF (PRESENT(year)) THEN
3962 if (c_e(year))then
3963 this%month = this%month + year*12
3964 else
3965 this=timedelta_miss
3966 return
3967 end if
3968 ENDIF
3969 IF (PRESENT(month)) THEN
3970 if (c_e(month))then
3971 this%month = this%month + month
3972 else
3973 this=timedelta_miss
3974 return
3975 end if
3976 ENDIF
3977 IF (PRESENT(day)) THEN
3978 if (c_e(day))then
3979 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3980 else
3981 this=timedelta_miss
3982 return
3983 end if
3984 ENDIF
3985 IF (PRESENT(hour)) THEN
3986 if (c_e(hour))then
3987 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3988 else
3989 this=timedelta_miss
3990 return
3991 end if
3992 ENDIF
3993 IF (PRESENT(minute)) THEN
3994 if (c_e(minute))then
3995 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3996 else
3997 this=timedelta_miss
3998 return
3999 end if
4000 ENDIF
4001 IF (PRESENT(sec)) THEN
4002 if (c_e(sec))then
4003 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
4004 else
4005 this=timedelta_miss
4006 return
4007 end if
4008 ENDIF
4009 IF (PRESENT(msec)) THEN
4010 if (c_e(msec))then
4011 this%iminuti = this%iminuti + msec
4012 else
4013 this=timedelta_miss
4014 return
4015 end if
4016 ENDIF
4017ENDIF
4018
4019
4020
4021
4022END SUBROUTINE timedelta_init
4023
4024
4025SUBROUTINE timedelta_delete(this)
4026TYPE(timedelta),INTENT(INOUT) :: this
4027
4028this%iminuti = imiss
4029this%month = 0
4030
4031END SUBROUTINE timedelta_delete
4032
4033
4038PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
4039 day, hour, minute, sec, msec, &
4040 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
4041TYPE(timedelta),INTENT(IN) :: this
4042INTEGER,INTENT(OUT),OPTIONAL :: year
4043INTEGER,INTENT(OUT),OPTIONAL :: month
4044INTEGER,INTENT(OUT),OPTIONAL :: amonth
4045INTEGER,INTENT(OUT),OPTIONAL :: day
4046INTEGER,INTENT(OUT),OPTIONAL :: hour
4047INTEGER,INTENT(OUT),OPTIONAL :: minute
4048INTEGER,INTENT(OUT),OPTIONAL :: sec
4049INTEGER,INTENT(OUT),OPTIONAL :: msec
4050INTEGER,INTENT(OUT),OPTIONAL :: ahour
4051INTEGER,INTENT(OUT),OPTIONAL :: aminute
4052INTEGER,INTENT(OUT),OPTIONAL :: asec
4053INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
4054CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
4055CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
4056CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
4057
4058CHARACTER(len=23) :: datebuf
4059
4060IF (PRESENT(amsec)) THEN
4061 amsec = this%iminuti
4062ENDIF
4063IF (PRESENT(asec)) THEN
4064 asec = int(this%iminuti/1000_int_ll)
4065ENDIF
4066IF (PRESENT(aminute)) THEN
4067 aminute = int(this%iminuti/60000_int_ll)
4068ENDIF
4069IF (PRESENT(ahour)) THEN
4070 ahour = int(this%iminuti/3600000_int_ll)
4071ENDIF
4072IF (PRESENT(msec)) THEN
4073 msec = int(mod(this%iminuti, 1000_int_ll))
4074ENDIF
4075IF (PRESENT(sec)) THEN
4076 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
4077ENDIF
4078IF (PRESENT(minute)) THEN
4079 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
4080ENDIF
4081IF (PRESENT(hour)) THEN
4082 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
4083ENDIF
4084IF (PRESENT(day)) THEN
4085 day = int(this%iminuti/86400000_int_ll)
4086ENDIF
4087IF (PRESENT(amonth)) THEN
4088 amonth = this%month
4089ENDIF
4090IF (PRESENT(month)) THEN
4091 month = mod(this%month-1,12)+1
4092ENDIF
4093IF (PRESENT(year)) THEN
4094 year = this%month/12
4095ENDIF
4096IF (PRESENT(isodate)) THEN ! Non standard, inventato!
4097 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
4098 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), ':', &
4099 mod(this%iminuti/60000_int_ll, 60_int_ll), ':', mod(this%iminuti/1000_int_ll, 60_int_ll), &
4100 '.', mod(this%iminuti, 1000_int_ll)
4101 isodate = datebuf(1:min(len(isodate),23))
4102
4103ENDIF
4104IF (PRESENT(simpledate)) THEN
4105 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
4106 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
4107 mod(this%iminuti/60000_int_ll, 60_int_ll), mod(this%iminuti/1000_int_ll, 60_int_ll), &
4108 mod(this%iminuti, 1000_int_ll)
4109 simpledate = datebuf(1:min(len(simpledate),17))
4110ENDIF
4111IF (PRESENT(oraclesimdate)) THEN
4112!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
4113!!$ 'obsoleto, usare piuttosto simpledate')
4114 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
4115 mod(this%iminuti/3600000_int_ll, 24_int_ll), mod(this%iminuti/60000_int_ll, 60_int_ll)
4116ENDIF
4117
4118END SUBROUTINE timedelta_getval
4119
4120
4123elemental FUNCTION timedelta_to_char(this) RESULT(char)
4124TYPE(timedelta),INTENT(IN) :: this
4125
4126CHARACTER(len=23) :: char
4127
4128CALL getval(this, isodate=char)
4129
4130END FUNCTION timedelta_to_char
4131
4132
4133FUNCTION trim_timedelta_to_char(in) RESULT(char)
4134TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
4135
4136CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
4137
4138char=timedelta_to_char(in)
4139
4140END FUNCTION trim_timedelta_to_char
4141
4142
4144elemental FUNCTION timedelta_getamsec(this)
4145TYPE(timedelta),INTENT(IN) :: this
4146INTEGER(kind=int_ll) :: timedelta_getamsec
4147
4148timedelta_getamsec = this%iminuti
4149
4150END FUNCTION timedelta_getamsec
4151
4152
4158FUNCTION timedelta_depop(this)
4159TYPE(timedelta),INTENT(IN) :: this
4160TYPE(timedelta) :: timedelta_depop
4161
4162TYPE(datetime) :: tmpdt
4163
4164IF (this%month == 0) THEN
4165 timedelta_depop = this
4166ELSE
4167 tmpdt = datetime_new(1970, 1, 1)
4168 timedelta_depop = (tmpdt + this) - tmpdt
4169ENDIF
4170
4171END FUNCTION timedelta_depop
4172
4173
4174elemental FUNCTION timedelta_eq(this, that) RESULT(res)
4175TYPE(timedelta),INTENT(IN) :: this, that
4176LOGICAL :: res
4177
4178res = (this%iminuti == that%iminuti .AND. this%month == that%month)
4179
4180END FUNCTION timedelta_eq
4181
4182
4183ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
4184TYPE(timedelta),INTENT(IN) :: this, that
4185LOGICAL :: res
4186
4187res = .NOT.(this == that)
4188
4189END FUNCTION timedelta_ne
4190
4191
4192ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
4193TYPE(timedelta),INTENT(IN) :: this, that
4194LOGICAL :: res
4195
4196res = this%iminuti > that%iminuti
4197
4198END FUNCTION timedelta_gt
4199
4200
4201ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
4202TYPE(timedelta),INTENT(IN) :: this, that
4203LOGICAL :: res
4204
4205res = this%iminuti < that%iminuti
4206
4207END FUNCTION timedelta_lt
4208
4209
4210ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
4211TYPE(timedelta),INTENT(IN) :: this, that
4212LOGICAL :: res
4213
4214IF (this == that) THEN
4215 res = .true.
4216ELSE IF (this > that) THEN
4217 res = .true.
4218ELSE
4219 res = .false.
4220ENDIF
4221
4222END FUNCTION timedelta_ge
4223
4224
4225elemental FUNCTION timedelta_le(this, that) RESULT(res)
4226TYPE(timedelta),INTENT(IN) :: this, that
4227LOGICAL :: res
4228
4229IF (this == that) THEN
4230 res = .true.
4231ELSE IF (this < that) THEN
4232 res = .true.
4233ELSE
4234 res = .false.
4235ENDIF
4236
4237END FUNCTION timedelta_le
4238
4239
4240ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
4241TYPE(timedelta),INTENT(IN) :: this, that
4242TYPE(timedelta) :: res
4243
4244res%iminuti = this%iminuti + that%iminuti
4245res%month = this%month + that%month
4246
4247END FUNCTION timedelta_add
4248
4249
4250ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
4251TYPE(timedelta),INTENT(IN) :: this, that
4252TYPE(timedelta) :: res
4253
4254res%iminuti = this%iminuti - that%iminuti
4255res%month = this%month - that%month
4256
4257END FUNCTION timedelta_sub
4258
4259
4260ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
4261TYPE(timedelta),INTENT(IN) :: this
4262INTEGER,INTENT(IN) :: n
4263TYPE(timedelta) :: res
4264
4265res%iminuti = this%iminuti*n
4266res%month = this%month*n
4267
4268END FUNCTION timedelta_mult
4269
4270
4271ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
4272INTEGER,INTENT(IN) :: n
4273TYPE(timedelta),INTENT(IN) :: this
4274TYPE(timedelta) :: res
4275
4276res%iminuti = this%iminuti*n
4277res%month = this%month*n
4278
4279END FUNCTION timedelta_tlum
4280
4281
4282ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
4283TYPE(timedelta),INTENT(IN) :: this
4284INTEGER,INTENT(IN) :: n
4285TYPE(timedelta) :: res
4286
4287res%iminuti = this%iminuti/n
4288res%month = this%month/n
4289
4290END FUNCTION timedelta_divint
4291
4292
4293ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
4294TYPE(timedelta),INTENT(IN) :: this, that
4295INTEGER :: res
4296
4297res = int(this%iminuti/that%iminuti)
4298
4299END FUNCTION timedelta_divtd
4300
4301
4302elemental FUNCTION timedelta_mod(this, that) RESULT(res)
4303TYPE(timedelta),INTENT(IN) :: this, that
4304TYPE(timedelta) :: res
4305
4306res%iminuti = mod(this%iminuti, that%iminuti)
4307res%month = 0
4308
4309END FUNCTION timedelta_mod
4310
4311
4312ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
4313TYPE(datetime),INTENT(IN) :: this
4314TYPE(timedelta),INTENT(IN) :: that
4315TYPE(timedelta) :: res
4316
4317IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
4318 res = timedelta_0
4319ELSE
4320 res%iminuti = mod(this%iminuti, that%iminuti)
4321 res%month = 0
4322ENDIF
4323
4324END FUNCTION datetime_timedelta_mod
4325
4326
4327ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
4328TYPE(timedelta),INTENT(IN) :: this
4329TYPE(timedelta) :: res
4330
4331res%iminuti = abs(this%iminuti)
4332res%month = abs(this%month)
4333
4334END FUNCTION timedelta_abs
4335
4336
4341SUBROUTINE timedelta_read_unit(this, unit)
4342TYPE(timedelta),INTENT(out) :: this
4343INTEGER, INTENT(in) :: unit
4344
4345CALL timedelta_vect_read_unit((/this/), unit)
4346
4347END SUBROUTINE timedelta_read_unit
4348
4349
4354SUBROUTINE timedelta_vect_read_unit(this, unit)
4355TYPE(timedelta) :: this(:)
4356INTEGER, INTENT(in) :: unit
4357
4358CHARACTER(len=40) :: form
4359CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4360INTEGER :: i
4361
4362ALLOCATE(dateiso(SIZE(this)))
4363INQUIRE(unit, form=form)
4364IF (form == 'FORMATTED') THEN
4365 READ(unit,'(3(A23,1X))')dateiso
4366ELSE
4367 READ(unit)dateiso
4368ENDIF
4369DO i = 1, SIZE(dateiso)
4370 CALL init(this(i), isodate=dateiso(i))
4371ENDDO
4372DEALLOCATE(dateiso)
4373
4374END SUBROUTINE timedelta_vect_read_unit
4375
4376
4381SUBROUTINE timedelta_write_unit(this, unit)
4382TYPE(timedelta),INTENT(in) :: this
4383INTEGER, INTENT(in) :: unit
4384
4385CALL timedelta_vect_write_unit((/this/), unit)
4386
4387END SUBROUTINE timedelta_write_unit
4388
4389
4394SUBROUTINE timedelta_vect_write_unit(this, unit)
4395TYPE(timedelta),INTENT(in) :: this(:)
4396INTEGER, INTENT(in) :: unit
4397
4398CHARACTER(len=40) :: form
4399CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4400INTEGER :: i
4401
4402ALLOCATE(dateiso(SIZE(this)))
4403DO i = 1, SIZE(dateiso)
4404 CALL getval(this(i), isodate=dateiso(i))
4405ENDDO
4406INQUIRE(unit, form=form)
4407IF (form == 'FORMATTED') THEN
4408 WRITE(unit,'(3(A23,1X))')dateiso
4409ELSE
4410 WRITE(unit)dateiso
4411ENDIF
4412DEALLOCATE(dateiso)
4413
4414END SUBROUTINE timedelta_vect_write_unit
4415
4416
4417ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4418TYPE(timedelta),INTENT(in) :: this
4419LOGICAL :: res
4420
4421res = .not. this == timedelta_miss
4422
4423end FUNCTION c_e_timedelta
4424
4425
4426elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4427
4428!!omstart JELADATA5
4429! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4430! 1 IMINUTI)
4431!
4432! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4433!
4434! variabili integer*4
4435! IN:
4436! IDAY,IMONTH,IYEAR, I*4
4437! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4438!
4439! OUT:
4440! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4441!!OMEND
4442
4443INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4444INTEGER,intent(out) :: iminuti
4445
4446iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4447
4448END SUBROUTINE jeladata5
4449
4450
4451elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4452INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4453INTEGER(KIND=int_ll),intent(out) :: imillisec
4454
4455imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4456 + imsec
4457
4458END SUBROUTINE jeladata5_1
4459
4460
4461
4462elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4463
4464!!omstart JELADATA6
4465! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4466! 1 IMINUTI)
4467!
4468! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4469! 1/1/1
4470!
4471! variabili integer*4
4472! IN:
4473! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4474!
4475! OUT:
4476! IDAY,IMONTH,IYEAR, I*4
4477! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4478!!OMEND
4479
4480
4481INTEGER,intent(in) :: iminuti
4482INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4483
4484INTEGER ::igiorno
4485
4486imin = mod(iminuti,60)
4487ihour = mod(iminuti,1440)/60
4488igiorno = iminuti/1440
4489IF (mod(iminuti,1440) < 0) igiorno = igiorno-1
4490CALL ndyin(igiorno,iday,imonth,iyear)
4491
4492END SUBROUTINE jeladata6
4493
4494
4495elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4496INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4497INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4498
4499INTEGER :: igiorno
4500
4501imsec = int(mod(imillisec, 60000_int_ll)) ! partial msec
4502!imin = MOD(imillisec/60000_int_ll, 60)
4503!ihour = MOD(imillisec/3600000_int_ll, 24)
4504imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4505ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4506igiorno = int(imillisec/86400000_int_ll)
4507!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4508CALL ndyin(igiorno,iday,imonth,iyear)
4509
4510END SUBROUTINE jeladata6_1
4511
4512
4513elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4514
4515!!OMSTART NDYIN
4516! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4517! restituisce la data fornendo in input il numero di
4518! giorni dal 1/1/1
4519!
4520!!omend
4521
4522INTEGER,intent(in) :: ndays
4523INTEGER,intent(out) :: igg, imm, iaa
4524integer :: n,lndays
4525
4526lndays=ndays
4527
4528n = lndays/d400
4529lndays = lndays - n*d400
4530iaa = year0 + n*400
4531n = min(lndays/d100, 3)
4532lndays = lndays - n*d100
4533iaa = iaa + n*100
4534n = lndays/d4
4535lndays = lndays - n*d4
4536iaa = iaa + n*4
4537n = min(lndays/d1, 3)
4538lndays = lndays - n*d1
4539iaa = iaa + n
4540n = bisextilis(iaa)
4541DO imm = 1, 12
4542 IF (lndays < ianno(imm+1,n)) EXIT
4543ENDDO
4544igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4545
4546END SUBROUTINE ndyin
4547
4548
4549integer elemental FUNCTION ndays(igg,imm,iaa)
4550
4551!!OMSTART NDAYS
4552! FUNCTION NDAYS(IGG,IMM,IAA)
4553! restituisce il numero di giorni dal 1/1/1
4554! fornendo in input la data
4555!
4556!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4557! nota bene E' SICURO !!!
4558! un anno e' bisestile se divisibile per 4
4559! un anno rimane bisestile se divisibile per 400
4560! un anno NON e' bisestile se divisibile per 100
4561!
4562!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4563!
4564!!omend
4565
4566INTEGER, intent(in) :: igg, imm, iaa
4567
4568INTEGER :: lmonth, lyear
4569
4570! Limito il mese a [1-12] e correggo l'anno coerentemente
4571lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4572lyear = iaa + (imm - lmonth)/12
4573ndays = igg+ianno(lmonth, bisextilis(lyear))
4574ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4575 (lyear-year0)/400
4576
4577END FUNCTION ndays
4578
4579
4580elemental FUNCTION bisextilis(annum)
4581INTEGER,INTENT(in) :: annum
4582INTEGER :: bisextilis
4583
4584IF (mod(annum,4) == 0 .AND. (mod(annum,400) == 0 .EQV. mod(annum,100) == 0)) THEN
4585 bisextilis = 2
4586ELSE
4587 bisextilis = 1
4588ENDIF
4589END FUNCTION bisextilis
4590
4591
4592ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4593TYPE(cyclicdatetime),INTENT(IN) :: this, that
4594LOGICAL :: res
4595
4596res = .true.
4597if (this%minute /= that%minute) res=.false.
4598if (this%hour /= that%hour) res=.false.
4599if (this%day /= that%day) res=.false.
4600if (this%month /= that%month) res=.false.
4601if (this%tendaysp /= that%tendaysp) res=.false.
4602
4603END FUNCTION cyclicdatetime_eq
4604
4605
4606ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4607TYPE(cyclicdatetime),INTENT(IN) :: this
4608TYPE(datetime),INTENT(IN) :: that
4609LOGICAL :: res
4610
4611integer :: minute,hour,day,month
4612
4613call getval(that,minute=minute,hour=hour,day=day,month=month)
4614
4615res = .true.
4616if (c_e(this%minute) .and. this%minute /= minute) res=.false.
4617if (c_e(this%hour) .and. this%hour /= hour) res=.false.
4618if (c_e(this%day) .and. this%day /= day) res=.false.
4619if (c_e(this%month) .and. this%month /= month) res=.false.
4620if (c_e(this%tendaysp)) then
4621 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4622end if
4623
4624END FUNCTION cyclicdatetime_datetime_eq
4625
4626
4627ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4628TYPE(datetime),INTENT(IN) :: this
4629TYPE(cyclicdatetime),INTENT(IN) :: that
4630LOGICAL :: res
4631
4632integer :: minute,hour,day,month
4633
4634call getval(this,minute=minute,hour=hour,day=day,month=month)
4635
4636res = .true.
4637if (c_e(that%minute) .and. that%minute /= minute) res=.false.
4638if (c_e(that%hour) .and. that%hour /= hour) res=.false.
4639if (c_e(that%day) .and. that%day /= day) res=.false.
4640if (c_e(that%month) .and. that%month /= month) res=.false.
4641
4642if (c_e(that%tendaysp)) then
4643 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4644end if
4645
4646
4647END FUNCTION datetime_cyclicdatetime_eq
4648
4649ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4650TYPE(cyclicdatetime),INTENT(in) :: this
4651LOGICAL :: res
4652
4653res = .not. this == cyclicdatetime_miss
4654
4655end FUNCTION c_e_cyclicdatetime
4656
4657
4660FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4661INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4662INTEGER,INTENT(IN),OPTIONAL :: month
4663INTEGER,INTENT(IN),OPTIONAL :: day
4664INTEGER,INTENT(IN),OPTIONAL :: hour
4665INTEGER,INTENT(IN),OPTIONAL :: minute
4666CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4667
4668integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4669
4670
4671TYPE(cyclicdatetime) :: this
4672
4673if (present(chardate)) then
4674
4675 ltendaysp=imiss
4676 lmonth=imiss
4677 lday=imiss
4678 lhour=imiss
4679 lminute=imiss
4680
4681 if (c_e(chardate))then
4682 ! TMMGGhhmm
4683 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4684 !print*,chardate(1:1),ios,ltendaysp
4685 if (ios /= 0)ltendaysp=imiss
4686
4687 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4688 !print*,chardate(2:3),ios,lmonth
4689 if (ios /= 0)lmonth=imiss
4690
4691 read(chardate(4:5),'(i2)',iostat=ios)lday
4692 !print*,chardate(4:5),ios,lday
4693 if (ios /= 0)lday=imiss
4694
4695 read(chardate(6:7),'(i2)',iostat=ios)lhour
4696 !print*,chardate(6:7),ios,lhour
4697 if (ios /= 0)lhour=imiss
4698
4699 read(chardate(8:9),'(i2)',iostat=ios)lminute
4700 !print*,chardate(8:9),ios,lminute
4701 if (ios /= 0)lminute=imiss
4702 end if
4703
4704 this%tendaysp=ltendaysp
4705 this%month=lmonth
4706 this%day=lday
4707 this%hour=lhour
4708 this%minute=lminute
4709else
4710 this%tendaysp=optio_l(tendaysp)
4711 this%month=optio_l(month)
4712 this%day=optio_l(day)
4713 this%hour=optio_l(hour)
4714 this%minute=optio_l(minute)
4715end if
4716
4717END FUNCTION cyclicdatetime_new
4718
4721elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4722TYPE(cyclicdatetime),INTENT(IN) :: this
4723
4724CHARACTER(len=80) :: char
4725
4726char=to_char(this%tendaysp)//";"//to_char(this%month)//";"//to_char(this%day)//";"//&
4727to_char(this%hour)//";"//to_char(this%minute)
4728
4729END FUNCTION cyclicdatetime_to_char
4730
4731
4744FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4745TYPE(cyclicdatetime),INTENT(IN) :: this
4746
4747TYPE(datetime) :: dtc
4748
4749integer :: year,month,day,hour
4750
4751dtc = datetime_miss
4752
4753! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4754if ( .not. c_e(this)) then
4755 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4756 return
4757end if
4758
4759! minute present -> not good for conventional datetime
4760if (c_e(this%minute)) return
4761! day, month and tendaysp present -> no good
4762if (c_e(this%day) .and. c_e(this%month) .and. c_e(this%tendaysp)) return
4763
4764if (c_e(this%day) .and. c_e(this%month)) then
4765 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4766else if (c_e(this%tendaysp) .and. c_e(this%month)) then
4767 day=(this%tendaysp-1)*10+1
4768 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4769else if (c_e(this%month)) then
4770 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4771else if (c_e(this%day)) then
4772 ! only day present -> no good
4773 return
4774end if
4775
4776if (c_e(this%hour)) then
4777 call getval(dtc,year=year,month=month,day=day,hour=hour)
4778 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4779end if
4780
4781
4782END FUNCTION cyclicdatetime_to_conventional
4783
4784
4785
4786FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4787TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4788
4789CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4790
4791char=cyclicdatetime_to_char(in)
4792
4793END FUNCTION trim_cyclicdatetime_to_char
4794
4795
4796
4797SUBROUTINE display_cyclicdatetime(this)
4798TYPE(cyclicdatetime),INTENT(in) :: this
4799
4800print*,"CYCLICDATETIME: ",to_char(this)
4801
4802end subroutine display_cyclicdatetime
4803
4804
4805#include "array_utilities_inc.F90"
4806
4807END MODULE datetime_class
4808
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.