libsim Versione 7.1.11
|
◆ map_distinct_datetime()
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
2827IMPLICIT NONE
2828
2829INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2830
2833 PRIVATE
2834 INTEGER(KIND=int_ll) :: iminuti
2836
2845 PRIVATE
2846 INTEGER(KIND=int_ll) :: iminuti
2847 INTEGER :: month
2849
2850
2855 PRIVATE
2856 INTEGER :: minute
2857 INTEGER :: hour
2858 INTEGER :: day
2859 INTEGER :: tendaysp
2860 INTEGER :: month
2862
2863
2871INTEGER, PARAMETER :: datetime_utc=1
2873INTEGER, PARAMETER :: datetime_local=2
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
2911 MODULE PROCEDURE datetime_init, timedelta_init
2912END INTERFACE
2913
2917 MODULE PROCEDURE datetime_delete, timedelta_delete
2918END INTERFACE
2919
2922 MODULE PROCEDURE datetime_getval, timedelta_getval
2923END INTERFACE
2924
2927 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2928END INTERFACE
2929
2930
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
3066 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3067END INTERFACE
3068
3072 MODULE PROCEDURE timedelta_abs
3073END INTERFACE
3074
3078 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3079 timedelta_read_unit, timedelta_vect_read_unit
3080END INTERFACE
3081
3085 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3086 timedelta_write_unit, timedelta_vect_write_unit
3087END INTERFACE
3088
3091 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3092END INTERFACE
3093
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
3117 datetime_min, datetime_max, &
3120 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3121 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3123 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3124 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3126 count_distinct, pack_distinct, &
3127 count_distinct_sorted, pack_distinct_sorted, &
3128 count_and_pack_distinct, &
3130 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
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
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)
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
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
3219 RETURN
3220 ELSE
3221 this = datetime_miss
3222 ENDIF
3223
3224ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
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
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
3256 CALL date_and_time(values=dt)
3257 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
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, &
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
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
3439
3440end subroutine display_datetime
3441
3442
3443
3444SUBROUTINE display_timedelta(this)
3445TYPE(timedelta),INTENT(in) :: this
3446
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
3541 minute=lminute, msec=lmsec)
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
3577 minute=lminute, msec=lmsec)
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)
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)
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
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
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
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
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
3788 this%month = this%month + month
3789 else
3790 this=timedelta_miss
3791 return
3792 end if
3793 ENDIF
3794 IF (PRESENT(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
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
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
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
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)') &
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), &
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, &
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
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)
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)
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
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
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
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
4431
4432res = .true.
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
4452
4453res = .true.
4458
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
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
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)
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
4578! day, month and tendaysp present -> no good
4580
4582 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4584 day=(this%tendaysp-1)*10+1
4585 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4587 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4589 ! only day present -> no good
4590 return
4591end if
4592
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
4618
4619end subroutine display_cyclicdatetime
4620
4621
4622#include "array_utilities_inc.F90"
4623
4625
Quick method to append an element to the array. Definition: datetime_class.F90:622 Restituiscono il valore dell'oggetto nella forma desiderata. Definition: datetime_class.F90:328 Costruttori per le classi datetime e timedelta. Definition: datetime_class.F90:317 Method for inserting elements of the array at a desired position. Definition: datetime_class.F90:613 Method for packing the array object reducing at a minimum the memory occupation, without destroying i... Definition: datetime_class.F90:645 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition: datetime_class.F90:484 Method for removing elements of the array at a desired position. Definition: datetime_class.F90:628 Functions that return a trimmed CHARACTER representation of the input variable. Definition: datetime_class.F90:355 Restituiscono il valore dell'oggetto in forma di stringa stampabile. Definition: datetime_class.F90:333 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition: datetime_class.F90:491 Definition of constants to be used for declaring variables of a desired type. Definition: kinds.F90:251 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:261 Class for expressing an absolute time value. Definition: datetime_class.F90:239 Class for expressing a relative time interval. Definition: datetime_class.F90:251 |