libsim Versione 7.2.1

◆ 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 2963 del file datetime_class.F90.

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

Generated with Doxygen.