libsim Versione 7.1.11

◆ map_inv_distinct_datetime()

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

map inv distinct

Definizione alla linea 2883 del file datetime_class.F90.

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