libsim Versione 7.1.11

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

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

Generated with Doxygen.