libsim Versione 7.1.11

◆ pack_distinct_datetime()

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

compatta gli elementi distinti di vect in un array

Definizione alla linea 2638 del file datetime_class.F90.

2640! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2641! authors:
2642! Davide Cesari <dcesari@arpa.emr.it>
2643! Paolo Patruno <ppatruno@arpa.emr.it>
2644
2645! This program is free software; you can redistribute it and/or
2646! modify it under the terms of the GNU General Public License as
2647! published by the Free Software Foundation; either version 2 of
2648! the License, or (at your option) any later version.
2649
2650! This program is distributed in the hope that it will be useful,
2651! but WITHOUT ANY WARRANTY; without even the implied warranty of
2652! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2653! GNU General Public License for more details.
2654
2655! You should have received a copy of the GNU General Public License
2656! along with this program. If not, see <http://www.gnu.org/licenses/>.
2657#include "config.h"
2658
2672MODULE datetime_class
2673USE kinds
2674USE log4fortran
2675USE err_handling
2679IMPLICIT NONE
2680
2681INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2682
2684TYPE datetime
2685 PRIVATE
2686 INTEGER(KIND=int_ll) :: iminuti
2687END TYPE datetime
2688
2696TYPE timedelta
2697 PRIVATE
2698 INTEGER(KIND=int_ll) :: iminuti
2699 INTEGER :: month
2700END TYPE timedelta
2701
2702
2706TYPE cyclicdatetime
2707 PRIVATE
2708 INTEGER :: minute
2709 INTEGER :: hour
2710 INTEGER :: day
2711 INTEGER :: tendaysp
2712 INTEGER :: month
2713END TYPE cyclicdatetime
2714
2715
2717TYPE(datetime), PARAMETER :: datetime_miss=datetime(illmiss)
2719TYPE(timedelta), PARAMETER :: timedelta_miss=timedelta(illmiss, 0)
2721TYPE(timedelta), PARAMETER :: timedelta_0=timedelta(0, 0)
2723INTEGER, PARAMETER :: datetime_utc=1
2725INTEGER, PARAMETER :: datetime_local=2
2727TYPE(datetime), PARAMETER :: datetime_min=datetime(-huge(1_int_ll)-1)
2729TYPE(datetime), PARAMETER :: datetime_max=datetime(huge(1_int_ll)-1)
2731TYPE(timedelta), PARAMETER :: timedelta_min=timedelta(-huge(1_int_ll)-1,0)
2733TYPE(timedelta), PARAMETER :: timedelta_max=timedelta(huge(1_int_ll)-1,0)
2735TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2736
2737
2738INTEGER(kind=dateint), PARAMETER :: &
2739 sec_in_day=86400, &
2740 sec_in_hour=3600, &
2741 sec_in_min=60, &
2742 min_in_day=1440, &
2743 min_in_hour=60, &
2744 hour_in_day=24
2745
2746INTEGER,PARAMETER :: &
2747 year0=1, & ! anno di origine per iminuti
2748 d1=365, & ! giorni/1 anno nel calendario gregoriano
2749 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2750 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2751 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2752 ianno(13,2)=reshape((/ &
2753 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2754 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2755
2756INTEGER(KIND=int_ll),PARAMETER :: &
2757 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2758
2762INTERFACE init
2763 MODULE PROCEDURE datetime_init, timedelta_init
2764END INTERFACE
2765
2768INTERFACE delete
2769 MODULE PROCEDURE datetime_delete, timedelta_delete
2770END INTERFACE
2771
2773INTERFACE getval
2774 MODULE PROCEDURE datetime_getval, timedelta_getval
2775END INTERFACE
2776
2778INTERFACE to_char
2779 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2780END INTERFACE
2781
2782
2800INTERFACE t2c
2801 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2802END INTERFACE
2803
2809INTERFACE OPERATOR (==)
2810 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2811 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2812END INTERFACE
2813
2819INTERFACE OPERATOR (/=)
2820 MODULE PROCEDURE datetime_ne, timedelta_ne
2821END INTERFACE
2822
2830INTERFACE OPERATOR (>)
2831 MODULE PROCEDURE datetime_gt, timedelta_gt
2832END INTERFACE
2833
2841INTERFACE OPERATOR (<)
2842 MODULE PROCEDURE datetime_lt, timedelta_lt
2843END INTERFACE
2844
2852INTERFACE OPERATOR (>=)
2853 MODULE PROCEDURE datetime_ge, timedelta_ge
2854END INTERFACE
2855
2863INTERFACE OPERATOR (<=)
2864 MODULE PROCEDURE datetime_le, timedelta_le
2865END INTERFACE
2866
2873INTERFACE OPERATOR (+)
2874 MODULE PROCEDURE datetime_add, timedelta_add
2875END INTERFACE
2876
2884INTERFACE OPERATOR (-)
2885 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
2886END INTERFACE
2887
2893INTERFACE OPERATOR (*)
2894 MODULE PROCEDURE timedelta_mult, timedelta_tlum
2895END INTERFACE
2896
2903INTERFACE OPERATOR (/)
2904 MODULE PROCEDURE timedelta_divint, timedelta_divtd
2905END INTERFACE
2906
2917INTERFACE mod
2918 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2919END INTERFACE
2920
2923INTERFACE abs
2924 MODULE PROCEDURE timedelta_abs
2925END INTERFACE
2926
2929INTERFACE read_unit
2930 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2931 timedelta_read_unit, timedelta_vect_read_unit
2932END INTERFACE
2933
2936INTERFACE write_unit
2937 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2938 timedelta_write_unit, timedelta_vect_write_unit
2939END INTERFACE
2940
2942INTERFACE display
2943 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2944END INTERFACE
2945
2947INTERFACE c_e
2948 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
2949END INTERFACE
2950
2951#undef VOL7D_POLY_TYPE
2952#undef VOL7D_POLY_TYPES
2953#undef ENABLE_SORT
2954#define VOL7D_POLY_TYPE TYPE(datetime)
2955#define VOL7D_POLY_TYPES _datetime
2956#define ENABLE_SORT
2957#include "array_utilities_pre.F90"
2958
2959
2960#define ARRAYOF_ORIGTYPE TYPE(datetime)
2961#define ARRAYOF_TYPE arrayof_datetime
2962#define ARRAYOF_ORIGEQ 1
2963#include "arrayof_pre.F90"
2964! from arrayof
2965
2966PRIVATE
2967
2968PUBLIC datetime, datetime_miss, datetime_utc, datetime_local, &
2969 datetime_min, datetime_max, &
2970 datetime_new, datetime_new_now, init, delete, getval, to_char, t2c, &
2972 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2973 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2974 OPERATOR(*), OPERATOR(/), mod, abs, &
2975 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2976 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2977 display, c_e, &
2978 count_distinct, pack_distinct, &
2979 count_distinct_sorted, pack_distinct_sorted, &
2980 count_and_pack_distinct, &
2981 map_distinct, map_inv_distinct, index, index_sorted, sort, &
2982 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
2983PUBLIC insert, append, remove, packarray
2984PUBLIC insert_unique, append_unique
2985PUBLIC cyclicdatetime_to_conventional
2986
2987CONTAINS
2988
2989
2990! ==============
2991! == datetime ==
2992! ==============
2993
3000ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3001 unixtime, isodate, simpledate) RESULT(this)
3002INTEGER,INTENT(IN),OPTIONAL :: year
3003INTEGER,INTENT(IN),OPTIONAL :: month
3004INTEGER,INTENT(IN),OPTIONAL :: day
3005INTEGER,INTENT(IN),OPTIONAL :: hour
3006INTEGER,INTENT(IN),OPTIONAL :: minute
3007INTEGER,INTENT(IN),OPTIONAL :: msec
3008INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3009CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3010CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3011
3012TYPE(datetime) :: this
3013INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3014CHARACTER(len=23) :: datebuf
3015
3016IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3017 lyear = year
3018 IF (PRESENT(month)) THEN
3019 lmonth = month
3020 ELSE
3021 lmonth = 1
3022 ENDIF
3023 IF (PRESENT(day)) THEN
3024 lday = day
3025 ELSE
3026 lday = 1
3027 ENDIF
3028 IF (PRESENT(hour)) THEN
3029 lhour = hour
3030 ELSE
3031 lhour = 0
3032 ENDIF
3033 IF (PRESENT(minute)) THEN
3034 lminute = minute
3035 ELSE
3036 lminute = 0
3037 ENDIF
3038 IF (PRESENT(msec)) THEN
3039 lmsec = msec
3040 ELSE
3041 lmsec = 0
3042 ENDIF
3043
3044 if (c_e(lday) .and. c_e(lmonth) .and. c_e(lyear) .and. c_e(lhour) &
3045 .and. c_e(lminute) .and. c_e(lmsec)) then
3046 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3047 else
3048 this=datetime_miss
3049 end if
3050
3051ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3052 if (c_e(unixtime)) then
3053 this%iminuti = (unixtime + unsec)*1000
3054 else
3055 this=datetime_miss
3056 end if
3057
3058ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3059
3060 IF (c_e(isodate) .AND. len_trim(isodate) > 0) THEN
3061 datebuf(1:23) = '0001-01-01 00:00:00.000'
3062 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3063 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3064 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3065 lmsec = lmsec + lsec*1000
3066 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3067 RETURN
3068
3069100 CONTINUE ! condizione di errore in isodate
3070 CALL delete(this)
3071 RETURN
3072 ELSE
3073 this = datetime_miss
3074 ENDIF
3075
3076ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3077 IF (c_e(simpledate) .AND. len_trim(simpledate) > 0)THEN
3078 datebuf(1:17) = '00010101000000000'
3079 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3080 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3081 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3082 lmsec = lmsec + lsec*1000
3083 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3084 RETURN
3085
3086120 CONTINUE ! condizione di errore in simpledate
3087 CALL delete(this)
3088 RETURN
3089 ELSE
3090 this = datetime_miss
3091 ENDIF
3092
3093ELSE
3094 this = datetime_miss
3095ENDIF
3096
3097END FUNCTION datetime_new
3098
3099
3101FUNCTION datetime_new_now(now) RESULT(this)
3102INTEGER,INTENT(IN) :: now
3103TYPE(datetime) :: this
3104
3105INTEGER :: dt(8)
3106
3107IF (c_e(now)) THEN
3108 CALL date_and_time(values=dt)
3109 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3110 CALL init(this, year=dt(1), month=dt(2), day=dt(3), hour=dt(5), minute=dt(6), &
3111 msec=dt(7)*1000+dt(8))
3112ELSE
3113 this = datetime_miss
3114ENDIF
3115
3116END FUNCTION datetime_new_now
3117
3118
3125SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3126 unixtime, isodate, simpledate, now)
3127TYPE(datetime),INTENT(INOUT) :: this
3128INTEGER,INTENT(IN),OPTIONAL :: year
3129INTEGER,INTENT(IN),OPTIONAL :: month
3130INTEGER,INTENT(IN),OPTIONAL :: day
3131INTEGER,INTENT(IN),OPTIONAL :: hour
3132INTEGER,INTENT(IN),OPTIONAL :: minute
3133INTEGER,INTENT(IN),OPTIONAL :: msec
3134INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3135CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3136CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3137INTEGER,INTENT(IN),OPTIONAL :: now
3138
3139IF (PRESENT(now)) THEN
3140 this = datetime_new_now(now)
3141ELSE
3142 this = datetime_new(year, month, day, hour, minute, msec, &
3143 unixtime, isodate, simpledate)
3144ENDIF
3145
3146END SUBROUTINE datetime_init
3147
3148
3149ELEMENTAL SUBROUTINE datetime_delete(this)
3150TYPE(datetime),INTENT(INOUT) :: this
3151
3152this%iminuti = illmiss
3153
3154END SUBROUTINE datetime_delete
3155
3156
3161PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3162 unixtime, isodate, simpledate, oraclesimdate)
3163TYPE(datetime),INTENT(IN) :: this
3164INTEGER,INTENT(OUT),OPTIONAL :: year
3165INTEGER,INTENT(OUT),OPTIONAL :: month
3166INTEGER,INTENT(OUT),OPTIONAL :: day
3167INTEGER,INTENT(OUT),OPTIONAL :: hour
3168INTEGER,INTENT(OUT),OPTIONAL :: minute
3169INTEGER,INTENT(OUT),OPTIONAL :: msec
3170INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3171CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3172CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3173CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3174
3175INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3176CHARACTER(len=23) :: datebuf
3177
3178IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3179 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3180 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3181
3182 IF (this == datetime_miss) THEN
3183
3184 IF (PRESENT(msec)) THEN
3185 msec = imiss
3186 ENDIF
3187 IF (PRESENT(minute)) THEN
3188 minute = imiss
3189 ENDIF
3190 IF (PRESENT(hour)) THEN
3191 hour = imiss
3192 ENDIF
3193 IF (PRESENT(day)) THEN
3194 day = imiss
3195 ENDIF
3196 IF (PRESENT(month)) THEN
3197 month = imiss
3198 ENDIF
3199 IF (PRESENT(year)) THEN
3200 year = imiss
3201 ENDIF
3202 IF (PRESENT(isodate)) THEN
3203 isodate = cmiss
3204 ENDIF
3205 IF (PRESENT(simpledate)) THEN
3206 simpledate = cmiss
3207 ENDIF
3208 IF (PRESENT(oraclesimdate)) THEN
3209!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3210!!$ 'obsoleto, usare piuttosto simpledate')
3211 oraclesimdate=cmiss
3212 ENDIF
3213 IF (PRESENT(unixtime)) THEN
3214 unixtime = illmiss
3215 ENDIF
3216
3217 ELSE
3218
3219 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3220 IF (PRESENT(msec)) THEN
3221 msec = lmsec
3222 ENDIF
3223 IF (PRESENT(minute)) THEN
3224 minute = lminute
3225 ENDIF
3226 IF (PRESENT(hour)) THEN
3227 hour = lhour
3228 ENDIF
3229 IF (PRESENT(day)) THEN
3230 day = lday
3231 ENDIF
3232 IF (PRESENT(month)) THEN
3233 month = lmonth
3234 ENDIF
3235 IF (PRESENT(year)) THEN
3236 year = lyear
3237 ENDIF
3238 IF (PRESENT(isodate)) THEN
3239 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3240 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3241 '.', mod(lmsec, 1000)
3242 isodate = datebuf(1:min(len(isodate),23))
3243 ENDIF
3244 IF (PRESENT(simpledate)) THEN
3245 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3246 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3247 simpledate = datebuf(1:min(len(simpledate),17))
3248 ENDIF
3249 IF (PRESENT(oraclesimdate)) THEN
3250!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3251!!$ 'obsoleto, usare piuttosto simpledate')
3252 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3253 ENDIF
3254 IF (PRESENT(unixtime)) THEN
3255 unixtime = this%iminuti/1000_int_ll-unsec
3256 ENDIF
3257
3258 ENDIF
3259ENDIF
3260
3261END SUBROUTINE datetime_getval
3262
3263
3266elemental FUNCTION datetime_to_char(this) RESULT(char)
3267TYPE(datetime),INTENT(IN) :: this
3268
3269CHARACTER(len=23) :: char
3270
3271CALL getval(this, isodate=char)
3272
3273END FUNCTION datetime_to_char
3274
3275
3276FUNCTION trim_datetime_to_char(in) RESULT(char)
3277TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3278
3279CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3280
3281char=datetime_to_char(in)
3282
3283END FUNCTION trim_datetime_to_char
3284
3285
3286
3287SUBROUTINE display_datetime(this)
3288TYPE(datetime),INTENT(in) :: this
3289
3290print*,"TIME: ",to_char(this)
3291
3292end subroutine display_datetime
3293
3294
3295
3296SUBROUTINE display_timedelta(this)
3297TYPE(timedelta),INTENT(in) :: this
3298
3299print*,"TIMEDELTA: ",to_char(this)
3300
3301end subroutine display_timedelta
3302
3303
3304
3305ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3306TYPE(datetime),INTENT(in) :: this
3307LOGICAL :: res
3308
3309res = .not. this == datetime_miss
3310
3311end FUNCTION c_e_datetime
3312
3313
3314ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3315TYPE(datetime),INTENT(IN) :: this, that
3316LOGICAL :: res
3317
3318res = this%iminuti == that%iminuti
3319
3320END FUNCTION datetime_eq
3321
3322
3323ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3324TYPE(datetime),INTENT(IN) :: this, that
3325LOGICAL :: res
3326
3327res = .NOT.(this == that)
3328
3329END FUNCTION datetime_ne
3330
3331
3332ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3333TYPE(datetime),INTENT(IN) :: this, that
3334LOGICAL :: res
3335
3336res = this%iminuti > that%iminuti
3337
3338END FUNCTION datetime_gt
3339
3340
3341ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3342TYPE(datetime),INTENT(IN) :: this, that
3343LOGICAL :: res
3344
3345res = this%iminuti < that%iminuti
3346
3347END FUNCTION datetime_lt
3348
3349
3350ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3351TYPE(datetime),INTENT(IN) :: this, that
3352LOGICAL :: res
3353
3354IF (this == that) THEN
3355 res = .true.
3356ELSE IF (this > that) THEN
3357 res = .true.
3358ELSE
3359 res = .false.
3360ENDIF
3361
3362END FUNCTION datetime_ge
3363
3364
3365ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3366TYPE(datetime),INTENT(IN) :: this, that
3367LOGICAL :: res
3368
3369IF (this == that) THEN
3370 res = .true.
3371ELSE IF (this < that) THEN
3372 res = .true.
3373ELSE
3374 res = .false.
3375ENDIF
3376
3377END FUNCTION datetime_le
3378
3379
3380FUNCTION datetime_add(this, that) RESULT(res)
3381TYPE(datetime),INTENT(IN) :: this
3382TYPE(timedelta),INTENT(IN) :: that
3383TYPE(datetime) :: res
3384
3385INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3386
3387IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3388 res = datetime_miss
3389ELSE
3390 res%iminuti = this%iminuti + that%iminuti
3391 IF (that%month /= 0) THEN
3392 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3393 minute=lminute, msec=lmsec)
3394 CALL init(res, year=lyear, month=lmonth+that%month, day=lday, &
3395 hour=lhour, minute=lminute, msec=lmsec)
3396 ENDIF
3397ENDIF
3398
3399END FUNCTION datetime_add
3400
3401
3402ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3403TYPE(datetime),INTENT(IN) :: this, that
3404TYPE(timedelta) :: res
3405
3406IF (this == datetime_miss .OR. that == datetime_miss) THEN
3407 res = timedelta_miss
3408ELSE
3409 res%iminuti = this%iminuti - that%iminuti
3410 res%month = 0
3411ENDIF
3412
3413END FUNCTION datetime_subdt
3414
3415
3416FUNCTION datetime_subtd(this, that) RESULT(res)
3417TYPE(datetime),INTENT(IN) :: this
3418TYPE(timedelta),INTENT(IN) :: that
3419TYPE(datetime) :: res
3420
3421INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3422
3423IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3424 res = datetime_miss
3425ELSE
3426 res%iminuti = this%iminuti - that%iminuti
3427 IF (that%month /= 0) THEN
3428 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3429 minute=lminute, msec=lmsec)
3430 CALL init(res, year=lyear, month=lmonth-that%month, day=lday, &
3431 hour=lhour, minute=lminute, msec=lmsec)
3432 ENDIF
3433ENDIF
3434
3435END FUNCTION datetime_subtd
3436
3437
3442SUBROUTINE datetime_read_unit(this, unit)
3443TYPE(datetime),INTENT(out) :: this
3444INTEGER, INTENT(in) :: unit
3445CALL datetime_vect_read_unit((/this/), unit)
3446
3447END SUBROUTINE datetime_read_unit
3448
3449
3454SUBROUTINE datetime_vect_read_unit(this, unit)
3455TYPE(datetime) :: this(:)
3456INTEGER, INTENT(in) :: unit
3457
3458CHARACTER(len=40) :: form
3459CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3460INTEGER :: i
3461
3462ALLOCATE(dateiso(SIZE(this)))
3463INQUIRE(unit, form=form)
3464IF (form == 'FORMATTED') THEN
3465 READ(unit,'(A23,1X)')dateiso
3466ELSE
3467 READ(unit)dateiso
3468ENDIF
3469DO i = 1, SIZE(dateiso)
3470 CALL init(this(i), isodate=dateiso(i))
3471ENDDO
3472DEALLOCATE(dateiso)
3473
3474END SUBROUTINE datetime_vect_read_unit
3475
3476
3481SUBROUTINE datetime_write_unit(this, unit)
3482TYPE(datetime),INTENT(in) :: this
3483INTEGER, INTENT(in) :: unit
3484
3485CALL datetime_vect_write_unit((/this/), unit)
3486
3487END SUBROUTINE datetime_write_unit
3488
3489
3494SUBROUTINE datetime_vect_write_unit(this, unit)
3495TYPE(datetime),INTENT(in) :: this(:)
3496INTEGER, INTENT(in) :: unit
3497
3498CHARACTER(len=40) :: form
3499CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3500INTEGER :: i
3501
3502ALLOCATE(dateiso(SIZE(this)))
3503DO i = 1, SIZE(dateiso)
3504 CALL getval(this(i), isodate=dateiso(i))
3505ENDDO
3506INQUIRE(unit, form=form)
3507IF (form == 'FORMATTED') THEN
3508 WRITE(unit,'(A23,1X)')dateiso
3509ELSE
3510 WRITE(unit)dateiso
3511ENDIF
3512DEALLOCATE(dateiso)
3513
3514END SUBROUTINE datetime_vect_write_unit
3515
3516
3517#include "arrayof_post.F90"
3518
3519
3520! ===============
3521! == timedelta ==
3522! ===============
3529FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3530 isodate, simpledate, oraclesimdate) RESULT (this)
3531INTEGER,INTENT(IN),OPTIONAL :: year
3532INTEGER,INTENT(IN),OPTIONAL :: month
3533INTEGER,INTENT(IN),OPTIONAL :: day
3534INTEGER,INTENT(IN),OPTIONAL :: hour
3535INTEGER,INTENT(IN),OPTIONAL :: minute
3536INTEGER,INTENT(IN),OPTIONAL :: sec
3537INTEGER,INTENT(IN),OPTIONAL :: msec
3538CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3539CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3540CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3541
3542TYPE(timedelta) :: this
3543
3544CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3545 isodate, simpledate, oraclesimdate)
3546
3547END FUNCTION timedelta_new
3548
3549
3554SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3555 isodate, simpledate, oraclesimdate)
3556TYPE(timedelta),INTENT(INOUT) :: this
3557INTEGER,INTENT(IN),OPTIONAL :: year
3558INTEGER,INTENT(IN),OPTIONAL :: month
3559INTEGER,INTENT(IN),OPTIONAL :: day
3560INTEGER,INTENT(IN),OPTIONAL :: hour
3561INTEGER,INTENT(IN),OPTIONAL :: minute
3562INTEGER,INTENT(IN),OPTIONAL :: sec
3563INTEGER,INTENT(IN),OPTIONAL :: msec
3564CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3565CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3566CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3567
3568INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3569CHARACTER(len=23) :: datebuf
3570
3571this%month = 0
3572
3573IF (PRESENT(isodate)) THEN
3574 datebuf(1:23) = '0000000000 00:00:00.000'
3575 l = len_trim(isodate)
3576! IF (l > 0) THEN
3577 n = index(trim(isodate), ' ') ! align blank space separator
3578 IF (n > 0) THEN
3579 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3580 datebuf(12-n:12-n+l-1) = isodate(:l)
3581 ELSE
3582 datebuf(1:l) = isodate(1:l)
3583 ENDIF
3584! ENDIF
3585
3586! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3587 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3588 h, m, s, ms
3589 this%month = lmonth + 12*lyear
3590 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3591 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3592 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3593 RETURN
3594
3595200 CONTINUE ! condizione di errore in isodate
3596 CALL delete(this)
3597 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3598 CALL raise_error()
3599
3600ELSE IF (PRESENT(simpledate)) THEN
3601 datebuf(1:17) = '00000000000000000'
3602 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3603 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3604 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3605 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3606 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3607
3608220 CONTINUE ! condizione di errore in simpledate
3609 CALL delete(this)
3610 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3611 CALL raise_error()
3612 RETURN
3613
3614ELSE IF (PRESENT(oraclesimdate)) THEN
3615 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3616 'obsoleto, usare piuttosto simpledate')
3617 READ(oraclesimdate, '(I8,2I2)')d, h, m
3618 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3619 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3620
3621ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3622 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3623 .and. .not. present(msec) .and. .not. present(isodate) &
3624 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3625
3626 this=timedelta_miss
3627
3628ELSE
3629 this%iminuti = 0
3630 IF (PRESENT(year)) THEN
3631 if (c_e(year))then
3632 this%month = this%month + year*12
3633 else
3634 this=timedelta_miss
3635 return
3636 end if
3637 ENDIF
3638 IF (PRESENT(month)) THEN
3639 if (c_e(month))then
3640 this%month = this%month + month
3641 else
3642 this=timedelta_miss
3643 return
3644 end if
3645 ENDIF
3646 IF (PRESENT(day)) THEN
3647 if (c_e(day))then
3648 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3649 else
3650 this=timedelta_miss
3651 return
3652 end if
3653 ENDIF
3654 IF (PRESENT(hour)) THEN
3655 if (c_e(hour))then
3656 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3657 else
3658 this=timedelta_miss
3659 return
3660 end if
3661 ENDIF
3662 IF (PRESENT(minute)) THEN
3663 if (c_e(minute))then
3664 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3665 else
3666 this=timedelta_miss
3667 return
3668 end if
3669 ENDIF
3670 IF (PRESENT(sec)) THEN
3671 if (c_e(sec))then
3672 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3673 else
3674 this=timedelta_miss
3675 return
3676 end if
3677 ENDIF
3678 IF (PRESENT(msec)) THEN
3679 if (c_e(msec))then
3680 this%iminuti = this%iminuti + msec
3681 else
3682 this=timedelta_miss
3683 return
3684 end if
3685 ENDIF
3686ENDIF
3687
3688
3689
3690
3691END SUBROUTINE timedelta_init
3692
3693
3694SUBROUTINE timedelta_delete(this)
3695TYPE(timedelta),INTENT(INOUT) :: this
3696
3697this%iminuti = imiss
3698this%month = 0
3699
3700END SUBROUTINE timedelta_delete
3701
3702
3707PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3708 day, hour, minute, sec, msec, &
3709 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3710TYPE(timedelta),INTENT(IN) :: this
3711INTEGER,INTENT(OUT),OPTIONAL :: year
3712INTEGER,INTENT(OUT),OPTIONAL :: month
3713INTEGER,INTENT(OUT),OPTIONAL :: amonth
3714INTEGER,INTENT(OUT),OPTIONAL :: day
3715INTEGER,INTENT(OUT),OPTIONAL :: hour
3716INTEGER,INTENT(OUT),OPTIONAL :: minute
3717INTEGER,INTENT(OUT),OPTIONAL :: sec
3718INTEGER,INTENT(OUT),OPTIONAL :: msec
3719INTEGER,INTENT(OUT),OPTIONAL :: ahour
3720INTEGER,INTENT(OUT),OPTIONAL :: aminute
3721INTEGER,INTENT(OUT),OPTIONAL :: asec
3722INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
3723CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3724CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3725CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3726
3727CHARACTER(len=23) :: datebuf
3728
3729IF (PRESENT(amsec)) THEN
3730 amsec = this%iminuti
3731ENDIF
3732IF (PRESENT(asec)) THEN
3733 asec = int(this%iminuti/1000_int_ll)
3734ENDIF
3735IF (PRESENT(aminute)) THEN
3736 aminute = int(this%iminuti/60000_int_ll)
3737ENDIF
3738IF (PRESENT(ahour)) THEN
3739 ahour = int(this%iminuti/3600000_int_ll)
3740ENDIF
3741IF (PRESENT(msec)) THEN
3742 msec = int(mod(this%iminuti, 1000_int_ll))
3743ENDIF
3744IF (PRESENT(sec)) THEN
3745 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3746ENDIF
3747IF (PRESENT(minute)) THEN
3748 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3749ENDIF
3750IF (PRESENT(hour)) THEN
3751 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3752ENDIF
3753IF (PRESENT(day)) THEN
3754 day = int(this%iminuti/86400000_int_ll)
3755ENDIF
3756IF (PRESENT(amonth)) THEN
3757 amonth = this%month
3758ENDIF
3759IF (PRESENT(month)) THEN
3760 month = mod(this%month-1,12)+1
3761ENDIF
3762IF (PRESENT(year)) THEN
3763 year = this%month/12
3764ENDIF
3765IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3766 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3767 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), ':', &
3768 mod(this%iminuti/60000_int_ll, 60_int_ll), ':', mod(this%iminuti/1000_int_ll, 60_int_ll), &
3769 '.', mod(this%iminuti, 1000_int_ll)
3770 isodate = datebuf(1:min(len(isodate),23))
3771
3772ENDIF
3773IF (PRESENT(simpledate)) THEN
3774 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3775 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3776 mod(this%iminuti/60000_int_ll, 60_int_ll), mod(this%iminuti/1000_int_ll, 60_int_ll), &
3777 mod(this%iminuti, 1000_int_ll)
3778 simpledate = datebuf(1:min(len(simpledate),17))
3779ENDIF
3780IF (PRESENT(oraclesimdate)) THEN
3781!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3782!!$ 'obsoleto, usare piuttosto simpledate')
3783 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3784 mod(this%iminuti/3600000_int_ll, 24_int_ll), mod(this%iminuti/60000_int_ll, 60_int_ll)
3785ENDIF
3786
3787END SUBROUTINE timedelta_getval
3788
3789
3792elemental FUNCTION timedelta_to_char(this) RESULT(char)
3793TYPE(timedelta),INTENT(IN) :: this
3794
3795CHARACTER(len=23) :: char
3796
3797CALL getval(this, isodate=char)
3798
3799END FUNCTION timedelta_to_char
3800
3801
3802FUNCTION trim_timedelta_to_char(in) RESULT(char)
3803TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3804
3805CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3806
3807char=timedelta_to_char(in)
3808
3809END FUNCTION trim_timedelta_to_char
3810
3811
3813elemental FUNCTION timedelta_getamsec(this)
3814TYPE(timedelta),INTENT(IN) :: this
3815INTEGER(kind=int_ll) :: timedelta_getamsec
3816
3817timedelta_getamsec = this%iminuti
3818
3819END FUNCTION timedelta_getamsec
3820
3821
3827FUNCTION timedelta_depop(this)
3828TYPE(timedelta),INTENT(IN) :: this
3829TYPE(timedelta) :: timedelta_depop
3830
3831TYPE(datetime) :: tmpdt
3832
3833IF (this%month == 0) THEN
3834 timedelta_depop = this
3835ELSE
3836 tmpdt = datetime_new(1970, 1, 1)
3837 timedelta_depop = (tmpdt + this) - tmpdt
3838ENDIF
3839
3840END FUNCTION timedelta_depop
3841
3842
3843elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3844TYPE(timedelta),INTENT(IN) :: this, that
3845LOGICAL :: res
3846
3847res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3848
3849END FUNCTION timedelta_eq
3850
3851
3852ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3853TYPE(timedelta),INTENT(IN) :: this, that
3854LOGICAL :: res
3855
3856res = .NOT.(this == that)
3857
3858END FUNCTION timedelta_ne
3859
3860
3861ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
3862TYPE(timedelta),INTENT(IN) :: this, that
3863LOGICAL :: res
3864
3865res = this%iminuti > that%iminuti
3866
3867END FUNCTION timedelta_gt
3868
3869
3870ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
3871TYPE(timedelta),INTENT(IN) :: this, that
3872LOGICAL :: res
3873
3874res = this%iminuti < that%iminuti
3875
3876END FUNCTION timedelta_lt
3877
3878
3879ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
3880TYPE(timedelta),INTENT(IN) :: this, that
3881LOGICAL :: res
3882
3883IF (this == that) THEN
3884 res = .true.
3885ELSE IF (this > that) THEN
3886 res = .true.
3887ELSE
3888 res = .false.
3889ENDIF
3890
3891END FUNCTION timedelta_ge
3892
3893
3894elemental FUNCTION timedelta_le(this, that) RESULT(res)
3895TYPE(timedelta),INTENT(IN) :: this, that
3896LOGICAL :: res
3897
3898IF (this == that) THEN
3899 res = .true.
3900ELSE IF (this < that) THEN
3901 res = .true.
3902ELSE
3903 res = .false.
3904ENDIF
3905
3906END FUNCTION timedelta_le
3907
3908
3909ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
3910TYPE(timedelta),INTENT(IN) :: this, that
3911TYPE(timedelta) :: res
3912
3913res%iminuti = this%iminuti + that%iminuti
3914res%month = this%month + that%month
3915
3916END FUNCTION timedelta_add
3917
3918
3919ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
3920TYPE(timedelta),INTENT(IN) :: this, that
3921TYPE(timedelta) :: res
3922
3923res%iminuti = this%iminuti - that%iminuti
3924res%month = this%month - that%month
3925
3926END FUNCTION timedelta_sub
3927
3928
3929ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
3930TYPE(timedelta),INTENT(IN) :: this
3931INTEGER,INTENT(IN) :: n
3932TYPE(timedelta) :: res
3933
3934res%iminuti = this%iminuti*n
3935res%month = this%month*n
3936
3937END FUNCTION timedelta_mult
3938
3939
3940ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
3941INTEGER,INTENT(IN) :: n
3942TYPE(timedelta),INTENT(IN) :: this
3943TYPE(timedelta) :: res
3944
3945res%iminuti = this%iminuti*n
3946res%month = this%month*n
3947
3948END FUNCTION timedelta_tlum
3949
3950
3951ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
3952TYPE(timedelta),INTENT(IN) :: this
3953INTEGER,INTENT(IN) :: n
3954TYPE(timedelta) :: res
3955
3956res%iminuti = this%iminuti/n
3957res%month = this%month/n
3958
3959END FUNCTION timedelta_divint
3960
3961
3962ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
3963TYPE(timedelta),INTENT(IN) :: this, that
3964INTEGER :: res
3965
3966res = int(this%iminuti/that%iminuti)
3967
3968END FUNCTION timedelta_divtd
3969
3970
3971elemental FUNCTION timedelta_mod(this, that) RESULT(res)
3972TYPE(timedelta),INTENT(IN) :: this, that
3973TYPE(timedelta) :: res
3974
3975res%iminuti = mod(this%iminuti, that%iminuti)
3976res%month = 0
3977
3978END FUNCTION timedelta_mod
3979
3980
3981ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
3982TYPE(datetime),INTENT(IN) :: this
3983TYPE(timedelta),INTENT(IN) :: that
3984TYPE(timedelta) :: res
3985
3986IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
3987 res = timedelta_0
3988ELSE
3989 res%iminuti = mod(this%iminuti, that%iminuti)
3990 res%month = 0
3991ENDIF
3992
3993END FUNCTION datetime_timedelta_mod
3994
3995
3996ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
3997TYPE(timedelta),INTENT(IN) :: this
3998TYPE(timedelta) :: res
3999
4000res%iminuti = abs(this%iminuti)
4001res%month = abs(this%month)
4002
4003END FUNCTION timedelta_abs
4004
4005
4010SUBROUTINE timedelta_read_unit(this, unit)
4011TYPE(timedelta),INTENT(out) :: this
4012INTEGER, INTENT(in) :: unit
4013
4014CALL timedelta_vect_read_unit((/this/), unit)
4015
4016END SUBROUTINE timedelta_read_unit
4017
4018
4023SUBROUTINE timedelta_vect_read_unit(this, unit)
4024TYPE(timedelta) :: this(:)
4025INTEGER, INTENT(in) :: unit
4026
4027CHARACTER(len=40) :: form
4028CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4029INTEGER :: i
4030
4031ALLOCATE(dateiso(SIZE(this)))
4032INQUIRE(unit, form=form)
4033IF (form == 'FORMATTED') THEN
4034 READ(unit,'(3(A23,1X))')dateiso
4035ELSE
4036 READ(unit)dateiso
4037ENDIF
4038DO i = 1, SIZE(dateiso)
4039 CALL init(this(i), isodate=dateiso(i))
4040ENDDO
4041DEALLOCATE(dateiso)
4042
4043END SUBROUTINE timedelta_vect_read_unit
4044
4045
4050SUBROUTINE timedelta_write_unit(this, unit)
4051TYPE(timedelta),INTENT(in) :: this
4052INTEGER, INTENT(in) :: unit
4053
4054CALL timedelta_vect_write_unit((/this/), unit)
4055
4056END SUBROUTINE timedelta_write_unit
4057
4058
4063SUBROUTINE timedelta_vect_write_unit(this, unit)
4064TYPE(timedelta),INTENT(in) :: this(:)
4065INTEGER, INTENT(in) :: unit
4066
4067CHARACTER(len=40) :: form
4068CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4069INTEGER :: i
4070
4071ALLOCATE(dateiso(SIZE(this)))
4072DO i = 1, SIZE(dateiso)
4073 CALL getval(this(i), isodate=dateiso(i))
4074ENDDO
4075INQUIRE(unit, form=form)
4076IF (form == 'FORMATTED') THEN
4077 WRITE(unit,'(3(A23,1X))')dateiso
4078ELSE
4079 WRITE(unit)dateiso
4080ENDIF
4081DEALLOCATE(dateiso)
4082
4083END SUBROUTINE timedelta_vect_write_unit
4084
4085
4086ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4087TYPE(timedelta),INTENT(in) :: this
4088LOGICAL :: res
4089
4090res = .not. this == timedelta_miss
4091
4092end FUNCTION c_e_timedelta
4093
4094
4095elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4096
4097!!omstart JELADATA5
4098! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4099! 1 IMINUTI)
4100!
4101! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4102!
4103! variabili integer*4
4104! IN:
4105! IDAY,IMONTH,IYEAR, I*4
4106! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4107!
4108! OUT:
4109! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4110!!OMEND
4111
4112INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4113INTEGER,intent(out) :: iminuti
4114
4115iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4116
4117END SUBROUTINE jeladata5
4118
4119
4120elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4121INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4122INTEGER(KIND=int_ll),intent(out) :: imillisec
4123
4124imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4125 + imsec
4126
4127END SUBROUTINE jeladata5_1
4128
4129
4130
4131elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4132
4133!!omstart JELADATA6
4134! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4135! 1 IMINUTI)
4136!
4137! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4138! 1/1/1
4139!
4140! variabili integer*4
4141! IN:
4142! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4143!
4144! OUT:
4145! IDAY,IMONTH,IYEAR, I*4
4146! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4147!!OMEND
4148
4149
4150INTEGER,intent(in) :: iminuti
4151INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4152
4153INTEGER ::igiorno
4154
4155imin = mod(iminuti,60)
4156ihour = mod(iminuti,1440)/60
4157igiorno = iminuti/1440
4158IF (mod(iminuti,1440) < 0) igiorno = igiorno-1
4159CALL ndyin(igiorno,iday,imonth,iyear)
4160
4161END SUBROUTINE jeladata6
4162
4163
4164elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4165INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4166INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4167
4168INTEGER :: igiorno
4169
4170imsec = int(mod(imillisec, 60000_int_ll)) ! partial msec
4171!imin = MOD(imillisec/60000_int_ll, 60)
4172!ihour = MOD(imillisec/3600000_int_ll, 24)
4173imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4174ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4175igiorno = int(imillisec/86400000_int_ll)
4176!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4177CALL ndyin(igiorno,iday,imonth,iyear)
4178
4179END SUBROUTINE jeladata6_1
4180
4181
4182elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4183
4184!!OMSTART NDYIN
4185! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4186! restituisce la data fornendo in input il numero di
4187! giorni dal 1/1/1
4188!
4189!!omend
4190
4191INTEGER,intent(in) :: ndays
4192INTEGER,intent(out) :: igg, imm, iaa
4193integer :: n,lndays
4194
4195lndays=ndays
4196
4197n = lndays/d400
4198lndays = lndays - n*d400
4199iaa = year0 + n*400
4200n = min(lndays/d100, 3)
4201lndays = lndays - n*d100
4202iaa = iaa + n*100
4203n = lndays/d4
4204lndays = lndays - n*d4
4205iaa = iaa + n*4
4206n = min(lndays/d1, 3)
4207lndays = lndays - n*d1
4208iaa = iaa + n
4209n = bisextilis(iaa)
4210DO imm = 1, 12
4211 IF (lndays < ianno(imm+1,n)) EXIT
4212ENDDO
4213igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4214
4215END SUBROUTINE ndyin
4216
4217
4218integer elemental FUNCTION ndays(igg,imm,iaa)
4219
4220!!OMSTART NDAYS
4221! FUNCTION NDAYS(IGG,IMM,IAA)
4222! restituisce il numero di giorni dal 1/1/1
4223! fornendo in input la data
4224!
4225!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4226! nota bene E' SICURO !!!
4227! un anno e' bisestile se divisibile per 4
4228! un anno rimane bisestile se divisibile per 400
4229! un anno NON e' bisestile se divisibile per 100
4230!
4231!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4232!
4233!!omend
4234
4235INTEGER, intent(in) :: igg, imm, iaa
4236
4237INTEGER :: lmonth, lyear
4238
4239! Limito il mese a [1-12] e correggo l'anno coerentemente
4240lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4241lyear = iaa + (imm - lmonth)/12
4242ndays = igg+ianno(lmonth, bisextilis(lyear))
4243ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4244 (lyear-year0)/400
4245
4246END FUNCTION ndays
4247
4248
4249elemental FUNCTION bisextilis(annum)
4250INTEGER,INTENT(in) :: annum
4251INTEGER :: bisextilis
4252
4253IF (mod(annum,4) == 0 .AND. (mod(annum,400) == 0 .EQV. mod(annum,100) == 0)) THEN
4254 bisextilis = 2
4255ELSE
4256 bisextilis = 1
4257ENDIF
4258END FUNCTION bisextilis
4259
4260
4261ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4262TYPE(cyclicdatetime),INTENT(IN) :: this, that
4263LOGICAL :: res
4264
4265res = .true.
4266if (this%minute /= that%minute) res=.false.
4267if (this%hour /= that%hour) res=.false.
4268if (this%day /= that%day) res=.false.
4269if (this%month /= that%month) res=.false.
4270if (this%tendaysp /= that%tendaysp) res=.false.
4271
4272END FUNCTION cyclicdatetime_eq
4273
4274
4275ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4276TYPE(cyclicdatetime),INTENT(IN) :: this
4277TYPE(datetime),INTENT(IN) :: that
4278LOGICAL :: res
4279
4280integer :: minute,hour,day,month
4281
4282call getval(that,minute=minute,hour=hour,day=day,month=month)
4283
4284res = .true.
4285if (c_e(this%minute) .and. this%minute /= minute) res=.false.
4286if (c_e(this%hour) .and. this%hour /= hour) res=.false.
4287if (c_e(this%day) .and. this%day /= day) res=.false.
4288if (c_e(this%month) .and. this%month /= month) res=.false.
4289if (c_e(this%tendaysp)) then
4290 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4291end if
4292
4293END FUNCTION cyclicdatetime_datetime_eq
4294
4295
4296ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4297TYPE(datetime),INTENT(IN) :: this
4298TYPE(cyclicdatetime),INTENT(IN) :: that
4299LOGICAL :: res
4300
4301integer :: minute,hour,day,month
4302
4303call getval(this,minute=minute,hour=hour,day=day,month=month)
4304
4305res = .true.
4306if (c_e(that%minute) .and. that%minute /= minute) res=.false.
4307if (c_e(that%hour) .and. that%hour /= hour) res=.false.
4308if (c_e(that%day) .and. that%day /= day) res=.false.
4309if (c_e(that%month) .and. that%month /= month) res=.false.
4310
4311if (c_e(that%tendaysp)) then
4312 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4313end if
4314
4315
4316END FUNCTION datetime_cyclicdatetime_eq
4317
4318ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4319TYPE(cyclicdatetime),INTENT(in) :: this
4320LOGICAL :: res
4321
4322res = .not. this == cyclicdatetime_miss
4323
4324end FUNCTION c_e_cyclicdatetime
4325
4326
4329FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4330INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4331INTEGER,INTENT(IN),OPTIONAL :: month
4332INTEGER,INTENT(IN),OPTIONAL :: day
4333INTEGER,INTENT(IN),OPTIONAL :: hour
4334INTEGER,INTENT(IN),OPTIONAL :: minute
4335CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4336
4337integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4338
4339
4340TYPE(cyclicdatetime) :: this
4341
4342if (present(chardate)) then
4343
4344 ltendaysp=imiss
4345 lmonth=imiss
4346 lday=imiss
4347 lhour=imiss
4348 lminute=imiss
4349
4350 if (c_e(chardate))then
4351 ! TMMGGhhmm
4352 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4353 !print*,chardate(1:1),ios,ltendaysp
4354 if (ios /= 0)ltendaysp=imiss
4355
4356 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4357 !print*,chardate(2:3),ios,lmonth
4358 if (ios /= 0)lmonth=imiss
4359
4360 read(chardate(4:5),'(i2)',iostat=ios)lday
4361 !print*,chardate(4:5),ios,lday
4362 if (ios /= 0)lday=imiss
4363
4364 read(chardate(6:7),'(i2)',iostat=ios)lhour
4365 !print*,chardate(6:7),ios,lhour
4366 if (ios /= 0)lhour=imiss
4367
4368 read(chardate(8:9),'(i2)',iostat=ios)lminute
4369 !print*,chardate(8:9),ios,lminute
4370 if (ios /= 0)lminute=imiss
4371 end if
4372
4373 this%tendaysp=ltendaysp
4374 this%month=lmonth
4375 this%day=lday
4376 this%hour=lhour
4377 this%minute=lminute
4378else
4379 this%tendaysp=optio_l(tendaysp)
4380 this%month=optio_l(month)
4381 this%day=optio_l(day)
4382 this%hour=optio_l(hour)
4383 this%minute=optio_l(minute)
4384end if
4385
4386END FUNCTION cyclicdatetime_new
4387
4390elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4391TYPE(cyclicdatetime),INTENT(IN) :: this
4392
4393CHARACTER(len=80) :: char
4394
4395char=to_char(this%tendaysp)//";"//to_char(this%month)//";"//to_char(this%day)//";"//&
4396to_char(this%hour)//";"//to_char(this%minute)
4397
4398END FUNCTION cyclicdatetime_to_char
4399
4400
4413FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4414TYPE(cyclicdatetime),INTENT(IN) :: this
4415
4416TYPE(datetime) :: dtc
4417
4418integer :: year,month,day,hour
4419
4420dtc = datetime_miss
4421
4422! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4423if ( .not. c_e(this)) then
4424 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4425 return
4426end if
4427
4428! minute present -> not good for conventional datetime
4429if (c_e(this%minute)) return
4430! day, month and tendaysp present -> no good
4431if (c_e(this%day) .and. c_e(this%month) .and. c_e(this%tendaysp)) return
4432
4433if (c_e(this%day) .and. c_e(this%month)) then
4434 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4435else if (c_e(this%tendaysp) .and. c_e(this%month)) then
4436 day=(this%tendaysp-1)*10+1
4437 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4438else if (c_e(this%month)) then
4439 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4440else if (c_e(this%day)) then
4441 ! only day present -> no good
4442 return
4443end if
4444
4445if (c_e(this%hour)) then
4446 call getval(dtc,year=year,month=month,day=day,hour=hour)
4447 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4448end if
4449
4450
4451END FUNCTION cyclicdatetime_to_conventional
4452
4453
4454
4455FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4456TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4457
4458CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4459
4460char=cyclicdatetime_to_char(in)
4461
4462END FUNCTION trim_cyclicdatetime_to_char
4463
4464
4465
4466SUBROUTINE display_cyclicdatetime(this)
4467TYPE(cyclicdatetime),INTENT(in) :: this
4468
4469print*,"CYCLICDATETIME: ",to_char(this)
4470
4471end subroutine display_cyclicdatetime
4472
4473
4474#include "array_utilities_inc.F90"
4475
4476END MODULE datetime_class
4477
Operatore di valore assoluto di un intervallo.
Quick method to append an element to the array.
Distruttori per le 2 classi.
Restituiscono il valore dell'oggetto nella forma desiderata.
Index method with sorted array.
Costruttori per le classi datetime e timedelta.
Method for inserting elements of the array at a desired position.
Operatore di resto della divisione.
Method for packing the array object reducing at a minimum the memory occupation, without destroying i...
Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o...
Method for removing elements of the array at a desired position.
Functions that return a trimmed CHARACTER representation of the input variable.
Restituiscono il valore dell'oggetto in forma di stringa stampabile.
Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ...
Index method.
Utilities for CHARACTER variables.
Classi per la gestione delle coordinate temporali.
Gestione degli errori.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:251
classe per la gestione del logging
Definitions of constants and functions for working with missing values.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Class for expressing a cyclic datetime.
Class for expressing an absolute time value.
Class for expressing a relative time interval.

Generated with Doxygen.