libsim Versione 7.2.1

◆ map_distinct_datetime()

integer function, dimension(size(vect)) map_distinct_datetime ( type(datetime), dimension(:), intent(in) vect,
logical, dimension(:), intent(in), optional mask,
logical, intent(in), optional back )
private

map distinct

Definizione alla linea 2781 del file datetime_class.F90.

2782! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2783! authors:
2784! Davide Cesari <dcesari@arpa.emr.it>
2785! Paolo Patruno <ppatruno@arpa.emr.it>
2786
2787! This program is free software; you can redistribute it and/or
2788! modify it under the terms of the GNU General Public License as
2789! published by the Free Software Foundation; either version 2 of
2790! the License, or (at your option) any later version.
2791
2792! This program is distributed in the hope that it will be useful,
2793! but WITHOUT ANY WARRANTY; without even the implied warranty of
2794! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2795! GNU General Public License for more details.
2796
2797! You should have received a copy of the GNU General Public License
2798! along with this program. If not, see <http://www.gnu.org/licenses/>.
2799#include "config.h"
2800
2814MODULE datetime_class
2815USE kinds
2816USE log4fortran
2817USE err_handling
2821IMPLICIT NONE
2822
2823INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2824
2826TYPE datetime
2827 PRIVATE
2828 INTEGER(KIND=int_ll) :: iminuti
2829END TYPE datetime
2830
2838TYPE timedelta
2839 PRIVATE
2840 INTEGER(KIND=int_ll) :: iminuti
2841 INTEGER :: month
2842END TYPE timedelta
2843
2844
2848TYPE cyclicdatetime
2849 PRIVATE
2850 INTEGER :: minute
2851 INTEGER :: hour
2852 INTEGER :: day
2853 INTEGER :: tendaysp
2854 INTEGER :: month
2855END TYPE cyclicdatetime
2856
2857
2859TYPE(datetime), PARAMETER :: datetime_miss=datetime(illmiss)
2861TYPE(timedelta), PARAMETER :: timedelta_miss=timedelta(illmiss, 0)
2863TYPE(timedelta), PARAMETER :: timedelta_0=timedelta(0, 0)
2865INTEGER, PARAMETER :: datetime_utc=1
2867INTEGER, PARAMETER :: datetime_local=2
2869TYPE(datetime), PARAMETER :: datetime_min=datetime(-huge(1_int_ll)-1)
2871TYPE(datetime), PARAMETER :: datetime_max=datetime(huge(1_int_ll)-1)
2873TYPE(timedelta), PARAMETER :: timedelta_min=timedelta(-huge(1_int_ll)-1,0)
2875TYPE(timedelta), PARAMETER :: timedelta_max=timedelta(huge(1_int_ll)-1,0)
2877TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2878
2879
2880INTEGER(kind=dateint), PARAMETER :: &
2881 sec_in_day=86400, &
2882 sec_in_hour=3600, &
2883 sec_in_min=60, &
2884 min_in_day=1440, &
2885 min_in_hour=60, &
2886 hour_in_day=24
2887
2888INTEGER,PARAMETER :: &
2889 year0=1, & ! anno di origine per iminuti
2890 d1=365, & ! giorni/1 anno nel calendario gregoriano
2891 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2892 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2893 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2894 ianno(13,2)=reshape((/ &
2895 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2896 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2897
2898INTEGER(KIND=int_ll),PARAMETER :: &
2899 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2900
2904INTERFACE init
2905 MODULE PROCEDURE datetime_init, timedelta_init
2906END INTERFACE
2907
2910INTERFACE delete
2911 MODULE PROCEDURE datetime_delete, timedelta_delete
2912END INTERFACE
2913
2915INTERFACE getval
2916 MODULE PROCEDURE datetime_getval, timedelta_getval
2917END INTERFACE
2918
2920INTERFACE to_char
2921 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2922END INTERFACE
2923
2924
2942INTERFACE t2c
2943 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2944END INTERFACE
2945
2951INTERFACE OPERATOR (==)
2952 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2953 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2954END INTERFACE
2955
2961INTERFACE OPERATOR (/=)
2962 MODULE PROCEDURE datetime_ne, timedelta_ne
2963END INTERFACE
2964
2972INTERFACE OPERATOR (>)
2973 MODULE PROCEDURE datetime_gt, timedelta_gt
2974END INTERFACE
2975
2983INTERFACE OPERATOR (<)
2984 MODULE PROCEDURE datetime_lt, timedelta_lt
2985END INTERFACE
2986
2994INTERFACE OPERATOR (>=)
2995 MODULE PROCEDURE datetime_ge, timedelta_ge
2996END INTERFACE
2997
3005INTERFACE OPERATOR (<=)
3006 MODULE PROCEDURE datetime_le, timedelta_le
3007END INTERFACE
3008
3015INTERFACE OPERATOR (+)
3016 MODULE PROCEDURE datetime_add, timedelta_add
3017END INTERFACE
3018
3026INTERFACE OPERATOR (-)
3027 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
3028END INTERFACE
3029
3035INTERFACE OPERATOR (*)
3036 MODULE PROCEDURE timedelta_mult, timedelta_tlum
3037END INTERFACE
3038
3045INTERFACE OPERATOR (/)
3046 MODULE PROCEDURE timedelta_divint, timedelta_divtd
3047END INTERFACE
3048
3059INTERFACE mod
3060 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3061END INTERFACE
3062
3065INTERFACE abs
3066 MODULE PROCEDURE timedelta_abs
3067END INTERFACE
3068
3071INTERFACE read_unit
3072 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3073 timedelta_read_unit, timedelta_vect_read_unit
3074END INTERFACE
3075
3078INTERFACE write_unit
3079 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3080 timedelta_write_unit, timedelta_vect_write_unit
3081END INTERFACE
3082
3084INTERFACE display
3085 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3086END INTERFACE
3087
3089INTERFACE c_e
3090 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
3091END INTERFACE
3092
3093#undef VOL7D_POLY_TYPE
3094#undef VOL7D_POLY_TYPES
3095#undef ENABLE_SORT
3096#define VOL7D_POLY_TYPE TYPE(datetime)
3097#define VOL7D_POLY_TYPES _datetime
3098#define ENABLE_SORT
3099#include "array_utilities_pre.F90"
3100
3101
3102#define ARRAYOF_ORIGTYPE TYPE(datetime)
3103#define ARRAYOF_TYPE arrayof_datetime
3104#define ARRAYOF_ORIGEQ 1
3105#include "arrayof_pre.F90"
3106! from arrayof
3107
3108PRIVATE
3109
3110PUBLIC datetime, datetime_miss, datetime_utc, datetime_local, &
3111 datetime_min, datetime_max, &
3112 datetime_new, datetime_new_now, init, delete, getval, to_char, t2c, &
3114 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3115 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3116 OPERATOR(*), OPERATOR(/), mod, abs, &
3117 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3118 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3119 display, c_e, &
3120 count_distinct, pack_distinct, &
3121 count_distinct_sorted, pack_distinct_sorted, &
3122 count_and_pack_distinct, &
3123 map_distinct, map_inv_distinct, index, index_sorted, sort, &
3124 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
3125PUBLIC insert, append, remove, packarray
3126PUBLIC insert_unique, append_unique
3127PUBLIC cyclicdatetime_to_conventional
3128
3129CONTAINS
3130
3131
3132! ==============
3133! == datetime ==
3134! ==============
3135
3142ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3143 unixtime, isodate, simpledate) RESULT(this)
3144INTEGER,INTENT(IN),OPTIONAL :: year
3145INTEGER,INTENT(IN),OPTIONAL :: month
3146INTEGER,INTENT(IN),OPTIONAL :: day
3147INTEGER,INTENT(IN),OPTIONAL :: hour
3148INTEGER,INTENT(IN),OPTIONAL :: minute
3149INTEGER,INTENT(IN),OPTIONAL :: msec
3150INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3151CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3152CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3153
3154TYPE(datetime) :: this
3155INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3156CHARACTER(len=23) :: datebuf
3157
3158IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3159 lyear = year
3160 IF (PRESENT(month)) THEN
3161 lmonth = month
3162 ELSE
3163 lmonth = 1
3164 ENDIF
3165 IF (PRESENT(day)) THEN
3166 lday = day
3167 ELSE
3168 lday = 1
3169 ENDIF
3170 IF (PRESENT(hour)) THEN
3171 lhour = hour
3172 ELSE
3173 lhour = 0
3174 ENDIF
3175 IF (PRESENT(minute)) THEN
3176 lminute = minute
3177 ELSE
3178 lminute = 0
3179 ENDIF
3180 IF (PRESENT(msec)) THEN
3181 lmsec = msec
3182 ELSE
3183 lmsec = 0
3184 ENDIF
3185
3186 if (c_e(lday) .and. c_e(lmonth) .and. c_e(lyear) .and. c_e(lhour) &
3187 .and. c_e(lminute) .and. c_e(lmsec)) then
3188 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3189 else
3190 this=datetime_miss
3191 end if
3192
3193ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3194 if (c_e(unixtime)) then
3195 this%iminuti = (unixtime + unsec)*1000
3196 else
3197 this=datetime_miss
3198 end if
3199
3200ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3201
3202 IF (c_e(isodate) .AND. len_trim(isodate) > 0) THEN
3203 datebuf(1:23) = '0001-01-01 00:00:00.000'
3204 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3205 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3206 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3207 lmsec = lmsec + lsec*1000
3208 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3209 RETURN
3210
3211100 CONTINUE ! condizione di errore in isodate
3212 CALL delete(this)
3213 RETURN
3214 ELSE
3215 this = datetime_miss
3216 ENDIF
3217
3218ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3219 IF (c_e(simpledate) .AND. len_trim(simpledate) > 0)THEN
3220 datebuf(1:17) = '00010101000000000'
3221 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3222 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3223 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3224 lmsec = lmsec + lsec*1000
3225 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3226 RETURN
3227
3228120 CONTINUE ! condizione di errore in simpledate
3229 CALL delete(this)
3230 RETURN
3231 ELSE
3232 this = datetime_miss
3233 ENDIF
3234
3235ELSE
3236 this = datetime_miss
3237ENDIF
3238
3239END FUNCTION datetime_new
3240
3241
3243FUNCTION datetime_new_now(now) RESULT(this)
3244INTEGER,INTENT(IN) :: now
3245TYPE(datetime) :: this
3246
3247INTEGER :: dt(8)
3248
3249IF (c_e(now)) THEN
3250 CALL date_and_time(values=dt)
3251 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3252 CALL init(this, year=dt(1), month=dt(2), day=dt(3), hour=dt(5), minute=dt(6), &
3253 msec=dt(7)*1000+dt(8))
3254ELSE
3255 this = datetime_miss
3256ENDIF
3257
3258END FUNCTION datetime_new_now
3259
3260
3267SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3268 unixtime, isodate, simpledate, now)
3269TYPE(datetime),INTENT(INOUT) :: this
3270INTEGER,INTENT(IN),OPTIONAL :: year
3271INTEGER,INTENT(IN),OPTIONAL :: month
3272INTEGER,INTENT(IN),OPTIONAL :: day
3273INTEGER,INTENT(IN),OPTIONAL :: hour
3274INTEGER,INTENT(IN),OPTIONAL :: minute
3275INTEGER,INTENT(IN),OPTIONAL :: msec
3276INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3277CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3278CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3279INTEGER,INTENT(IN),OPTIONAL :: now
3280
3281IF (PRESENT(now)) THEN
3282 this = datetime_new_now(now)
3283ELSE
3284 this = datetime_new(year, month, day, hour, minute, msec, &
3285 unixtime, isodate, simpledate)
3286ENDIF
3287
3288END SUBROUTINE datetime_init
3289
3290
3291ELEMENTAL SUBROUTINE datetime_delete(this)
3292TYPE(datetime),INTENT(INOUT) :: this
3293
3294this%iminuti = illmiss
3295
3296END SUBROUTINE datetime_delete
3297
3298
3303PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3304 unixtime, isodate, simpledate, oraclesimdate)
3305TYPE(datetime),INTENT(IN) :: this
3306INTEGER,INTENT(OUT),OPTIONAL :: year
3307INTEGER,INTENT(OUT),OPTIONAL :: month
3308INTEGER,INTENT(OUT),OPTIONAL :: day
3309INTEGER,INTENT(OUT),OPTIONAL :: hour
3310INTEGER,INTENT(OUT),OPTIONAL :: minute
3311INTEGER,INTENT(OUT),OPTIONAL :: msec
3312INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3313CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3314CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3315CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3316
3317INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3318CHARACTER(len=23) :: datebuf
3319
3320IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3321 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3322 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3323
3324 IF (this == datetime_miss) THEN
3325
3326 IF (PRESENT(msec)) THEN
3327 msec = imiss
3328 ENDIF
3329 IF (PRESENT(minute)) THEN
3330 minute = imiss
3331 ENDIF
3332 IF (PRESENT(hour)) THEN
3333 hour = imiss
3334 ENDIF
3335 IF (PRESENT(day)) THEN
3336 day = imiss
3337 ENDIF
3338 IF (PRESENT(month)) THEN
3339 month = imiss
3340 ENDIF
3341 IF (PRESENT(year)) THEN
3342 year = imiss
3343 ENDIF
3344 IF (PRESENT(isodate)) THEN
3345 isodate = cmiss
3346 ENDIF
3347 IF (PRESENT(simpledate)) THEN
3348 simpledate = cmiss
3349 ENDIF
3350 IF (PRESENT(oraclesimdate)) THEN
3351!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3352!!$ 'obsoleto, usare piuttosto simpledate')
3353 oraclesimdate=cmiss
3354 ENDIF
3355 IF (PRESENT(unixtime)) THEN
3356 unixtime = illmiss
3357 ENDIF
3358
3359 ELSE
3360
3361 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3362 IF (PRESENT(msec)) THEN
3363 msec = lmsec
3364 ENDIF
3365 IF (PRESENT(minute)) THEN
3366 minute = lminute
3367 ENDIF
3368 IF (PRESENT(hour)) THEN
3369 hour = lhour
3370 ENDIF
3371 IF (PRESENT(day)) THEN
3372 day = lday
3373 ENDIF
3374 IF (PRESENT(month)) THEN
3375 month = lmonth
3376 ENDIF
3377 IF (PRESENT(year)) THEN
3378 year = lyear
3379 ENDIF
3380 IF (PRESENT(isodate)) THEN
3381 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3382 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3383 '.', mod(lmsec, 1000)
3384 isodate = datebuf(1:min(len(isodate),23))
3385 ENDIF
3386 IF (PRESENT(simpledate)) THEN
3387 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3388 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3389 simpledate = datebuf(1:min(len(simpledate),17))
3390 ENDIF
3391 IF (PRESENT(oraclesimdate)) THEN
3392!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3393!!$ 'obsoleto, usare piuttosto simpledate')
3394 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3395 ENDIF
3396 IF (PRESENT(unixtime)) THEN
3397 unixtime = this%iminuti/1000_int_ll-unsec
3398 ENDIF
3399
3400 ENDIF
3401ENDIF
3402
3403END SUBROUTINE datetime_getval
3404
3405
3408elemental FUNCTION datetime_to_char(this) RESULT(char)
3409TYPE(datetime),INTENT(IN) :: this
3410
3411CHARACTER(len=23) :: char
3412
3413CALL getval(this, isodate=char)
3414
3415END FUNCTION datetime_to_char
3416
3417
3418FUNCTION trim_datetime_to_char(in) RESULT(char)
3419TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3420
3421CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3422
3423char=datetime_to_char(in)
3424
3425END FUNCTION trim_datetime_to_char
3426
3427
3428
3429SUBROUTINE display_datetime(this)
3430TYPE(datetime),INTENT(in) :: this
3431
3432print*,"TIME: ",to_char(this)
3433
3434end subroutine display_datetime
3435
3436
3437
3438SUBROUTINE display_timedelta(this)
3439TYPE(timedelta),INTENT(in) :: this
3440
3441print*,"TIMEDELTA: ",to_char(this)
3442
3443end subroutine display_timedelta
3444
3445
3446
3447ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3448TYPE(datetime),INTENT(in) :: this
3449LOGICAL :: res
3450
3451res = .not. this == datetime_miss
3452
3453end FUNCTION c_e_datetime
3454
3455
3456ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3457TYPE(datetime),INTENT(IN) :: this, that
3458LOGICAL :: res
3459
3460res = this%iminuti == that%iminuti
3461
3462END FUNCTION datetime_eq
3463
3464
3465ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3466TYPE(datetime),INTENT(IN) :: this, that
3467LOGICAL :: res
3468
3469res = .NOT.(this == that)
3470
3471END FUNCTION datetime_ne
3472
3473
3474ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3475TYPE(datetime),INTENT(IN) :: this, that
3476LOGICAL :: res
3477
3478res = this%iminuti > that%iminuti
3479
3480END FUNCTION datetime_gt
3481
3482
3483ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3484TYPE(datetime),INTENT(IN) :: this, that
3485LOGICAL :: res
3486
3487res = this%iminuti < that%iminuti
3488
3489END FUNCTION datetime_lt
3490
3491
3492ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3493TYPE(datetime),INTENT(IN) :: this, that
3494LOGICAL :: res
3495
3496IF (this == that) THEN
3497 res = .true.
3498ELSE IF (this > that) THEN
3499 res = .true.
3500ELSE
3501 res = .false.
3502ENDIF
3503
3504END FUNCTION datetime_ge
3505
3506
3507ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3508TYPE(datetime),INTENT(IN) :: this, that
3509LOGICAL :: res
3510
3511IF (this == that) THEN
3512 res = .true.
3513ELSE IF (this < that) THEN
3514 res = .true.
3515ELSE
3516 res = .false.
3517ENDIF
3518
3519END FUNCTION datetime_le
3520
3521
3522FUNCTION datetime_add(this, that) RESULT(res)
3523TYPE(datetime),INTENT(IN) :: this
3524TYPE(timedelta),INTENT(IN) :: that
3525TYPE(datetime) :: res
3526
3527INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3528
3529IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3530 res = datetime_miss
3531ELSE
3532 res%iminuti = this%iminuti + that%iminuti
3533 IF (that%month /= 0) THEN
3534 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3535 minute=lminute, msec=lmsec)
3536 CALL init(res, year=lyear, month=lmonth+that%month, day=lday, &
3537 hour=lhour, minute=lminute, msec=lmsec)
3538 ENDIF
3539ENDIF
3540
3541END FUNCTION datetime_add
3542
3543
3544ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3545TYPE(datetime),INTENT(IN) :: this, that
3546TYPE(timedelta) :: res
3547
3548IF (this == datetime_miss .OR. that == datetime_miss) THEN
3549 res = timedelta_miss
3550ELSE
3551 res%iminuti = this%iminuti - that%iminuti
3552 res%month = 0
3553ENDIF
3554
3555END FUNCTION datetime_subdt
3556
3557
3558FUNCTION datetime_subtd(this, that) RESULT(res)
3559TYPE(datetime),INTENT(IN) :: this
3560TYPE(timedelta),INTENT(IN) :: that
3561TYPE(datetime) :: res
3562
3563INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3564
3565IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3566 res = datetime_miss
3567ELSE
3568 res%iminuti = this%iminuti - that%iminuti
3569 IF (that%month /= 0) THEN
3570 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3571 minute=lminute, msec=lmsec)
3572 CALL init(res, year=lyear, month=lmonth-that%month, day=lday, &
3573 hour=lhour, minute=lminute, msec=lmsec)
3574 ENDIF
3575ENDIF
3576
3577END FUNCTION datetime_subtd
3578
3579
3584SUBROUTINE datetime_read_unit(this, unit)
3585TYPE(datetime),INTENT(out) :: this
3586INTEGER, INTENT(in) :: unit
3587CALL datetime_vect_read_unit((/this/), unit)
3588
3589END SUBROUTINE datetime_read_unit
3590
3591
3596SUBROUTINE datetime_vect_read_unit(this, unit)
3597TYPE(datetime) :: this(:)
3598INTEGER, INTENT(in) :: unit
3599
3600CHARACTER(len=40) :: form
3601CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3602INTEGER :: i
3603
3604ALLOCATE(dateiso(SIZE(this)))
3605INQUIRE(unit, form=form)
3606IF (form == 'FORMATTED') THEN
3607 READ(unit,'(A23,1X)')dateiso
3608ELSE
3609 READ(unit)dateiso
3610ENDIF
3611DO i = 1, SIZE(dateiso)
3612 CALL init(this(i), isodate=dateiso(i))
3613ENDDO
3614DEALLOCATE(dateiso)
3615
3616END SUBROUTINE datetime_vect_read_unit
3617
3618
3623SUBROUTINE datetime_write_unit(this, unit)
3624TYPE(datetime),INTENT(in) :: this
3625INTEGER, INTENT(in) :: unit
3626
3627CALL datetime_vect_write_unit((/this/), unit)
3628
3629END SUBROUTINE datetime_write_unit
3630
3631
3636SUBROUTINE datetime_vect_write_unit(this, unit)
3637TYPE(datetime),INTENT(in) :: this(:)
3638INTEGER, INTENT(in) :: unit
3639
3640CHARACTER(len=40) :: form
3641CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3642INTEGER :: i
3643
3644ALLOCATE(dateiso(SIZE(this)))
3645DO i = 1, SIZE(dateiso)
3646 CALL getval(this(i), isodate=dateiso(i))
3647ENDDO
3648INQUIRE(unit, form=form)
3649IF (form == 'FORMATTED') THEN
3650 WRITE(unit,'(A23,1X)')dateiso
3651ELSE
3652 WRITE(unit)dateiso
3653ENDIF
3654DEALLOCATE(dateiso)
3655
3656END SUBROUTINE datetime_vect_write_unit
3657
3658
3659#include "arrayof_post.F90"
3660
3661
3662! ===============
3663! == timedelta ==
3664! ===============
3671FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3672 isodate, simpledate, oraclesimdate) RESULT (this)
3673INTEGER,INTENT(IN),OPTIONAL :: year
3674INTEGER,INTENT(IN),OPTIONAL :: month
3675INTEGER,INTENT(IN),OPTIONAL :: day
3676INTEGER,INTENT(IN),OPTIONAL :: hour
3677INTEGER,INTENT(IN),OPTIONAL :: minute
3678INTEGER,INTENT(IN),OPTIONAL :: sec
3679INTEGER,INTENT(IN),OPTIONAL :: msec
3680CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3681CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3682CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3683
3684TYPE(timedelta) :: this
3685
3686CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3687 isodate, simpledate, oraclesimdate)
3688
3689END FUNCTION timedelta_new
3690
3691
3696SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3697 isodate, simpledate, oraclesimdate)
3698TYPE(timedelta),INTENT(INOUT) :: this
3699INTEGER,INTENT(IN),OPTIONAL :: year
3700INTEGER,INTENT(IN),OPTIONAL :: month
3701INTEGER,INTENT(IN),OPTIONAL :: day
3702INTEGER,INTENT(IN),OPTIONAL :: hour
3703INTEGER,INTENT(IN),OPTIONAL :: minute
3704INTEGER,INTENT(IN),OPTIONAL :: sec
3705INTEGER,INTENT(IN),OPTIONAL :: msec
3706CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3707CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3708CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3709
3710INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3711CHARACTER(len=23) :: datebuf
3712
3713this%month = 0
3714
3715IF (PRESENT(isodate)) THEN
3716 datebuf(1:23) = '0000000000 00:00:00.000'
3717 l = len_trim(isodate)
3718! IF (l > 0) THEN
3719 n = index(trim(isodate), ' ') ! align blank space separator
3720 IF (n > 0) THEN
3721 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3722 datebuf(12-n:12-n+l-1) = isodate(:l)
3723 ELSE
3724 datebuf(1:l) = isodate(1:l)
3725 ENDIF
3726! ENDIF
3727
3728! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3729 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3730 h, m, s, ms
3731 this%month = lmonth + 12*lyear
3732 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3733 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3734 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3735 RETURN
3736
3737200 CONTINUE ! condizione di errore in isodate
3738 CALL delete(this)
3739 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3740 CALL raise_error()
3741
3742ELSE IF (PRESENT(simpledate)) THEN
3743 datebuf(1:17) = '00000000000000000'
3744 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3745 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3746 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3747 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3748 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3749
3750220 CONTINUE ! condizione di errore in simpledate
3751 CALL delete(this)
3752 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3753 CALL raise_error()
3754 RETURN
3755
3756ELSE IF (PRESENT(oraclesimdate)) THEN
3757 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3758 'obsoleto, usare piuttosto simpledate')
3759 READ(oraclesimdate, '(I8,2I2)')d, h, m
3760 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3761 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3762
3763ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3764 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3765 .and. .not. present(msec) .and. .not. present(isodate) &
3766 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3767
3768 this=timedelta_miss
3769
3770ELSE
3771 this%iminuti = 0
3772 IF (PRESENT(year)) THEN
3773 if (c_e(year))then
3774 this%month = this%month + year*12
3775 else
3776 this=timedelta_miss
3777 return
3778 end if
3779 ENDIF
3780 IF (PRESENT(month)) THEN
3781 if (c_e(month))then
3782 this%month = this%month + month
3783 else
3784 this=timedelta_miss
3785 return
3786 end if
3787 ENDIF
3788 IF (PRESENT(day)) THEN
3789 if (c_e(day))then
3790 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3791 else
3792 this=timedelta_miss
3793 return
3794 end if
3795 ENDIF
3796 IF (PRESENT(hour)) THEN
3797 if (c_e(hour))then
3798 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3799 else
3800 this=timedelta_miss
3801 return
3802 end if
3803 ENDIF
3804 IF (PRESENT(minute)) THEN
3805 if (c_e(minute))then
3806 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3807 else
3808 this=timedelta_miss
3809 return
3810 end if
3811 ENDIF
3812 IF (PRESENT(sec)) THEN
3813 if (c_e(sec))then
3814 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3815 else
3816 this=timedelta_miss
3817 return
3818 end if
3819 ENDIF
3820 IF (PRESENT(msec)) THEN
3821 if (c_e(msec))then
3822 this%iminuti = this%iminuti + msec
3823 else
3824 this=timedelta_miss
3825 return
3826 end if
3827 ENDIF
3828ENDIF
3829
3830
3831
3832
3833END SUBROUTINE timedelta_init
3834
3835
3836SUBROUTINE timedelta_delete(this)
3837TYPE(timedelta),INTENT(INOUT) :: this
3838
3839this%iminuti = imiss
3840this%month = 0
3841
3842END SUBROUTINE timedelta_delete
3843
3844
3849PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3850 day, hour, minute, sec, msec, &
3851 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3852TYPE(timedelta),INTENT(IN) :: this
3853INTEGER,INTENT(OUT),OPTIONAL :: year
3854INTEGER,INTENT(OUT),OPTIONAL :: month
3855INTEGER,INTENT(OUT),OPTIONAL :: amonth
3856INTEGER,INTENT(OUT),OPTIONAL :: day
3857INTEGER,INTENT(OUT),OPTIONAL :: hour
3858INTEGER,INTENT(OUT),OPTIONAL :: minute
3859INTEGER,INTENT(OUT),OPTIONAL :: sec
3860INTEGER,INTENT(OUT),OPTIONAL :: msec
3861INTEGER,INTENT(OUT),OPTIONAL :: ahour
3862INTEGER,INTENT(OUT),OPTIONAL :: aminute
3863INTEGER,INTENT(OUT),OPTIONAL :: asec
3864INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
3865CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3866CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3867CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3868
3869CHARACTER(len=23) :: datebuf
3870
3871IF (PRESENT(amsec)) THEN
3872 amsec = this%iminuti
3873ENDIF
3874IF (PRESENT(asec)) THEN
3875 asec = int(this%iminuti/1000_int_ll)
3876ENDIF
3877IF (PRESENT(aminute)) THEN
3878 aminute = int(this%iminuti/60000_int_ll)
3879ENDIF
3880IF (PRESENT(ahour)) THEN
3881 ahour = int(this%iminuti/3600000_int_ll)
3882ENDIF
3883IF (PRESENT(msec)) THEN
3884 msec = int(mod(this%iminuti, 1000_int_ll))
3885ENDIF
3886IF (PRESENT(sec)) THEN
3887 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3888ENDIF
3889IF (PRESENT(minute)) THEN
3890 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3891ENDIF
3892IF (PRESENT(hour)) THEN
3893 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3894ENDIF
3895IF (PRESENT(day)) THEN
3896 day = int(this%iminuti/86400000_int_ll)
3897ENDIF
3898IF (PRESENT(amonth)) THEN
3899 amonth = this%month
3900ENDIF
3901IF (PRESENT(month)) THEN
3902 month = mod(this%month-1,12)+1
3903ENDIF
3904IF (PRESENT(year)) THEN
3905 year = this%month/12
3906ENDIF
3907IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3908 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3909 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), ':', &
3910 mod(this%iminuti/60000_int_ll, 60_int_ll), ':', mod(this%iminuti/1000_int_ll, 60_int_ll), &
3911 '.', mod(this%iminuti, 1000_int_ll)
3912 isodate = datebuf(1:min(len(isodate),23))
3913
3914ENDIF
3915IF (PRESENT(simpledate)) THEN
3916 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3917 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3918 mod(this%iminuti/60000_int_ll, 60_int_ll), mod(this%iminuti/1000_int_ll, 60_int_ll), &
3919 mod(this%iminuti, 1000_int_ll)
3920 simpledate = datebuf(1:min(len(simpledate),17))
3921ENDIF
3922IF (PRESENT(oraclesimdate)) THEN
3923!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3924!!$ 'obsoleto, usare piuttosto simpledate')
3925 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3926 mod(this%iminuti/3600000_int_ll, 24_int_ll), mod(this%iminuti/60000_int_ll, 60_int_ll)
3927ENDIF
3928
3929END SUBROUTINE timedelta_getval
3930
3931
3934elemental FUNCTION timedelta_to_char(this) RESULT(char)
3935TYPE(timedelta),INTENT(IN) :: this
3936
3937CHARACTER(len=23) :: char
3938
3939CALL getval(this, isodate=char)
3940
3941END FUNCTION timedelta_to_char
3942
3943
3944FUNCTION trim_timedelta_to_char(in) RESULT(char)
3945TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3946
3947CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3948
3949char=timedelta_to_char(in)
3950
3951END FUNCTION trim_timedelta_to_char
3952
3953
3955elemental FUNCTION timedelta_getamsec(this)
3956TYPE(timedelta),INTENT(IN) :: this
3957INTEGER(kind=int_ll) :: timedelta_getamsec
3958
3959timedelta_getamsec = this%iminuti
3960
3961END FUNCTION timedelta_getamsec
3962
3963
3969FUNCTION timedelta_depop(this)
3970TYPE(timedelta),INTENT(IN) :: this
3971TYPE(timedelta) :: timedelta_depop
3972
3973TYPE(datetime) :: tmpdt
3974
3975IF (this%month == 0) THEN
3976 timedelta_depop = this
3977ELSE
3978 tmpdt = datetime_new(1970, 1, 1)
3979 timedelta_depop = (tmpdt + this) - tmpdt
3980ENDIF
3981
3982END FUNCTION timedelta_depop
3983
3984
3985elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3986TYPE(timedelta),INTENT(IN) :: this, that
3987LOGICAL :: res
3988
3989res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3990
3991END FUNCTION timedelta_eq
3992
3993
3994ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3995TYPE(timedelta),INTENT(IN) :: this, that
3996LOGICAL :: res
3997
3998res = .NOT.(this == that)
3999
4000END FUNCTION timedelta_ne
4001
4002
4003ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
4004TYPE(timedelta),INTENT(IN) :: this, that
4005LOGICAL :: res
4006
4007res = this%iminuti > that%iminuti
4008
4009END FUNCTION timedelta_gt
4010
4011
4012ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
4013TYPE(timedelta),INTENT(IN) :: this, that
4014LOGICAL :: res
4015
4016res = this%iminuti < that%iminuti
4017
4018END FUNCTION timedelta_lt
4019
4020
4021ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
4022TYPE(timedelta),INTENT(IN) :: this, that
4023LOGICAL :: res
4024
4025IF (this == that) THEN
4026 res = .true.
4027ELSE IF (this > that) THEN
4028 res = .true.
4029ELSE
4030 res = .false.
4031ENDIF
4032
4033END FUNCTION timedelta_ge
4034
4035
4036elemental FUNCTION timedelta_le(this, that) RESULT(res)
4037TYPE(timedelta),INTENT(IN) :: this, that
4038LOGICAL :: res
4039
4040IF (this == that) THEN
4041 res = .true.
4042ELSE IF (this < that) THEN
4043 res = .true.
4044ELSE
4045 res = .false.
4046ENDIF
4047
4048END FUNCTION timedelta_le
4049
4050
4051ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
4052TYPE(timedelta),INTENT(IN) :: this, that
4053TYPE(timedelta) :: res
4054
4055res%iminuti = this%iminuti + that%iminuti
4056res%month = this%month + that%month
4057
4058END FUNCTION timedelta_add
4059
4060
4061ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
4062TYPE(timedelta),INTENT(IN) :: this, that
4063TYPE(timedelta) :: res
4064
4065res%iminuti = this%iminuti - that%iminuti
4066res%month = this%month - that%month
4067
4068END FUNCTION timedelta_sub
4069
4070
4071ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
4072TYPE(timedelta),INTENT(IN) :: this
4073INTEGER,INTENT(IN) :: n
4074TYPE(timedelta) :: res
4075
4076res%iminuti = this%iminuti*n
4077res%month = this%month*n
4078
4079END FUNCTION timedelta_mult
4080
4081
4082ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
4083INTEGER,INTENT(IN) :: n
4084TYPE(timedelta),INTENT(IN) :: this
4085TYPE(timedelta) :: res
4086
4087res%iminuti = this%iminuti*n
4088res%month = this%month*n
4089
4090END FUNCTION timedelta_tlum
4091
4092
4093ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
4094TYPE(timedelta),INTENT(IN) :: this
4095INTEGER,INTENT(IN) :: n
4096TYPE(timedelta) :: res
4097
4098res%iminuti = this%iminuti/n
4099res%month = this%month/n
4100
4101END FUNCTION timedelta_divint
4102
4103
4104ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
4105TYPE(timedelta),INTENT(IN) :: this, that
4106INTEGER :: res
4107
4108res = int(this%iminuti/that%iminuti)
4109
4110END FUNCTION timedelta_divtd
4111
4112
4113elemental FUNCTION timedelta_mod(this, that) RESULT(res)
4114TYPE(timedelta),INTENT(IN) :: this, that
4115TYPE(timedelta) :: res
4116
4117res%iminuti = mod(this%iminuti, that%iminuti)
4118res%month = 0
4119
4120END FUNCTION timedelta_mod
4121
4122
4123ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
4124TYPE(datetime),INTENT(IN) :: this
4125TYPE(timedelta),INTENT(IN) :: that
4126TYPE(timedelta) :: res
4127
4128IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
4129 res = timedelta_0
4130ELSE
4131 res%iminuti = mod(this%iminuti, that%iminuti)
4132 res%month = 0
4133ENDIF
4134
4135END FUNCTION datetime_timedelta_mod
4136
4137
4138ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
4139TYPE(timedelta),INTENT(IN) :: this
4140TYPE(timedelta) :: res
4141
4142res%iminuti = abs(this%iminuti)
4143res%month = abs(this%month)
4144
4145END FUNCTION timedelta_abs
4146
4147
4152SUBROUTINE timedelta_read_unit(this, unit)
4153TYPE(timedelta),INTENT(out) :: this
4154INTEGER, INTENT(in) :: unit
4155
4156CALL timedelta_vect_read_unit((/this/), unit)
4157
4158END SUBROUTINE timedelta_read_unit
4159
4160
4165SUBROUTINE timedelta_vect_read_unit(this, unit)
4166TYPE(timedelta) :: this(:)
4167INTEGER, INTENT(in) :: unit
4168
4169CHARACTER(len=40) :: form
4170CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4171INTEGER :: i
4172
4173ALLOCATE(dateiso(SIZE(this)))
4174INQUIRE(unit, form=form)
4175IF (form == 'FORMATTED') THEN
4176 READ(unit,'(3(A23,1X))')dateiso
4177ELSE
4178 READ(unit)dateiso
4179ENDIF
4180DO i = 1, SIZE(dateiso)
4181 CALL init(this(i), isodate=dateiso(i))
4182ENDDO
4183DEALLOCATE(dateiso)
4184
4185END SUBROUTINE timedelta_vect_read_unit
4186
4187
4192SUBROUTINE timedelta_write_unit(this, unit)
4193TYPE(timedelta),INTENT(in) :: this
4194INTEGER, INTENT(in) :: unit
4195
4196CALL timedelta_vect_write_unit((/this/), unit)
4197
4198END SUBROUTINE timedelta_write_unit
4199
4200
4205SUBROUTINE timedelta_vect_write_unit(this, unit)
4206TYPE(timedelta),INTENT(in) :: this(:)
4207INTEGER, INTENT(in) :: unit
4208
4209CHARACTER(len=40) :: form
4210CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4211INTEGER :: i
4212
4213ALLOCATE(dateiso(SIZE(this)))
4214DO i = 1, SIZE(dateiso)
4215 CALL getval(this(i), isodate=dateiso(i))
4216ENDDO
4217INQUIRE(unit, form=form)
4218IF (form == 'FORMATTED') THEN
4219 WRITE(unit,'(3(A23,1X))')dateiso
4220ELSE
4221 WRITE(unit)dateiso
4222ENDIF
4223DEALLOCATE(dateiso)
4224
4225END SUBROUTINE timedelta_vect_write_unit
4226
4227
4228ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4229TYPE(timedelta),INTENT(in) :: this
4230LOGICAL :: res
4231
4232res = .not. this == timedelta_miss
4233
4234end FUNCTION c_e_timedelta
4235
4236
4237elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4238
4239!!omstart JELADATA5
4240! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4241! 1 IMINUTI)
4242!
4243! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4244!
4245! variabili integer*4
4246! IN:
4247! IDAY,IMONTH,IYEAR, I*4
4248! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4249!
4250! OUT:
4251! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4252!!OMEND
4253
4254INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4255INTEGER,intent(out) :: iminuti
4256
4257iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4258
4259END SUBROUTINE jeladata5
4260
4261
4262elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4263INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4264INTEGER(KIND=int_ll),intent(out) :: imillisec
4265
4266imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4267 + imsec
4268
4269END SUBROUTINE jeladata5_1
4270
4271
4272
4273elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4274
4275!!omstart JELADATA6
4276! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4277! 1 IMINUTI)
4278!
4279! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4280! 1/1/1
4281!
4282! variabili integer*4
4283! IN:
4284! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4285!
4286! OUT:
4287! IDAY,IMONTH,IYEAR, I*4
4288! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4289!!OMEND
4290
4291
4292INTEGER,intent(in) :: iminuti
4293INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4294
4295INTEGER ::igiorno
4296
4297imin = mod(iminuti,60)
4298ihour = mod(iminuti,1440)/60
4299igiorno = iminuti/1440
4300IF (mod(iminuti,1440) < 0) igiorno = igiorno-1
4301CALL ndyin(igiorno,iday,imonth,iyear)
4302
4303END SUBROUTINE jeladata6
4304
4305
4306elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4307INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4308INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4309
4310INTEGER :: igiorno
4311
4312imsec = int(mod(imillisec, 60000_int_ll)) ! partial msec
4313!imin = MOD(imillisec/60000_int_ll, 60)
4314!ihour = MOD(imillisec/3600000_int_ll, 24)
4315imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4316ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4317igiorno = int(imillisec/86400000_int_ll)
4318!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4319CALL ndyin(igiorno,iday,imonth,iyear)
4320
4321END SUBROUTINE jeladata6_1
4322
4323
4324elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4325
4326!!OMSTART NDYIN
4327! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4328! restituisce la data fornendo in input il numero di
4329! giorni dal 1/1/1
4330!
4331!!omend
4332
4333INTEGER,intent(in) :: ndays
4334INTEGER,intent(out) :: igg, imm, iaa
4335integer :: n,lndays
4336
4337lndays=ndays
4338
4339n = lndays/d400
4340lndays = lndays - n*d400
4341iaa = year0 + n*400
4342n = min(lndays/d100, 3)
4343lndays = lndays - n*d100
4344iaa = iaa + n*100
4345n = lndays/d4
4346lndays = lndays - n*d4
4347iaa = iaa + n*4
4348n = min(lndays/d1, 3)
4349lndays = lndays - n*d1
4350iaa = iaa + n
4351n = bisextilis(iaa)
4352DO imm = 1, 12
4353 IF (lndays < ianno(imm+1,n)) EXIT
4354ENDDO
4355igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4356
4357END SUBROUTINE ndyin
4358
4359
4360integer elemental FUNCTION ndays(igg,imm,iaa)
4361
4362!!OMSTART NDAYS
4363! FUNCTION NDAYS(IGG,IMM,IAA)
4364! restituisce il numero di giorni dal 1/1/1
4365! fornendo in input la data
4366!
4367!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4368! nota bene E' SICURO !!!
4369! un anno e' bisestile se divisibile per 4
4370! un anno rimane bisestile se divisibile per 400
4371! un anno NON e' bisestile se divisibile per 100
4372!
4373!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4374!
4375!!omend
4376
4377INTEGER, intent(in) :: igg, imm, iaa
4378
4379INTEGER :: lmonth, lyear
4380
4381! Limito il mese a [1-12] e correggo l'anno coerentemente
4382lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4383lyear = iaa + (imm - lmonth)/12
4384ndays = igg+ianno(lmonth, bisextilis(lyear))
4385ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4386 (lyear-year0)/400
4387
4388END FUNCTION ndays
4389
4390
4391elemental FUNCTION bisextilis(annum)
4392INTEGER,INTENT(in) :: annum
4393INTEGER :: bisextilis
4394
4395IF (mod(annum,4) == 0 .AND. (mod(annum,400) == 0 .EQV. mod(annum,100) == 0)) THEN
4396 bisextilis = 2
4397ELSE
4398 bisextilis = 1
4399ENDIF
4400END FUNCTION bisextilis
4401
4402
4403ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4404TYPE(cyclicdatetime),INTENT(IN) :: this, that
4405LOGICAL :: res
4406
4407res = .true.
4408if (this%minute /= that%minute) res=.false.
4409if (this%hour /= that%hour) res=.false.
4410if (this%day /= that%day) res=.false.
4411if (this%month /= that%month) res=.false.
4412if (this%tendaysp /= that%tendaysp) res=.false.
4413
4414END FUNCTION cyclicdatetime_eq
4415
4416
4417ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4418TYPE(cyclicdatetime),INTENT(IN) :: this
4419TYPE(datetime),INTENT(IN) :: that
4420LOGICAL :: res
4421
4422integer :: minute,hour,day,month
4423
4424call getval(that,minute=minute,hour=hour,day=day,month=month)
4425
4426res = .true.
4427if (c_e(this%minute) .and. this%minute /= minute) res=.false.
4428if (c_e(this%hour) .and. this%hour /= hour) res=.false.
4429if (c_e(this%day) .and. this%day /= day) res=.false.
4430if (c_e(this%month) .and. this%month /= month) res=.false.
4431if (c_e(this%tendaysp)) then
4432 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4433end if
4434
4435END FUNCTION cyclicdatetime_datetime_eq
4436
4437
4438ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4439TYPE(datetime),INTENT(IN) :: this
4440TYPE(cyclicdatetime),INTENT(IN) :: that
4441LOGICAL :: res
4442
4443integer :: minute,hour,day,month
4444
4445call getval(this,minute=minute,hour=hour,day=day,month=month)
4446
4447res = .true.
4448if (c_e(that%minute) .and. that%minute /= minute) res=.false.
4449if (c_e(that%hour) .and. that%hour /= hour) res=.false.
4450if (c_e(that%day) .and. that%day /= day) res=.false.
4451if (c_e(that%month) .and. that%month /= month) res=.false.
4452
4453if (c_e(that%tendaysp)) then
4454 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4455end if
4456
4457
4458END FUNCTION datetime_cyclicdatetime_eq
4459
4460ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4461TYPE(cyclicdatetime),INTENT(in) :: this
4462LOGICAL :: res
4463
4464res = .not. this == cyclicdatetime_miss
4465
4466end FUNCTION c_e_cyclicdatetime
4467
4468
4471FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4472INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4473INTEGER,INTENT(IN),OPTIONAL :: month
4474INTEGER,INTENT(IN),OPTIONAL :: day
4475INTEGER,INTENT(IN),OPTIONAL :: hour
4476INTEGER,INTENT(IN),OPTIONAL :: minute
4477CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4478
4479integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4480
4481
4482TYPE(cyclicdatetime) :: this
4483
4484if (present(chardate)) then
4485
4486 ltendaysp=imiss
4487 lmonth=imiss
4488 lday=imiss
4489 lhour=imiss
4490 lminute=imiss
4491
4492 if (c_e(chardate))then
4493 ! TMMGGhhmm
4494 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4495 !print*,chardate(1:1),ios,ltendaysp
4496 if (ios /= 0)ltendaysp=imiss
4497
4498 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4499 !print*,chardate(2:3),ios,lmonth
4500 if (ios /= 0)lmonth=imiss
4501
4502 read(chardate(4:5),'(i2)',iostat=ios)lday
4503 !print*,chardate(4:5),ios,lday
4504 if (ios /= 0)lday=imiss
4505
4506 read(chardate(6:7),'(i2)',iostat=ios)lhour
4507 !print*,chardate(6:7),ios,lhour
4508 if (ios /= 0)lhour=imiss
4509
4510 read(chardate(8:9),'(i2)',iostat=ios)lminute
4511 !print*,chardate(8:9),ios,lminute
4512 if (ios /= 0)lminute=imiss
4513 end if
4514
4515 this%tendaysp=ltendaysp
4516 this%month=lmonth
4517 this%day=lday
4518 this%hour=lhour
4519 this%minute=lminute
4520else
4521 this%tendaysp=optio_l(tendaysp)
4522 this%month=optio_l(month)
4523 this%day=optio_l(day)
4524 this%hour=optio_l(hour)
4525 this%minute=optio_l(minute)
4526end if
4527
4528END FUNCTION cyclicdatetime_new
4529
4532elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4533TYPE(cyclicdatetime),INTENT(IN) :: this
4534
4535CHARACTER(len=80) :: char
4536
4537char=to_char(this%tendaysp)//";"//to_char(this%month)//";"//to_char(this%day)//";"//&
4538to_char(this%hour)//";"//to_char(this%minute)
4539
4540END FUNCTION cyclicdatetime_to_char
4541
4542
4555FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4556TYPE(cyclicdatetime),INTENT(IN) :: this
4557
4558TYPE(datetime) :: dtc
4559
4560integer :: year,month,day,hour
4561
4562dtc = datetime_miss
4563
4564! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4565if ( .not. c_e(this)) then
4566 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4567 return
4568end if
4569
4570! minute present -> not good for conventional datetime
4571if (c_e(this%minute)) return
4572! day, month and tendaysp present -> no good
4573if (c_e(this%day) .and. c_e(this%month) .and. c_e(this%tendaysp)) return
4574
4575if (c_e(this%day) .and. c_e(this%month)) then
4576 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4577else if (c_e(this%tendaysp) .and. c_e(this%month)) then
4578 day=(this%tendaysp-1)*10+1
4579 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4580else if (c_e(this%month)) then
4581 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4582else if (c_e(this%day)) then
4583 ! only day present -> no good
4584 return
4585end if
4586
4587if (c_e(this%hour)) then
4588 call getval(dtc,year=year,month=month,day=day,hour=hour)
4589 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4590end if
4591
4592
4593END FUNCTION cyclicdatetime_to_conventional
4594
4595
4596
4597FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4598TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4599
4600CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4601
4602char=cyclicdatetime_to_char(in)
4603
4604END FUNCTION trim_cyclicdatetime_to_char
4605
4606
4607
4608SUBROUTINE display_cyclicdatetime(this)
4609TYPE(cyclicdatetime),INTENT(in) :: this
4610
4611print*,"CYCLICDATETIME: ",to_char(this)
4612
4613end subroutine display_cyclicdatetime
4614
4615
4616#include "array_utilities_inc.F90"
4617
4618END MODULE datetime_class
4619
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.