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