libsim Versione 7.2.1
|
◆ pack_distinct_datetime()
compatta gli elementi distinti di vect in un array Definizione alla linea 2632 del file datetime_class.F90. 2634! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2635! authors:
2636! Davide Cesari <dcesari@arpa.emr.it>
2637! Paolo Patruno <ppatruno@arpa.emr.it>
2638
2639! This program is free software; you can redistribute it and/or
2640! modify it under the terms of the GNU General Public License as
2641! published by the Free Software Foundation; either version 2 of
2642! the License, or (at your option) any later version.
2643
2644! This program is distributed in the hope that it will be useful,
2645! but WITHOUT ANY WARRANTY; without even the implied warranty of
2646! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2647! GNU General Public License for more details.
2648
2649! You should have received a copy of the GNU General Public License
2650! along with this program. If not, see <http://www.gnu.org/licenses/>.
2651#include "config.h"
2652
2673IMPLICIT NONE
2674
2675INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2676
2679 PRIVATE
2680 INTEGER(KIND=int_ll) :: iminuti
2682
2691 PRIVATE
2692 INTEGER(KIND=int_ll) :: iminuti
2693 INTEGER :: month
2695
2696
2701 PRIVATE
2702 INTEGER :: minute
2703 INTEGER :: hour
2704 INTEGER :: day
2705 INTEGER :: tendaysp
2706 INTEGER :: month
2708
2709
2717INTEGER, PARAMETER :: datetime_utc=1
2719INTEGER, PARAMETER :: datetime_local=2
2729TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2730
2731
2732INTEGER(kind=dateint), PARAMETER :: &
2733 sec_in_day=86400, &
2734 sec_in_hour=3600, &
2735 sec_in_min=60, &
2736 min_in_day=1440, &
2737 min_in_hour=60, &
2738 hour_in_day=24
2739
2740INTEGER,PARAMETER :: &
2741 year0=1, & ! anno di origine per iminuti
2742 d1=365, & ! giorni/1 anno nel calendario gregoriano
2743 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2744 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2745 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2746 ianno(13,2)=reshape((/ &
2747 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2748 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2749
2750INTEGER(KIND=int_ll),PARAMETER :: &
2751 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2752
2757 MODULE PROCEDURE datetime_init, timedelta_init
2758END INTERFACE
2759
2763 MODULE PROCEDURE datetime_delete, timedelta_delete
2764END INTERFACE
2765
2768 MODULE PROCEDURE datetime_getval, timedelta_getval
2769END INTERFACE
2770
2773 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2774END INTERFACE
2775
2776
2795 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2796END INTERFACE
2797
2803INTERFACE OPERATOR (==)
2804 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2805 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2806END INTERFACE
2807
2813INTERFACE OPERATOR (/=)
2814 MODULE PROCEDURE datetime_ne, timedelta_ne
2815END INTERFACE
2816
2824INTERFACE OPERATOR (>)
2825 MODULE PROCEDURE datetime_gt, timedelta_gt
2826END INTERFACE
2827
2835INTERFACE OPERATOR (<)
2836 MODULE PROCEDURE datetime_lt, timedelta_lt
2837END INTERFACE
2838
2846INTERFACE OPERATOR (>=)
2847 MODULE PROCEDURE datetime_ge, timedelta_ge
2848END INTERFACE
2849
2857INTERFACE OPERATOR (<=)
2858 MODULE PROCEDURE datetime_le, timedelta_le
2859END INTERFACE
2860
2867INTERFACE OPERATOR (+)
2868 MODULE PROCEDURE datetime_add, timedelta_add
2869END INTERFACE
2870
2878INTERFACE OPERATOR (-)
2879 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
2880END INTERFACE
2881
2887INTERFACE OPERATOR (*)
2888 MODULE PROCEDURE timedelta_mult, timedelta_tlum
2889END INTERFACE
2890
2897INTERFACE OPERATOR (/)
2898 MODULE PROCEDURE timedelta_divint, timedelta_divtd
2899END INTERFACE
2900
2912 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2913END INTERFACE
2914
2918 MODULE PROCEDURE timedelta_abs
2919END INTERFACE
2920
2924 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2925 timedelta_read_unit, timedelta_vect_read_unit
2926END INTERFACE
2927
2931 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2932 timedelta_write_unit, timedelta_vect_write_unit
2933END INTERFACE
2934
2937 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2938END INTERFACE
2939
2942 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
2943END INTERFACE
2944
2945#undef VOL7D_POLY_TYPE
2946#undef VOL7D_POLY_TYPES
2947#undef ENABLE_SORT
2948#define VOL7D_POLY_TYPE TYPE(datetime)
2949#define VOL7D_POLY_TYPES _datetime
2950#define ENABLE_SORT
2951#include "array_utilities_pre.F90"
2952
2953
2954#define ARRAYOF_ORIGTYPE TYPE(datetime)
2955#define ARRAYOF_TYPE arrayof_datetime
2956#define ARRAYOF_ORIGEQ 1
2957#include "arrayof_pre.F90"
2958! from arrayof
2959
2960PRIVATE
2961
2963 datetime_min, datetime_max, &
2966 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2967 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2969 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2970 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2972 count_distinct, pack_distinct, &
2973 count_distinct_sorted, pack_distinct_sorted, &
2974 count_and_pack_distinct, &
2976 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
2978PUBLIC insert_unique, append_unique
2979PUBLIC cyclicdatetime_to_conventional
2980
2981CONTAINS
2982
2983
2984! ==============
2985! == datetime ==
2986! ==============
2987
2994ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
2995 unixtime, isodate, simpledate) RESULT(this)
2996INTEGER,INTENT(IN),OPTIONAL :: year
2997INTEGER,INTENT(IN),OPTIONAL :: month
2998INTEGER,INTENT(IN),OPTIONAL :: day
2999INTEGER,INTENT(IN),OPTIONAL :: hour
3000INTEGER,INTENT(IN),OPTIONAL :: minute
3001INTEGER,INTENT(IN),OPTIONAL :: msec
3002INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3003CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3004CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3005
3006TYPE(datetime) :: this
3007INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3008CHARACTER(len=23) :: datebuf
3009
3010IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3011 lyear = year
3012 IF (PRESENT(month)) THEN
3013 lmonth = month
3014 ELSE
3015 lmonth = 1
3016 ENDIF
3017 IF (PRESENT(day)) THEN
3018 lday = day
3019 ELSE
3020 lday = 1
3021 ENDIF
3022 IF (PRESENT(hour)) THEN
3023 lhour = hour
3024 ELSE
3025 lhour = 0
3026 ENDIF
3027 IF (PRESENT(minute)) THEN
3028 lminute = minute
3029 ELSE
3030 lminute = 0
3031 ENDIF
3032 IF (PRESENT(msec)) THEN
3033 lmsec = msec
3034 ELSE
3035 lmsec = 0
3036 ENDIF
3037
3040 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3041 else
3042 this=datetime_miss
3043 end if
3044
3045ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3047 this%iminuti = (unixtime + unsec)*1000
3048 else
3049 this=datetime_miss
3050 end if
3051
3052ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3053
3055 datebuf(1:23) = '0001-01-01 00:00:00.000'
3056 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3057 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3058 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3059 lmsec = lmsec + lsec*1000
3060 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3061 RETURN
3062
3063100 CONTINUE ! condizione di errore in isodate
3065 RETURN
3066 ELSE
3067 this = datetime_miss
3068 ENDIF
3069
3070ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3072 datebuf(1:17) = '00010101000000000'
3073 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3074 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3075 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3076 lmsec = lmsec + lsec*1000
3077 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3078 RETURN
3079
3080120 CONTINUE ! condizione di errore in simpledate
3082 RETURN
3083 ELSE
3084 this = datetime_miss
3085 ENDIF
3086
3087ELSE
3088 this = datetime_miss
3089ENDIF
3090
3091END FUNCTION datetime_new
3092
3093
3095FUNCTION datetime_new_now(now) RESULT(this)
3096INTEGER,INTENT(IN) :: now
3097TYPE(datetime) :: this
3098
3099INTEGER :: dt(8)
3100
3102 CALL date_and_time(values=dt)
3103 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3105 msec=dt(7)*1000+dt(8))
3106ELSE
3107 this = datetime_miss
3108ENDIF
3109
3110END FUNCTION datetime_new_now
3111
3112
3119SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3120 unixtime, isodate, simpledate, now)
3121TYPE(datetime),INTENT(INOUT) :: this
3122INTEGER,INTENT(IN),OPTIONAL :: year
3123INTEGER,INTENT(IN),OPTIONAL :: month
3124INTEGER,INTENT(IN),OPTIONAL :: day
3125INTEGER,INTENT(IN),OPTIONAL :: hour
3126INTEGER,INTENT(IN),OPTIONAL :: minute
3127INTEGER,INTENT(IN),OPTIONAL :: msec
3128INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3129CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3130CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3131INTEGER,INTENT(IN),OPTIONAL :: now
3132
3133IF (PRESENT(now)) THEN
3134 this = datetime_new_now(now)
3135ELSE
3136 this = datetime_new(year, month, day, hour, minute, msec, &
3137 unixtime, isodate, simpledate)
3138ENDIF
3139
3140END SUBROUTINE datetime_init
3141
3142
3143ELEMENTAL SUBROUTINE datetime_delete(this)
3144TYPE(datetime),INTENT(INOUT) :: this
3145
3146this%iminuti = illmiss
3147
3148END SUBROUTINE datetime_delete
3149
3150
3155PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3156 unixtime, isodate, simpledate, oraclesimdate)
3157TYPE(datetime),INTENT(IN) :: this
3158INTEGER,INTENT(OUT),OPTIONAL :: year
3159INTEGER,INTENT(OUT),OPTIONAL :: month
3160INTEGER,INTENT(OUT),OPTIONAL :: day
3161INTEGER,INTENT(OUT),OPTIONAL :: hour
3162INTEGER,INTENT(OUT),OPTIONAL :: minute
3163INTEGER,INTENT(OUT),OPTIONAL :: msec
3164INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3165CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3166CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3167CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3168
3169INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3170CHARACTER(len=23) :: datebuf
3171
3172IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3173 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3174 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3175
3176 IF (this == datetime_miss) THEN
3177
3178 IF (PRESENT(msec)) THEN
3179 msec = imiss
3180 ENDIF
3181 IF (PRESENT(minute)) THEN
3182 minute = imiss
3183 ENDIF
3184 IF (PRESENT(hour)) THEN
3185 hour = imiss
3186 ENDIF
3187 IF (PRESENT(day)) THEN
3188 day = imiss
3189 ENDIF
3190 IF (PRESENT(month)) THEN
3191 month = imiss
3192 ENDIF
3193 IF (PRESENT(year)) THEN
3194 year = imiss
3195 ENDIF
3196 IF (PRESENT(isodate)) THEN
3197 isodate = cmiss
3198 ENDIF
3199 IF (PRESENT(simpledate)) THEN
3200 simpledate = cmiss
3201 ENDIF
3202 IF (PRESENT(oraclesimdate)) THEN
3203!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3204!!$ 'obsoleto, usare piuttosto simpledate')
3205 oraclesimdate=cmiss
3206 ENDIF
3207 IF (PRESENT(unixtime)) THEN
3208 unixtime = illmiss
3209 ENDIF
3210
3211 ELSE
3212
3213 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3214 IF (PRESENT(msec)) THEN
3215 msec = lmsec
3216 ENDIF
3217 IF (PRESENT(minute)) THEN
3218 minute = lminute
3219 ENDIF
3220 IF (PRESENT(hour)) THEN
3221 hour = lhour
3222 ENDIF
3223 IF (PRESENT(day)) THEN
3224 day = lday
3225 ENDIF
3226 IF (PRESENT(month)) THEN
3227 month = lmonth
3228 ENDIF
3229 IF (PRESENT(year)) THEN
3230 year = lyear
3231 ENDIF
3232 IF (PRESENT(isodate)) THEN
3233 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3234 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3236 isodate = datebuf(1:min(len(isodate),23))
3237 ENDIF
3238 IF (PRESENT(simpledate)) THEN
3239 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3240 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3241 simpledate = datebuf(1:min(len(simpledate),17))
3242 ENDIF
3243 IF (PRESENT(oraclesimdate)) THEN
3244!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3245!!$ 'obsoleto, usare piuttosto simpledate')
3246 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3247 ENDIF
3248 IF (PRESENT(unixtime)) THEN
3249 unixtime = this%iminuti/1000_int_ll-unsec
3250 ENDIF
3251
3252 ENDIF
3253ENDIF
3254
3255END SUBROUTINE datetime_getval
3256
3257
3260elemental FUNCTION datetime_to_char(this) RESULT(char)
3261TYPE(datetime),INTENT(IN) :: this
3262
3263CHARACTER(len=23) :: char
3264
3266
3267END FUNCTION datetime_to_char
3268
3269
3270FUNCTION trim_datetime_to_char(in) RESULT(char)
3271TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3272
3273CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3274
3275char=datetime_to_char(in)
3276
3277END FUNCTION trim_datetime_to_char
3278
3279
3280
3281SUBROUTINE display_datetime(this)
3282TYPE(datetime),INTENT(in) :: this
3283
3285
3286end subroutine display_datetime
3287
3288
3289
3290SUBROUTINE display_timedelta(this)
3291TYPE(timedelta),INTENT(in) :: this
3292
3294
3295end subroutine display_timedelta
3296
3297
3298
3299ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3300TYPE(datetime),INTENT(in) :: this
3301LOGICAL :: res
3302
3303res = .not. this == datetime_miss
3304
3305end FUNCTION c_e_datetime
3306
3307
3308ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3309TYPE(datetime),INTENT(IN) :: this, that
3310LOGICAL :: res
3311
3312res = this%iminuti == that%iminuti
3313
3314END FUNCTION datetime_eq
3315
3316
3317ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3318TYPE(datetime),INTENT(IN) :: this, that
3319LOGICAL :: res
3320
3321res = .NOT.(this == that)
3322
3323END FUNCTION datetime_ne
3324
3325
3326ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3327TYPE(datetime),INTENT(IN) :: this, that
3328LOGICAL :: res
3329
3330res = this%iminuti > that%iminuti
3331
3332END FUNCTION datetime_gt
3333
3334
3335ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3336TYPE(datetime),INTENT(IN) :: this, that
3337LOGICAL :: res
3338
3339res = this%iminuti < that%iminuti
3340
3341END FUNCTION datetime_lt
3342
3343
3344ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3345TYPE(datetime),INTENT(IN) :: this, that
3346LOGICAL :: res
3347
3348IF (this == that) THEN
3349 res = .true.
3350ELSE IF (this > that) THEN
3351 res = .true.
3352ELSE
3353 res = .false.
3354ENDIF
3355
3356END FUNCTION datetime_ge
3357
3358
3359ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3360TYPE(datetime),INTENT(IN) :: this, that
3361LOGICAL :: res
3362
3363IF (this == that) THEN
3364 res = .true.
3365ELSE IF (this < that) THEN
3366 res = .true.
3367ELSE
3368 res = .false.
3369ENDIF
3370
3371END FUNCTION datetime_le
3372
3373
3374FUNCTION datetime_add(this, that) RESULT(res)
3375TYPE(datetime),INTENT(IN) :: this
3376TYPE(timedelta),INTENT(IN) :: that
3377TYPE(datetime) :: res
3378
3379INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3380
3381IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3382 res = datetime_miss
3383ELSE
3384 res%iminuti = this%iminuti + that%iminuti
3385 IF (that%month /= 0) THEN
3387 minute=lminute, msec=lmsec)
3389 hour=lhour, minute=lminute, msec=lmsec)
3390 ENDIF
3391ENDIF
3392
3393END FUNCTION datetime_add
3394
3395
3396ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3397TYPE(datetime),INTENT(IN) :: this, that
3398TYPE(timedelta) :: res
3399
3400IF (this == datetime_miss .OR. that == datetime_miss) THEN
3401 res = timedelta_miss
3402ELSE
3403 res%iminuti = this%iminuti - that%iminuti
3404 res%month = 0
3405ENDIF
3406
3407END FUNCTION datetime_subdt
3408
3409
3410FUNCTION datetime_subtd(this, that) RESULT(res)
3411TYPE(datetime),INTENT(IN) :: this
3412TYPE(timedelta),INTENT(IN) :: that
3413TYPE(datetime) :: res
3414
3415INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3416
3417IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3418 res = datetime_miss
3419ELSE
3420 res%iminuti = this%iminuti - that%iminuti
3421 IF (that%month /= 0) THEN
3423 minute=lminute, msec=lmsec)
3425 hour=lhour, minute=lminute, msec=lmsec)
3426 ENDIF
3427ENDIF
3428
3429END FUNCTION datetime_subtd
3430
3431
3436SUBROUTINE datetime_read_unit(this, unit)
3437TYPE(datetime),INTENT(out) :: this
3438INTEGER, INTENT(in) :: unit
3439CALL datetime_vect_read_unit((/this/), unit)
3440
3441END SUBROUTINE datetime_read_unit
3442
3443
3448SUBROUTINE datetime_vect_read_unit(this, unit)
3449TYPE(datetime) :: this(:)
3450INTEGER, INTENT(in) :: unit
3451
3452CHARACTER(len=40) :: form
3453CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3454INTEGER :: i
3455
3456ALLOCATE(dateiso(SIZE(this)))
3457INQUIRE(unit, form=form)
3458IF (form == 'FORMATTED') THEN
3459 READ(unit,'(A23,1X)')dateiso
3460ELSE
3461 READ(unit)dateiso
3462ENDIF
3463DO i = 1, SIZE(dateiso)
3465ENDDO
3466DEALLOCATE(dateiso)
3467
3468END SUBROUTINE datetime_vect_read_unit
3469
3470
3475SUBROUTINE datetime_write_unit(this, unit)
3476TYPE(datetime),INTENT(in) :: this
3477INTEGER, INTENT(in) :: unit
3478
3479CALL datetime_vect_write_unit((/this/), unit)
3480
3481END SUBROUTINE datetime_write_unit
3482
3483
3488SUBROUTINE datetime_vect_write_unit(this, unit)
3489TYPE(datetime),INTENT(in) :: this(:)
3490INTEGER, INTENT(in) :: unit
3491
3492CHARACTER(len=40) :: form
3493CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3494INTEGER :: i
3495
3496ALLOCATE(dateiso(SIZE(this)))
3497DO i = 1, SIZE(dateiso)
3499ENDDO
3500INQUIRE(unit, form=form)
3501IF (form == 'FORMATTED') THEN
3502 WRITE(unit,'(A23,1X)')dateiso
3503ELSE
3504 WRITE(unit)dateiso
3505ENDIF
3506DEALLOCATE(dateiso)
3507
3508END SUBROUTINE datetime_vect_write_unit
3509
3510
3511#include "arrayof_post.F90"
3512
3513
3514! ===============
3515! == timedelta ==
3516! ===============
3523FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3524 isodate, simpledate, oraclesimdate) RESULT (this)
3525INTEGER,INTENT(IN),OPTIONAL :: year
3526INTEGER,INTENT(IN),OPTIONAL :: month
3527INTEGER,INTENT(IN),OPTIONAL :: day
3528INTEGER,INTENT(IN),OPTIONAL :: hour
3529INTEGER,INTENT(IN),OPTIONAL :: minute
3530INTEGER,INTENT(IN),OPTIONAL :: sec
3531INTEGER,INTENT(IN),OPTIONAL :: msec
3532CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3533CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3534CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3535
3536TYPE(timedelta) :: this
3537
3538CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3539 isodate, simpledate, oraclesimdate)
3540
3541END FUNCTION timedelta_new
3542
3543
3548SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3549 isodate, simpledate, oraclesimdate)
3550TYPE(timedelta),INTENT(INOUT) :: this
3551INTEGER,INTENT(IN),OPTIONAL :: year
3552INTEGER,INTENT(IN),OPTIONAL :: month
3553INTEGER,INTENT(IN),OPTIONAL :: day
3554INTEGER,INTENT(IN),OPTIONAL :: hour
3555INTEGER,INTENT(IN),OPTIONAL :: minute
3556INTEGER,INTENT(IN),OPTIONAL :: sec
3557INTEGER,INTENT(IN),OPTIONAL :: msec
3558CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3559CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3560CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3561
3562INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3563CHARACTER(len=23) :: datebuf
3564
3565this%month = 0
3566
3567IF (PRESENT(isodate)) THEN
3568 datebuf(1:23) = '0000000000 00:00:00.000'
3569 l = len_trim(isodate)
3570! IF (l > 0) THEN
3572 IF (n > 0) THEN
3573 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3574 datebuf(12-n:12-n+l-1) = isodate(:l)
3575 ELSE
3576 datebuf(1:l) = isodate(1:l)
3577 ENDIF
3578! ENDIF
3579
3580! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3581 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3582 h, m, s, ms
3583 this%month = lmonth + 12*lyear
3584 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3585 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3586 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3587 RETURN
3588
3589200 CONTINUE ! condizione di errore in isodate
3591 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3592 CALL raise_error()
3593
3594ELSE IF (PRESENT(simpledate)) THEN
3595 datebuf(1:17) = '00000000000000000'
3596 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3597 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3598 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3599 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3600 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3601
3602220 CONTINUE ! condizione di errore in simpledate
3604 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3605 CALL raise_error()
3606 RETURN
3607
3608ELSE IF (PRESENT(oraclesimdate)) THEN
3609 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3610 'obsoleto, usare piuttosto simpledate')
3611 READ(oraclesimdate, '(I8,2I2)')d, h, m
3612 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3613 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3614
3615ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3616 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3617 .and. .not. present(msec) .and. .not. present(isodate) &
3618 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3619
3620 this=timedelta_miss
3621
3622ELSE
3623 this%iminuti = 0
3624 IF (PRESENT(year)) THEN
3626 this%month = this%month + year*12
3627 else
3628 this=timedelta_miss
3629 return
3630 end if
3631 ENDIF
3632 IF (PRESENT(month)) THEN
3634 this%month = this%month + month
3635 else
3636 this=timedelta_miss
3637 return
3638 end if
3639 ENDIF
3640 IF (PRESENT(day)) THEN
3642 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3643 else
3644 this=timedelta_miss
3645 return
3646 end if
3647 ENDIF
3648 IF (PRESENT(hour)) THEN
3650 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3651 else
3652 this=timedelta_miss
3653 return
3654 end if
3655 ENDIF
3656 IF (PRESENT(minute)) THEN
3658 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3659 else
3660 this=timedelta_miss
3661 return
3662 end if
3663 ENDIF
3664 IF (PRESENT(sec)) THEN
3666 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3667 else
3668 this=timedelta_miss
3669 return
3670 end if
3671 ENDIF
3672 IF (PRESENT(msec)) THEN
3674 this%iminuti = this%iminuti + msec
3675 else
3676 this=timedelta_miss
3677 return
3678 end if
3679 ENDIF
3680ENDIF
3681
3682
3683
3684
3685END SUBROUTINE timedelta_init
3686
3687
3688SUBROUTINE timedelta_delete(this)
3689TYPE(timedelta),INTENT(INOUT) :: this
3690
3691this%iminuti = imiss
3692this%month = 0
3693
3694END SUBROUTINE timedelta_delete
3695
3696
3701PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3702 day, hour, minute, sec, msec, &
3703 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3704TYPE(timedelta),INTENT(IN) :: this
3705INTEGER,INTENT(OUT),OPTIONAL :: year
3706INTEGER,INTENT(OUT),OPTIONAL :: month
3707INTEGER,INTENT(OUT),OPTIONAL :: amonth
3708INTEGER,INTENT(OUT),OPTIONAL :: day
3709INTEGER,INTENT(OUT),OPTIONAL :: hour
3710INTEGER,INTENT(OUT),OPTIONAL :: minute
3711INTEGER,INTENT(OUT),OPTIONAL :: sec
3712INTEGER,INTENT(OUT),OPTIONAL :: msec
3713INTEGER,INTENT(OUT),OPTIONAL :: ahour
3714INTEGER,INTENT(OUT),OPTIONAL :: aminute
3715INTEGER,INTENT(OUT),OPTIONAL :: asec
3716INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
3717CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3718CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3719CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3720
3721CHARACTER(len=23) :: datebuf
3722
3723IF (PRESENT(amsec)) THEN
3724 amsec = this%iminuti
3725ENDIF
3726IF (PRESENT(asec)) THEN
3727 asec = int(this%iminuti/1000_int_ll)
3728ENDIF
3729IF (PRESENT(aminute)) THEN
3730 aminute = int(this%iminuti/60000_int_ll)
3731ENDIF
3732IF (PRESENT(ahour)) THEN
3733 ahour = int(this%iminuti/3600000_int_ll)
3734ENDIF
3735IF (PRESENT(msec)) THEN
3736 msec = int(mod(this%iminuti, 1000_int_ll))
3737ENDIF
3738IF (PRESENT(sec)) THEN
3739 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3740ENDIF
3741IF (PRESENT(minute)) THEN
3742 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3743ENDIF
3744IF (PRESENT(hour)) THEN
3745 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3746ENDIF
3747IF (PRESENT(day)) THEN
3748 day = int(this%iminuti/86400000_int_ll)
3749ENDIF
3750IF (PRESENT(amonth)) THEN
3751 amonth = this%month
3752ENDIF
3753IF (PRESENT(month)) THEN
3754 month = mod(this%month-1,12)+1
3755ENDIF
3756IF (PRESENT(year)) THEN
3757 year = this%month/12
3758ENDIF
3759IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3760 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3764 isodate = datebuf(1:min(len(isodate),23))
3765
3766ENDIF
3767IF (PRESENT(simpledate)) THEN
3768 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3769 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3771 mod(this%iminuti, 1000_int_ll)
3772 simpledate = datebuf(1:min(len(simpledate),17))
3773ENDIF
3774IF (PRESENT(oraclesimdate)) THEN
3775!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3776!!$ 'obsoleto, usare piuttosto simpledate')
3777 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3779ENDIF
3780
3781END SUBROUTINE timedelta_getval
3782
3783
3786elemental FUNCTION timedelta_to_char(this) RESULT(char)
3787TYPE(timedelta),INTENT(IN) :: this
3788
3789CHARACTER(len=23) :: char
3790
3792
3793END FUNCTION timedelta_to_char
3794
3795
3796FUNCTION trim_timedelta_to_char(in) RESULT(char)
3797TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3798
3799CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3800
3801char=timedelta_to_char(in)
3802
3803END FUNCTION trim_timedelta_to_char
3804
3805
3807elemental FUNCTION timedelta_getamsec(this)
3808TYPE(timedelta),INTENT(IN) :: this
3809INTEGER(kind=int_ll) :: timedelta_getamsec
3810
3811timedelta_getamsec = this%iminuti
3812
3813END FUNCTION timedelta_getamsec
3814
3815
3821FUNCTION timedelta_depop(this)
3822TYPE(timedelta),INTENT(IN) :: this
3823TYPE(timedelta) :: timedelta_depop
3824
3825TYPE(datetime) :: tmpdt
3826
3827IF (this%month == 0) THEN
3828 timedelta_depop = this
3829ELSE
3830 tmpdt = datetime_new(1970, 1, 1)
3831 timedelta_depop = (tmpdt + this) - tmpdt
3832ENDIF
3833
3834END FUNCTION timedelta_depop
3835
3836
3837elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3838TYPE(timedelta),INTENT(IN) :: this, that
3839LOGICAL :: res
3840
3841res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3842
3843END FUNCTION timedelta_eq
3844
3845
3846ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3847TYPE(timedelta),INTENT(IN) :: this, that
3848LOGICAL :: res
3849
3850res = .NOT.(this == that)
3851
3852END FUNCTION timedelta_ne
3853
3854
3855ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
3856TYPE(timedelta),INTENT(IN) :: this, that
3857LOGICAL :: res
3858
3859res = this%iminuti > that%iminuti
3860
3861END FUNCTION timedelta_gt
3862
3863
3864ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
3865TYPE(timedelta),INTENT(IN) :: this, that
3866LOGICAL :: res
3867
3868res = this%iminuti < that%iminuti
3869
3870END FUNCTION timedelta_lt
3871
3872
3873ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
3874TYPE(timedelta),INTENT(IN) :: this, that
3875LOGICAL :: res
3876
3877IF (this == that) THEN
3878 res = .true.
3879ELSE IF (this > that) THEN
3880 res = .true.
3881ELSE
3882 res = .false.
3883ENDIF
3884
3885END FUNCTION timedelta_ge
3886
3887
3888elemental FUNCTION timedelta_le(this, that) RESULT(res)
3889TYPE(timedelta),INTENT(IN) :: this, that
3890LOGICAL :: res
3891
3892IF (this == that) THEN
3893 res = .true.
3894ELSE IF (this < that) THEN
3895 res = .true.
3896ELSE
3897 res = .false.
3898ENDIF
3899
3900END FUNCTION timedelta_le
3901
3902
3903ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
3904TYPE(timedelta),INTENT(IN) :: this, that
3905TYPE(timedelta) :: res
3906
3907res%iminuti = this%iminuti + that%iminuti
3908res%month = this%month + that%month
3909
3910END FUNCTION timedelta_add
3911
3912
3913ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
3914TYPE(timedelta),INTENT(IN) :: this, that
3915TYPE(timedelta) :: res
3916
3917res%iminuti = this%iminuti - that%iminuti
3918res%month = this%month - that%month
3919
3920END FUNCTION timedelta_sub
3921
3922
3923ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
3924TYPE(timedelta),INTENT(IN) :: this
3925INTEGER,INTENT(IN) :: n
3926TYPE(timedelta) :: res
3927
3928res%iminuti = this%iminuti*n
3929res%month = this%month*n
3930
3931END FUNCTION timedelta_mult
3932
3933
3934ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
3935INTEGER,INTENT(IN) :: n
3936TYPE(timedelta),INTENT(IN) :: this
3937TYPE(timedelta) :: res
3938
3939res%iminuti = this%iminuti*n
3940res%month = this%month*n
3941
3942END FUNCTION timedelta_tlum
3943
3944
3945ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
3946TYPE(timedelta),INTENT(IN) :: this
3947INTEGER,INTENT(IN) :: n
3948TYPE(timedelta) :: res
3949
3950res%iminuti = this%iminuti/n
3951res%month = this%month/n
3952
3953END FUNCTION timedelta_divint
3954
3955
3956ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
3957TYPE(timedelta),INTENT(IN) :: this, that
3958INTEGER :: res
3959
3960res = int(this%iminuti/that%iminuti)
3961
3962END FUNCTION timedelta_divtd
3963
3964
3965elemental FUNCTION timedelta_mod(this, that) RESULT(res)
3966TYPE(timedelta),INTENT(IN) :: this, that
3967TYPE(timedelta) :: res
3968
3969res%iminuti = mod(this%iminuti, that%iminuti)
3970res%month = 0
3971
3972END FUNCTION timedelta_mod
3973
3974
3975ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
3976TYPE(datetime),INTENT(IN) :: this
3977TYPE(timedelta),INTENT(IN) :: that
3978TYPE(timedelta) :: res
3979
3980IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
3981 res = timedelta_0
3982ELSE
3983 res%iminuti = mod(this%iminuti, that%iminuti)
3984 res%month = 0
3985ENDIF
3986
3987END FUNCTION datetime_timedelta_mod
3988
3989
3990ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
3991TYPE(timedelta),INTENT(IN) :: this
3992TYPE(timedelta) :: res
3993
3994res%iminuti = abs(this%iminuti)
3995res%month = abs(this%month)
3996
3997END FUNCTION timedelta_abs
3998
3999
4004SUBROUTINE timedelta_read_unit(this, unit)
4005TYPE(timedelta),INTENT(out) :: this
4006INTEGER, INTENT(in) :: unit
4007
4008CALL timedelta_vect_read_unit((/this/), unit)
4009
4010END SUBROUTINE timedelta_read_unit
4011
4012
4017SUBROUTINE timedelta_vect_read_unit(this, unit)
4018TYPE(timedelta) :: this(:)
4019INTEGER, INTENT(in) :: unit
4020
4021CHARACTER(len=40) :: form
4022CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4023INTEGER :: i
4024
4025ALLOCATE(dateiso(SIZE(this)))
4026INQUIRE(unit, form=form)
4027IF (form == 'FORMATTED') THEN
4028 READ(unit,'(3(A23,1X))')dateiso
4029ELSE
4030 READ(unit)dateiso
4031ENDIF
4032DO i = 1, SIZE(dateiso)
4034ENDDO
4035DEALLOCATE(dateiso)
4036
4037END SUBROUTINE timedelta_vect_read_unit
4038
4039
4044SUBROUTINE timedelta_write_unit(this, unit)
4045TYPE(timedelta),INTENT(in) :: this
4046INTEGER, INTENT(in) :: unit
4047
4048CALL timedelta_vect_write_unit((/this/), unit)
4049
4050END SUBROUTINE timedelta_write_unit
4051
4052
4057SUBROUTINE timedelta_vect_write_unit(this, unit)
4058TYPE(timedelta),INTENT(in) :: this(:)
4059INTEGER, INTENT(in) :: unit
4060
4061CHARACTER(len=40) :: form
4062CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4063INTEGER :: i
4064
4065ALLOCATE(dateiso(SIZE(this)))
4066DO i = 1, SIZE(dateiso)
4068ENDDO
4069INQUIRE(unit, form=form)
4070IF (form == 'FORMATTED') THEN
4071 WRITE(unit,'(3(A23,1X))')dateiso
4072ELSE
4073 WRITE(unit)dateiso
4074ENDIF
4075DEALLOCATE(dateiso)
4076
4077END SUBROUTINE timedelta_vect_write_unit
4078
4079
4080ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4081TYPE(timedelta),INTENT(in) :: this
4082LOGICAL :: res
4083
4084res = .not. this == timedelta_miss
4085
4086end FUNCTION c_e_timedelta
4087
4088
4089elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4090
4091!!omstart JELADATA5
4092! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4093! 1 IMINUTI)
4094!
4095! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4096!
4097! variabili integer*4
4098! IN:
4099! IDAY,IMONTH,IYEAR, I*4
4100! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4101!
4102! OUT:
4103! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4104!!OMEND
4105
4106INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4107INTEGER,intent(out) :: iminuti
4108
4109iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4110
4111END SUBROUTINE jeladata5
4112
4113
4114elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4115INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4116INTEGER(KIND=int_ll),intent(out) :: imillisec
4117
4118imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4119 + imsec
4120
4121END SUBROUTINE jeladata5_1
4122
4123
4124
4125elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4126
4127!!omstart JELADATA6
4128! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4129! 1 IMINUTI)
4130!
4131! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4132! 1/1/1
4133!
4134! variabili integer*4
4135! IN:
4136! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4137!
4138! OUT:
4139! IDAY,IMONTH,IYEAR, I*4
4140! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4141!!OMEND
4142
4143
4144INTEGER,intent(in) :: iminuti
4145INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4146
4147INTEGER ::igiorno
4148
4149imin = mod(iminuti,60)
4150ihour = mod(iminuti,1440)/60
4151igiorno = iminuti/1440
4153CALL ndyin(igiorno,iday,imonth,iyear)
4154
4155END SUBROUTINE jeladata6
4156
4157
4158elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4159INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4160INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4161
4162INTEGER :: igiorno
4163
4165!imin = MOD(imillisec/60000_int_ll, 60)
4166!ihour = MOD(imillisec/3600000_int_ll, 24)
4167imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4168ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4169igiorno = int(imillisec/86400000_int_ll)
4170!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4171CALL ndyin(igiorno,iday,imonth,iyear)
4172
4173END SUBROUTINE jeladata6_1
4174
4175
4176elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4177
4178!!OMSTART NDYIN
4179! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4180! restituisce la data fornendo in input il numero di
4181! giorni dal 1/1/1
4182!
4183!!omend
4184
4185INTEGER,intent(in) :: ndays
4186INTEGER,intent(out) :: igg, imm, iaa
4187integer :: n,lndays
4188
4189lndays=ndays
4190
4191n = lndays/d400
4192lndays = lndays - n*d400
4193iaa = year0 + n*400
4194n = min(lndays/d100, 3)
4195lndays = lndays - n*d100
4196iaa = iaa + n*100
4197n = lndays/d4
4198lndays = lndays - n*d4
4199iaa = iaa + n*4
4200n = min(lndays/d1, 3)
4201lndays = lndays - n*d1
4202iaa = iaa + n
4203n = bisextilis(iaa)
4204DO imm = 1, 12
4205 IF (lndays < ianno(imm+1,n)) EXIT
4206ENDDO
4207igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4208
4209END SUBROUTINE ndyin
4210
4211
4212integer elemental FUNCTION ndays(igg,imm,iaa)
4213
4214!!OMSTART NDAYS
4215! FUNCTION NDAYS(IGG,IMM,IAA)
4216! restituisce il numero di giorni dal 1/1/1
4217! fornendo in input la data
4218!
4219!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4220! nota bene E' SICURO !!!
4221! un anno e' bisestile se divisibile per 4
4222! un anno rimane bisestile se divisibile per 400
4223! un anno NON e' bisestile se divisibile per 100
4224!
4225!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4226!
4227!!omend
4228
4229INTEGER, intent(in) :: igg, imm, iaa
4230
4231INTEGER :: lmonth, lyear
4232
4233! Limito il mese a [1-12] e correggo l'anno coerentemente
4234lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4235lyear = iaa + (imm - lmonth)/12
4236ndays = igg+ianno(lmonth, bisextilis(lyear))
4237ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4238 (lyear-year0)/400
4239
4240END FUNCTION ndays
4241
4242
4243elemental FUNCTION bisextilis(annum)
4244INTEGER,INTENT(in) :: annum
4245INTEGER :: bisextilis
4246
4248 bisextilis = 2
4249ELSE
4250 bisextilis = 1
4251ENDIF
4252END FUNCTION bisextilis
4253
4254
4255ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4256TYPE(cyclicdatetime),INTENT(IN) :: this, that
4257LOGICAL :: res
4258
4259res = .true.
4260if (this%minute /= that%minute) res=.false.
4261if (this%hour /= that%hour) res=.false.
4262if (this%day /= that%day) res=.false.
4263if (this%month /= that%month) res=.false.
4264if (this%tendaysp /= that%tendaysp) res=.false.
4265
4266END FUNCTION cyclicdatetime_eq
4267
4268
4269ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4270TYPE(cyclicdatetime),INTENT(IN) :: this
4271TYPE(datetime),INTENT(IN) :: that
4272LOGICAL :: res
4273
4274integer :: minute,hour,day,month
4275
4277
4278res = .true.
4284 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4285end if
4286
4287END FUNCTION cyclicdatetime_datetime_eq
4288
4289
4290ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4291TYPE(datetime),INTENT(IN) :: this
4292TYPE(cyclicdatetime),INTENT(IN) :: that
4293LOGICAL :: res
4294
4295integer :: minute,hour,day,month
4296
4298
4299res = .true.
4304
4306 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4307end if
4308
4309
4310END FUNCTION datetime_cyclicdatetime_eq
4311
4312ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4313TYPE(cyclicdatetime),INTENT(in) :: this
4314LOGICAL :: res
4315
4316res = .not. this == cyclicdatetime_miss
4317
4318end FUNCTION c_e_cyclicdatetime
4319
4320
4323FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4324INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4325INTEGER,INTENT(IN),OPTIONAL :: month
4326INTEGER,INTENT(IN),OPTIONAL :: day
4327INTEGER,INTENT(IN),OPTIONAL :: hour
4328INTEGER,INTENT(IN),OPTIONAL :: minute
4329CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4330
4331integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4332
4333
4334TYPE(cyclicdatetime) :: this
4335
4336if (present(chardate)) then
4337
4338 ltendaysp=imiss
4339 lmonth=imiss
4340 lday=imiss
4341 lhour=imiss
4342 lminute=imiss
4343
4345 ! TMMGGhhmm
4346 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4347 !print*,chardate(1:1),ios,ltendaysp
4348 if (ios /= 0)ltendaysp=imiss
4349
4350 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4351 !print*,chardate(2:3),ios,lmonth
4352 if (ios /= 0)lmonth=imiss
4353
4354 read(chardate(4:5),'(i2)',iostat=ios)lday
4355 !print*,chardate(4:5),ios,lday
4356 if (ios /= 0)lday=imiss
4357
4358 read(chardate(6:7),'(i2)',iostat=ios)lhour
4359 !print*,chardate(6:7),ios,lhour
4360 if (ios /= 0)lhour=imiss
4361
4362 read(chardate(8:9),'(i2)',iostat=ios)lminute
4363 !print*,chardate(8:9),ios,lminute
4364 if (ios /= 0)lminute=imiss
4365 end if
4366
4367 this%tendaysp=ltendaysp
4368 this%month=lmonth
4369 this%day=lday
4370 this%hour=lhour
4371 this%minute=lminute
4372else
4373 this%tendaysp=optio_l(tendaysp)
4374 this%month=optio_l(month)
4375 this%day=optio_l(day)
4376 this%hour=optio_l(hour)
4377 this%minute=optio_l(minute)
4378end if
4379
4380END FUNCTION cyclicdatetime_new
4381
4384elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4385TYPE(cyclicdatetime),INTENT(IN) :: this
4386
4387CHARACTER(len=80) :: char
4388
4391
4392END FUNCTION cyclicdatetime_to_char
4393
4394
4407FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4408TYPE(cyclicdatetime),INTENT(IN) :: this
4409
4410TYPE(datetime) :: dtc
4411
4412integer :: year,month,day,hour
4413
4414dtc = datetime_miss
4415
4416! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4418 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4419 return
4420end if
4421
4422! minute present -> not good for conventional datetime
4424! day, month and tendaysp present -> no good
4426
4428 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4430 day=(this%tendaysp-1)*10+1
4431 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4433 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4435 ! only day present -> no good
4436 return
4437end if
4438
4441 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4442end if
4443
4444
4445END FUNCTION cyclicdatetime_to_conventional
4446
4447
4448
4449FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4450TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4451
4452CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4453
4454char=cyclicdatetime_to_char(in)
4455
4456END FUNCTION trim_cyclicdatetime_to_char
4457
4458
4459
4460SUBROUTINE display_cyclicdatetime(this)
4461TYPE(cyclicdatetime),INTENT(in) :: this
4462
4464
4465end subroutine display_cyclicdatetime
4466
4467
4468#include "array_utilities_inc.F90"
4469
4471
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 |