libsim Versione 7.1.11

◆ count_distinct_sorted_datetime()

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

conta gli elementi distinti in un sorted array

Definizione alla linea 2494 del file datetime_class.F90.

2495! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2496! authors:
2497! Davide Cesari <dcesari@arpa.emr.it>
2498! Paolo Patruno <ppatruno@arpa.emr.it>
2499
2500! This program is free software; you can redistribute it and/or
2501! modify it under the terms of the GNU General Public License as
2502! published by the Free Software Foundation; either version 2 of
2503! the License, or (at your option) any later version.
2504
2505! This program is distributed in the hope that it will be useful,
2506! but WITHOUT ANY WARRANTY; without even the implied warranty of
2507! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2508! GNU General Public License for more details.
2509
2510! You should have received a copy of the GNU General Public License
2511! along with this program. If not, see <http://www.gnu.org/licenses/>.
2512#include "config.h"
2513
2527MODULE datetime_class
2528USE kinds
2529USE log4fortran
2530USE err_handling
2534IMPLICIT NONE
2535
2536INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2537
2539TYPE datetime
2540 PRIVATE
2541 INTEGER(KIND=int_ll) :: iminuti
2542END TYPE datetime
2543
2551TYPE timedelta
2552 PRIVATE
2553 INTEGER(KIND=int_ll) :: iminuti
2554 INTEGER :: month
2555END TYPE timedelta
2556
2557
2561TYPE cyclicdatetime
2562 PRIVATE
2563 INTEGER :: minute
2564 INTEGER :: hour
2565 INTEGER :: day
2566 INTEGER :: tendaysp
2567 INTEGER :: month
2568END TYPE cyclicdatetime
2569
2570
2572TYPE(datetime), PARAMETER :: datetime_miss=datetime(illmiss)
2574TYPE(timedelta), PARAMETER :: timedelta_miss=timedelta(illmiss, 0)
2576TYPE(timedelta), PARAMETER :: timedelta_0=timedelta(0, 0)
2578INTEGER, PARAMETER :: datetime_utc=1
2580INTEGER, PARAMETER :: datetime_local=2
2582TYPE(datetime), PARAMETER :: datetime_min=datetime(-huge(1_int_ll)-1)
2584TYPE(datetime), PARAMETER :: datetime_max=datetime(huge(1_int_ll)-1)
2586TYPE(timedelta), PARAMETER :: timedelta_min=timedelta(-huge(1_int_ll)-1,0)
2588TYPE(timedelta), PARAMETER :: timedelta_max=timedelta(huge(1_int_ll)-1,0)
2590TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2591
2592
2593INTEGER(kind=dateint), PARAMETER :: &
2594 sec_in_day=86400, &
2595 sec_in_hour=3600, &
2596 sec_in_min=60, &
2597 min_in_day=1440, &
2598 min_in_hour=60, &
2599 hour_in_day=24
2600
2601INTEGER,PARAMETER :: &
2602 year0=1, & ! anno di origine per iminuti
2603 d1=365, & ! giorni/1 anno nel calendario gregoriano
2604 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2605 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2606 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2607 ianno(13,2)=reshape((/ &
2608 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2609 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2610
2611INTEGER(KIND=int_ll),PARAMETER :: &
2612 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2613
2617INTERFACE init
2618 MODULE PROCEDURE datetime_init, timedelta_init
2619END INTERFACE
2620
2623INTERFACE delete
2624 MODULE PROCEDURE datetime_delete, timedelta_delete
2625END INTERFACE
2626
2628INTERFACE getval
2629 MODULE PROCEDURE datetime_getval, timedelta_getval
2630END INTERFACE
2631
2633INTERFACE to_char
2634 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2635END INTERFACE
2636
2637
2655INTERFACE t2c
2656 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2657END INTERFACE
2658
2664INTERFACE OPERATOR (==)
2665 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2666 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2667END INTERFACE
2668
2674INTERFACE OPERATOR (/=)
2675 MODULE PROCEDURE datetime_ne, timedelta_ne
2676END INTERFACE
2677
2685INTERFACE OPERATOR (>)
2686 MODULE PROCEDURE datetime_gt, timedelta_gt
2687END INTERFACE
2688
2696INTERFACE OPERATOR (<)
2697 MODULE PROCEDURE datetime_lt, timedelta_lt
2698END INTERFACE
2699
2707INTERFACE OPERATOR (>=)
2708 MODULE PROCEDURE datetime_ge, timedelta_ge
2709END INTERFACE
2710
2718INTERFACE OPERATOR (<=)
2719 MODULE PROCEDURE datetime_le, timedelta_le
2720END INTERFACE
2721
2728INTERFACE OPERATOR (+)
2729 MODULE PROCEDURE datetime_add, timedelta_add
2730END INTERFACE
2731
2739INTERFACE OPERATOR (-)
2740 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
2741END INTERFACE
2742
2748INTERFACE OPERATOR (*)
2749 MODULE PROCEDURE timedelta_mult, timedelta_tlum
2750END INTERFACE
2751
2758INTERFACE OPERATOR (/)
2759 MODULE PROCEDURE timedelta_divint, timedelta_divtd
2760END INTERFACE
2761
2772INTERFACE mod
2773 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2774END INTERFACE
2775
2778INTERFACE abs
2779 MODULE PROCEDURE timedelta_abs
2780END INTERFACE
2781
2784INTERFACE read_unit
2785 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2786 timedelta_read_unit, timedelta_vect_read_unit
2787END INTERFACE
2788
2791INTERFACE write_unit
2792 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2793 timedelta_write_unit, timedelta_vect_write_unit
2794END INTERFACE
2795
2797INTERFACE display
2798 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2799END INTERFACE
2800
2802INTERFACE c_e
2803 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
2804END INTERFACE
2805
2806#undef VOL7D_POLY_TYPE
2807#undef VOL7D_POLY_TYPES
2808#undef ENABLE_SORT
2809#define VOL7D_POLY_TYPE TYPE(datetime)
2810#define VOL7D_POLY_TYPES _datetime
2811#define ENABLE_SORT
2812#include "array_utilities_pre.F90"
2813
2814
2815#define ARRAYOF_ORIGTYPE TYPE(datetime)
2816#define ARRAYOF_TYPE arrayof_datetime
2817#define ARRAYOF_ORIGEQ 1
2818#include "arrayof_pre.F90"
2819! from arrayof
2820
2821PRIVATE
2822
2823PUBLIC datetime, datetime_miss, datetime_utc, datetime_local, &
2824 datetime_min, datetime_max, &
2825 datetime_new, datetime_new_now, init, delete, getval, to_char, t2c, &
2827 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2828 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2829 OPERATOR(*), OPERATOR(/), mod, abs, &
2830 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2831 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2832 display, c_e, &
2833 count_distinct, pack_distinct, &
2834 count_distinct_sorted, pack_distinct_sorted, &
2835 count_and_pack_distinct, &
2836 map_distinct, map_inv_distinct, index, index_sorted, sort, &
2837 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
2838PUBLIC insert, append, remove, packarray
2839PUBLIC insert_unique, append_unique
2840PUBLIC cyclicdatetime_to_conventional
2841
2842CONTAINS
2843
2844
2845! ==============
2846! == datetime ==
2847! ==============
2848
2855ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
2856 unixtime, isodate, simpledate) RESULT(this)
2857INTEGER,INTENT(IN),OPTIONAL :: year
2858INTEGER,INTENT(IN),OPTIONAL :: month
2859INTEGER,INTENT(IN),OPTIONAL :: day
2860INTEGER,INTENT(IN),OPTIONAL :: hour
2861INTEGER,INTENT(IN),OPTIONAL :: minute
2862INTEGER,INTENT(IN),OPTIONAL :: msec
2863INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2864CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2865CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2866
2867TYPE(datetime) :: this
2868INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2869CHARACTER(len=23) :: datebuf
2870
2871IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
2872 lyear = year
2873 IF (PRESENT(month)) THEN
2874 lmonth = month
2875 ELSE
2876 lmonth = 1
2877 ENDIF
2878 IF (PRESENT(day)) THEN
2879 lday = day
2880 ELSE
2881 lday = 1
2882 ENDIF
2883 IF (PRESENT(hour)) THEN
2884 lhour = hour
2885 ELSE
2886 lhour = 0
2887 ENDIF
2888 IF (PRESENT(minute)) THEN
2889 lminute = minute
2890 ELSE
2891 lminute = 0
2892 ENDIF
2893 IF (PRESENT(msec)) THEN
2894 lmsec = msec
2895 ELSE
2896 lmsec = 0
2897 ENDIF
2898
2899 if (c_e(lday) .and. c_e(lmonth) .and. c_e(lyear) .and. c_e(lhour) &
2900 .and. c_e(lminute) .and. c_e(lmsec)) then
2901 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2902 else
2903 this=datetime_miss
2904 end if
2905
2906ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
2907 if (c_e(unixtime)) then
2908 this%iminuti = (unixtime + unsec)*1000
2909 else
2910 this=datetime_miss
2911 end if
2912
2913ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
2914
2915 IF (c_e(isodate) .AND. len_trim(isodate) > 0) THEN
2916 datebuf(1:23) = '0001-01-01 00:00:00.000'
2917 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
2918 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
2919 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2920 lmsec = lmsec + lsec*1000
2921 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2922 RETURN
2923
2924100 CONTINUE ! condizione di errore in isodate
2925 CALL delete(this)
2926 RETURN
2927 ELSE
2928 this = datetime_miss
2929 ENDIF
2930
2931ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
2932 IF (c_e(simpledate) .AND. len_trim(simpledate) > 0)THEN
2933 datebuf(1:17) = '00010101000000000'
2934 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
2935 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
2936 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2937 lmsec = lmsec + lsec*1000
2938 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2939 RETURN
2940
2941120 CONTINUE ! condizione di errore in simpledate
2942 CALL delete(this)
2943 RETURN
2944 ELSE
2945 this = datetime_miss
2946 ENDIF
2947
2948ELSE
2949 this = datetime_miss
2950ENDIF
2951
2952END FUNCTION datetime_new
2953
2954
2956FUNCTION datetime_new_now(now) RESULT(this)
2957INTEGER,INTENT(IN) :: now
2958TYPE(datetime) :: this
2959
2960INTEGER :: dt(8)
2961
2962IF (c_e(now)) THEN
2963 CALL date_and_time(values=dt)
2964 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
2965 CALL init(this, year=dt(1), month=dt(2), day=dt(3), hour=dt(5), minute=dt(6), &
2966 msec=dt(7)*1000+dt(8))
2967ELSE
2968 this = datetime_miss
2969ENDIF
2970
2971END FUNCTION datetime_new_now
2972
2973
2980SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
2981 unixtime, isodate, simpledate, now)
2982TYPE(datetime),INTENT(INOUT) :: this
2983INTEGER,INTENT(IN),OPTIONAL :: year
2984INTEGER,INTENT(IN),OPTIONAL :: month
2985INTEGER,INTENT(IN),OPTIONAL :: day
2986INTEGER,INTENT(IN),OPTIONAL :: hour
2987INTEGER,INTENT(IN),OPTIONAL :: minute
2988INTEGER,INTENT(IN),OPTIONAL :: msec
2989INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2990CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2991CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2992INTEGER,INTENT(IN),OPTIONAL :: now
2993
2994IF (PRESENT(now)) THEN
2995 this = datetime_new_now(now)
2996ELSE
2997 this = datetime_new(year, month, day, hour, minute, msec, &
2998 unixtime, isodate, simpledate)
2999ENDIF
3000
3001END SUBROUTINE datetime_init
3002
3003
3004ELEMENTAL SUBROUTINE datetime_delete(this)
3005TYPE(datetime),INTENT(INOUT) :: this
3006
3007this%iminuti = illmiss
3008
3009END SUBROUTINE datetime_delete
3010
3011
3016PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3017 unixtime, isodate, simpledate, oraclesimdate)
3018TYPE(datetime),INTENT(IN) :: this
3019INTEGER,INTENT(OUT),OPTIONAL :: year
3020INTEGER,INTENT(OUT),OPTIONAL :: month
3021INTEGER,INTENT(OUT),OPTIONAL :: day
3022INTEGER,INTENT(OUT),OPTIONAL :: hour
3023INTEGER,INTENT(OUT),OPTIONAL :: minute
3024INTEGER,INTENT(OUT),OPTIONAL :: msec
3025INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3026CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3027CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3028CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3029
3030INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3031CHARACTER(len=23) :: datebuf
3032
3033IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3034 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3035 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3036
3037 IF (this == datetime_miss) THEN
3038
3039 IF (PRESENT(msec)) THEN
3040 msec = imiss
3041 ENDIF
3042 IF (PRESENT(minute)) THEN
3043 minute = imiss
3044 ENDIF
3045 IF (PRESENT(hour)) THEN
3046 hour = imiss
3047 ENDIF
3048 IF (PRESENT(day)) THEN
3049 day = imiss
3050 ENDIF
3051 IF (PRESENT(month)) THEN
3052 month = imiss
3053 ENDIF
3054 IF (PRESENT(year)) THEN
3055 year = imiss
3056 ENDIF
3057 IF (PRESENT(isodate)) THEN
3058 isodate = cmiss
3059 ENDIF
3060 IF (PRESENT(simpledate)) THEN
3061 simpledate = cmiss
3062 ENDIF
3063 IF (PRESENT(oraclesimdate)) THEN
3064!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3065!!$ 'obsoleto, usare piuttosto simpledate')
3066 oraclesimdate=cmiss
3067 ENDIF
3068 IF (PRESENT(unixtime)) THEN
3069 unixtime = illmiss
3070 ENDIF
3071
3072 ELSE
3073
3074 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3075 IF (PRESENT(msec)) THEN
3076 msec = lmsec
3077 ENDIF
3078 IF (PRESENT(minute)) THEN
3079 minute = lminute
3080 ENDIF
3081 IF (PRESENT(hour)) THEN
3082 hour = lhour
3083 ENDIF
3084 IF (PRESENT(day)) THEN
3085 day = lday
3086 ENDIF
3087 IF (PRESENT(month)) THEN
3088 month = lmonth
3089 ENDIF
3090 IF (PRESENT(year)) THEN
3091 year = lyear
3092 ENDIF
3093 IF (PRESENT(isodate)) THEN
3094 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3095 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3096 '.', mod(lmsec, 1000)
3097 isodate = datebuf(1:min(len(isodate),23))
3098 ENDIF
3099 IF (PRESENT(simpledate)) THEN
3100 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3101 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3102 simpledate = datebuf(1:min(len(simpledate),17))
3103 ENDIF
3104 IF (PRESENT(oraclesimdate)) THEN
3105!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3106!!$ 'obsoleto, usare piuttosto simpledate')
3107 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3108 ENDIF
3109 IF (PRESENT(unixtime)) THEN
3110 unixtime = this%iminuti/1000_int_ll-unsec
3111 ENDIF
3112
3113 ENDIF
3114ENDIF
3115
3116END SUBROUTINE datetime_getval
3117
3118
3121elemental FUNCTION datetime_to_char(this) RESULT(char)
3122TYPE(datetime),INTENT(IN) :: this
3123
3124CHARACTER(len=23) :: char
3125
3126CALL getval(this, isodate=char)
3127
3128END FUNCTION datetime_to_char
3129
3130
3131FUNCTION trim_datetime_to_char(in) RESULT(char)
3132TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3133
3134CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3135
3136char=datetime_to_char(in)
3137
3138END FUNCTION trim_datetime_to_char
3139
3140
3141
3142SUBROUTINE display_datetime(this)
3143TYPE(datetime),INTENT(in) :: this
3144
3145print*,"TIME: ",to_char(this)
3146
3147end subroutine display_datetime
3148
3149
3150
3151SUBROUTINE display_timedelta(this)
3152TYPE(timedelta),INTENT(in) :: this
3153
3154print*,"TIMEDELTA: ",to_char(this)
3155
3156end subroutine display_timedelta
3157
3158
3159
3160ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3161TYPE(datetime),INTENT(in) :: this
3162LOGICAL :: res
3163
3164res = .not. this == datetime_miss
3165
3166end FUNCTION c_e_datetime
3167
3168
3169ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3170TYPE(datetime),INTENT(IN) :: this, that
3171LOGICAL :: res
3172
3173res = this%iminuti == that%iminuti
3174
3175END FUNCTION datetime_eq
3176
3177
3178ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3179TYPE(datetime),INTENT(IN) :: this, that
3180LOGICAL :: res
3181
3182res = .NOT.(this == that)
3183
3184END FUNCTION datetime_ne
3185
3186
3187ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3188TYPE(datetime),INTENT(IN) :: this, that
3189LOGICAL :: res
3190
3191res = this%iminuti > that%iminuti
3192
3193END FUNCTION datetime_gt
3194
3195
3196ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3197TYPE(datetime),INTENT(IN) :: this, that
3198LOGICAL :: res
3199
3200res = this%iminuti < that%iminuti
3201
3202END FUNCTION datetime_lt
3203
3204
3205ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3206TYPE(datetime),INTENT(IN) :: this, that
3207LOGICAL :: res
3208
3209IF (this == that) THEN
3210 res = .true.
3211ELSE IF (this > that) THEN
3212 res = .true.
3213ELSE
3214 res = .false.
3215ENDIF
3216
3217END FUNCTION datetime_ge
3218
3219
3220ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3221TYPE(datetime),INTENT(IN) :: this, that
3222LOGICAL :: res
3223
3224IF (this == that) THEN
3225 res = .true.
3226ELSE IF (this < that) THEN
3227 res = .true.
3228ELSE
3229 res = .false.
3230ENDIF
3231
3232END FUNCTION datetime_le
3233
3234
3235FUNCTION datetime_add(this, that) RESULT(res)
3236TYPE(datetime),INTENT(IN) :: this
3237TYPE(timedelta),INTENT(IN) :: that
3238TYPE(datetime) :: res
3239
3240INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3241
3242IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3243 res = datetime_miss
3244ELSE
3245 res%iminuti = this%iminuti + that%iminuti
3246 IF (that%month /= 0) THEN
3247 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3248 minute=lminute, msec=lmsec)
3249 CALL init(res, year=lyear, month=lmonth+that%month, day=lday, &
3250 hour=lhour, minute=lminute, msec=lmsec)
3251 ENDIF
3252ENDIF
3253
3254END FUNCTION datetime_add
3255
3256
3257ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3258TYPE(datetime),INTENT(IN) :: this, that
3259TYPE(timedelta) :: res
3260
3261IF (this == datetime_miss .OR. that == datetime_miss) THEN
3262 res = timedelta_miss
3263ELSE
3264 res%iminuti = this%iminuti - that%iminuti
3265 res%month = 0
3266ENDIF
3267
3268END FUNCTION datetime_subdt
3269
3270
3271FUNCTION datetime_subtd(this, that) RESULT(res)
3272TYPE(datetime),INTENT(IN) :: this
3273TYPE(timedelta),INTENT(IN) :: that
3274TYPE(datetime) :: res
3275
3276INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3277
3278IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3279 res = datetime_miss
3280ELSE
3281 res%iminuti = this%iminuti - that%iminuti
3282 IF (that%month /= 0) THEN
3283 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3284 minute=lminute, msec=lmsec)
3285 CALL init(res, year=lyear, month=lmonth-that%month, day=lday, &
3286 hour=lhour, minute=lminute, msec=lmsec)
3287 ENDIF
3288ENDIF
3289
3290END FUNCTION datetime_subtd
3291
3292
3297SUBROUTINE datetime_read_unit(this, unit)
3298TYPE(datetime),INTENT(out) :: this
3299INTEGER, INTENT(in) :: unit
3300CALL datetime_vect_read_unit((/this/), unit)
3301
3302END SUBROUTINE datetime_read_unit
3303
3304
3309SUBROUTINE datetime_vect_read_unit(this, unit)
3310TYPE(datetime) :: this(:)
3311INTEGER, INTENT(in) :: unit
3312
3313CHARACTER(len=40) :: form
3314CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3315INTEGER :: i
3316
3317ALLOCATE(dateiso(SIZE(this)))
3318INQUIRE(unit, form=form)
3319IF (form == 'FORMATTED') THEN
3320 READ(unit,'(A23,1X)')dateiso
3321ELSE
3322 READ(unit)dateiso
3323ENDIF
3324DO i = 1, SIZE(dateiso)
3325 CALL init(this(i), isodate=dateiso(i))
3326ENDDO
3327DEALLOCATE(dateiso)
3328
3329END SUBROUTINE datetime_vect_read_unit
3330
3331
3336SUBROUTINE datetime_write_unit(this, unit)
3337TYPE(datetime),INTENT(in) :: this
3338INTEGER, INTENT(in) :: unit
3339
3340CALL datetime_vect_write_unit((/this/), unit)
3341
3342END SUBROUTINE datetime_write_unit
3343
3344
3349SUBROUTINE datetime_vect_write_unit(this, unit)
3350TYPE(datetime),INTENT(in) :: this(:)
3351INTEGER, INTENT(in) :: unit
3352
3353CHARACTER(len=40) :: form
3354CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3355INTEGER :: i
3356
3357ALLOCATE(dateiso(SIZE(this)))
3358DO i = 1, SIZE(dateiso)
3359 CALL getval(this(i), isodate=dateiso(i))
3360ENDDO
3361INQUIRE(unit, form=form)
3362IF (form == 'FORMATTED') THEN
3363 WRITE(unit,'(A23,1X)')dateiso
3364ELSE
3365 WRITE(unit)dateiso
3366ENDIF
3367DEALLOCATE(dateiso)
3368
3369END SUBROUTINE datetime_vect_write_unit
3370
3371
3372#include "arrayof_post.F90"
3373
3374
3375! ===============
3376! == timedelta ==
3377! ===============
3384FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3385 isodate, simpledate, oraclesimdate) RESULT (this)
3386INTEGER,INTENT(IN),OPTIONAL :: year
3387INTEGER,INTENT(IN),OPTIONAL :: month
3388INTEGER,INTENT(IN),OPTIONAL :: day
3389INTEGER,INTENT(IN),OPTIONAL :: hour
3390INTEGER,INTENT(IN),OPTIONAL :: minute
3391INTEGER,INTENT(IN),OPTIONAL :: sec
3392INTEGER,INTENT(IN),OPTIONAL :: msec
3393CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3394CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3395CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3396
3397TYPE(timedelta) :: this
3398
3399CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3400 isodate, simpledate, oraclesimdate)
3401
3402END FUNCTION timedelta_new
3403
3404
3409SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3410 isodate, simpledate, oraclesimdate)
3411TYPE(timedelta),INTENT(INOUT) :: this
3412INTEGER,INTENT(IN),OPTIONAL :: year
3413INTEGER,INTENT(IN),OPTIONAL :: month
3414INTEGER,INTENT(IN),OPTIONAL :: day
3415INTEGER,INTENT(IN),OPTIONAL :: hour
3416INTEGER,INTENT(IN),OPTIONAL :: minute
3417INTEGER,INTENT(IN),OPTIONAL :: sec
3418INTEGER,INTENT(IN),OPTIONAL :: msec
3419CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3420CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3421CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3422
3423INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3424CHARACTER(len=23) :: datebuf
3425
3426this%month = 0
3427
3428IF (PRESENT(isodate)) THEN
3429 datebuf(1:23) = '0000000000 00:00:00.000'
3430 l = len_trim(isodate)
3431! IF (l > 0) THEN
3432 n = index(trim(isodate), ' ') ! align blank space separator
3433 IF (n > 0) THEN
3434 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3435 datebuf(12-n:12-n+l-1) = isodate(:l)
3436 ELSE
3437 datebuf(1:l) = isodate(1:l)
3438 ENDIF
3439! ENDIF
3440
3441! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3442 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3443 h, m, s, ms
3444 this%month = lmonth + 12*lyear
3445 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3446 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3447 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3448 RETURN
3449
3450200 CONTINUE ! condizione di errore in isodate
3451 CALL delete(this)
3452 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3453 CALL raise_error()
3454
3455ELSE IF (PRESENT(simpledate)) THEN
3456 datebuf(1:17) = '00000000000000000'
3457 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3458 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3459 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3460 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3461 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3462
3463220 CONTINUE ! condizione di errore in simpledate
3464 CALL delete(this)
3465 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3466 CALL raise_error()
3467 RETURN
3468
3469ELSE IF (PRESENT(oraclesimdate)) THEN
3470 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3471 'obsoleto, usare piuttosto simpledate')
3472 READ(oraclesimdate, '(I8,2I2)')d, h, m
3473 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3474 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3475
3476ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3477 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3478 .and. .not. present(msec) .and. .not. present(isodate) &
3479 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3480
3481 this=timedelta_miss
3482
3483ELSE
3484 this%iminuti = 0
3485 IF (PRESENT(year)) THEN
3486 if (c_e(year))then
3487 this%month = this%month + year*12
3488 else
3489 this=timedelta_miss
3490 return
3491 end if
3492 ENDIF
3493 IF (PRESENT(month)) THEN
3494 if (c_e(month))then
3495 this%month = this%month + month
3496 else
3497 this=timedelta_miss
3498 return
3499 end if
3500 ENDIF
3501 IF (PRESENT(day)) THEN
3502 if (c_e(day))then
3503 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3504 else
3505 this=timedelta_miss
3506 return
3507 end if
3508 ENDIF
3509 IF (PRESENT(hour)) THEN
3510 if (c_e(hour))then
3511 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3512 else
3513 this=timedelta_miss
3514 return
3515 end if
3516 ENDIF
3517 IF (PRESENT(minute)) THEN
3518 if (c_e(minute))then
3519 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3520 else
3521 this=timedelta_miss
3522 return
3523 end if
3524 ENDIF
3525 IF (PRESENT(sec)) THEN
3526 if (c_e(sec))then
3527 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3528 else
3529 this=timedelta_miss
3530 return
3531 end if
3532 ENDIF
3533 IF (PRESENT(msec)) THEN
3534 if (c_e(msec))then
3535 this%iminuti = this%iminuti + msec
3536 else
3537 this=timedelta_miss
3538 return
3539 end if
3540 ENDIF
3541ENDIF
3542
3543
3544
3545
3546END SUBROUTINE timedelta_init
3547
3548
3549SUBROUTINE timedelta_delete(this)
3550TYPE(timedelta),INTENT(INOUT) :: this
3551
3552this%iminuti = imiss
3553this%month = 0
3554
3555END SUBROUTINE timedelta_delete
3556
3557
3562PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3563 day, hour, minute, sec, msec, &
3564 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3565TYPE(timedelta),INTENT(IN) :: this
3566INTEGER,INTENT(OUT),OPTIONAL :: year
3567INTEGER,INTENT(OUT),OPTIONAL :: month
3568INTEGER,INTENT(OUT),OPTIONAL :: amonth
3569INTEGER,INTENT(OUT),OPTIONAL :: day
3570INTEGER,INTENT(OUT),OPTIONAL :: hour
3571INTEGER,INTENT(OUT),OPTIONAL :: minute
3572INTEGER,INTENT(OUT),OPTIONAL :: sec
3573INTEGER,INTENT(OUT),OPTIONAL :: msec
3574INTEGER,INTENT(OUT),OPTIONAL :: ahour
3575INTEGER,INTENT(OUT),OPTIONAL :: aminute
3576INTEGER,INTENT(OUT),OPTIONAL :: asec
3577INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
3578CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3579CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3580CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3581
3582CHARACTER(len=23) :: datebuf
3583
3584IF (PRESENT(amsec)) THEN
3585 amsec = this%iminuti
3586ENDIF
3587IF (PRESENT(asec)) THEN
3588 asec = int(this%iminuti/1000_int_ll)
3589ENDIF
3590IF (PRESENT(aminute)) THEN
3591 aminute = int(this%iminuti/60000_int_ll)
3592ENDIF
3593IF (PRESENT(ahour)) THEN
3594 ahour = int(this%iminuti/3600000_int_ll)
3595ENDIF
3596IF (PRESENT(msec)) THEN
3597 msec = int(mod(this%iminuti, 1000_int_ll))
3598ENDIF
3599IF (PRESENT(sec)) THEN
3600 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3601ENDIF
3602IF (PRESENT(minute)) THEN
3603 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3604ENDIF
3605IF (PRESENT(hour)) THEN
3606 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3607ENDIF
3608IF (PRESENT(day)) THEN
3609 day = int(this%iminuti/86400000_int_ll)
3610ENDIF
3611IF (PRESENT(amonth)) THEN
3612 amonth = this%month
3613ENDIF
3614IF (PRESENT(month)) THEN
3615 month = mod(this%month-1,12)+1
3616ENDIF
3617IF (PRESENT(year)) THEN
3618 year = this%month/12
3619ENDIF
3620IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3621 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3622 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), ':', &
3623 mod(this%iminuti/60000_int_ll, 60_int_ll), ':', mod(this%iminuti/1000_int_ll, 60_int_ll), &
3624 '.', mod(this%iminuti, 1000_int_ll)
3625 isodate = datebuf(1:min(len(isodate),23))
3626
3627ENDIF
3628IF (PRESENT(simpledate)) THEN
3629 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3630 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3631 mod(this%iminuti/60000_int_ll, 60_int_ll), mod(this%iminuti/1000_int_ll, 60_int_ll), &
3632 mod(this%iminuti, 1000_int_ll)
3633 simpledate = datebuf(1:min(len(simpledate),17))
3634ENDIF
3635IF (PRESENT(oraclesimdate)) THEN
3636!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3637!!$ 'obsoleto, usare piuttosto simpledate')
3638 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3639 mod(this%iminuti/3600000_int_ll, 24_int_ll), mod(this%iminuti/60000_int_ll, 60_int_ll)
3640ENDIF
3641
3642END SUBROUTINE timedelta_getval
3643
3644
3647elemental FUNCTION timedelta_to_char(this) RESULT(char)
3648TYPE(timedelta),INTENT(IN) :: this
3649
3650CHARACTER(len=23) :: char
3651
3652CALL getval(this, isodate=char)
3653
3654END FUNCTION timedelta_to_char
3655
3656
3657FUNCTION trim_timedelta_to_char(in) RESULT(char)
3658TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3659
3660CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3661
3662char=timedelta_to_char(in)
3663
3664END FUNCTION trim_timedelta_to_char
3665
3666
3668elemental FUNCTION timedelta_getamsec(this)
3669TYPE(timedelta),INTENT(IN) :: this
3670INTEGER(kind=int_ll) :: timedelta_getamsec
3671
3672timedelta_getamsec = this%iminuti
3673
3674END FUNCTION timedelta_getamsec
3675
3676
3682FUNCTION timedelta_depop(this)
3683TYPE(timedelta),INTENT(IN) :: this
3684TYPE(timedelta) :: timedelta_depop
3685
3686TYPE(datetime) :: tmpdt
3687
3688IF (this%month == 0) THEN
3689 timedelta_depop = this
3690ELSE
3691 tmpdt = datetime_new(1970, 1, 1)
3692 timedelta_depop = (tmpdt + this) - tmpdt
3693ENDIF
3694
3695END FUNCTION timedelta_depop
3696
3697
3698elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3699TYPE(timedelta),INTENT(IN) :: this, that
3700LOGICAL :: res
3701
3702res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3703
3704END FUNCTION timedelta_eq
3705
3706
3707ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3708TYPE(timedelta),INTENT(IN) :: this, that
3709LOGICAL :: res
3710
3711res = .NOT.(this == that)
3712
3713END FUNCTION timedelta_ne
3714
3715
3716ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
3717TYPE(timedelta),INTENT(IN) :: this, that
3718LOGICAL :: res
3719
3720res = this%iminuti > that%iminuti
3721
3722END FUNCTION timedelta_gt
3723
3724
3725ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
3726TYPE(timedelta),INTENT(IN) :: this, that
3727LOGICAL :: res
3728
3729res = this%iminuti < that%iminuti
3730
3731END FUNCTION timedelta_lt
3732
3733
3734ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
3735TYPE(timedelta),INTENT(IN) :: this, that
3736LOGICAL :: res
3737
3738IF (this == that) THEN
3739 res = .true.
3740ELSE IF (this > that) THEN
3741 res = .true.
3742ELSE
3743 res = .false.
3744ENDIF
3745
3746END FUNCTION timedelta_ge
3747
3748
3749elemental FUNCTION timedelta_le(this, that) RESULT(res)
3750TYPE(timedelta),INTENT(IN) :: this, that
3751LOGICAL :: res
3752
3753IF (this == that) THEN
3754 res = .true.
3755ELSE IF (this < that) THEN
3756 res = .true.
3757ELSE
3758 res = .false.
3759ENDIF
3760
3761END FUNCTION timedelta_le
3762
3763
3764ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
3765TYPE(timedelta),INTENT(IN) :: this, that
3766TYPE(timedelta) :: res
3767
3768res%iminuti = this%iminuti + that%iminuti
3769res%month = this%month + that%month
3770
3771END FUNCTION timedelta_add
3772
3773
3774ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
3775TYPE(timedelta),INTENT(IN) :: this, that
3776TYPE(timedelta) :: res
3777
3778res%iminuti = this%iminuti - that%iminuti
3779res%month = this%month - that%month
3780
3781END FUNCTION timedelta_sub
3782
3783
3784ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
3785TYPE(timedelta),INTENT(IN) :: this
3786INTEGER,INTENT(IN) :: n
3787TYPE(timedelta) :: res
3788
3789res%iminuti = this%iminuti*n
3790res%month = this%month*n
3791
3792END FUNCTION timedelta_mult
3793
3794
3795ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
3796INTEGER,INTENT(IN) :: n
3797TYPE(timedelta),INTENT(IN) :: this
3798TYPE(timedelta) :: res
3799
3800res%iminuti = this%iminuti*n
3801res%month = this%month*n
3802
3803END FUNCTION timedelta_tlum
3804
3805
3806ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
3807TYPE(timedelta),INTENT(IN) :: this
3808INTEGER,INTENT(IN) :: n
3809TYPE(timedelta) :: res
3810
3811res%iminuti = this%iminuti/n
3812res%month = this%month/n
3813
3814END FUNCTION timedelta_divint
3815
3816
3817ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
3818TYPE(timedelta),INTENT(IN) :: this, that
3819INTEGER :: res
3820
3821res = int(this%iminuti/that%iminuti)
3822
3823END FUNCTION timedelta_divtd
3824
3825
3826elemental FUNCTION timedelta_mod(this, that) RESULT(res)
3827TYPE(timedelta),INTENT(IN) :: this, that
3828TYPE(timedelta) :: res
3829
3830res%iminuti = mod(this%iminuti, that%iminuti)
3831res%month = 0
3832
3833END FUNCTION timedelta_mod
3834
3835
3836ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
3837TYPE(datetime),INTENT(IN) :: this
3838TYPE(timedelta),INTENT(IN) :: that
3839TYPE(timedelta) :: res
3840
3841IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
3842 res = timedelta_0
3843ELSE
3844 res%iminuti = mod(this%iminuti, that%iminuti)
3845 res%month = 0
3846ENDIF
3847
3848END FUNCTION datetime_timedelta_mod
3849
3850
3851ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
3852TYPE(timedelta),INTENT(IN) :: this
3853TYPE(timedelta) :: res
3854
3855res%iminuti = abs(this%iminuti)
3856res%month = abs(this%month)
3857
3858END FUNCTION timedelta_abs
3859
3860
3865SUBROUTINE timedelta_read_unit(this, unit)
3866TYPE(timedelta),INTENT(out) :: this
3867INTEGER, INTENT(in) :: unit
3868
3869CALL timedelta_vect_read_unit((/this/), unit)
3870
3871END SUBROUTINE timedelta_read_unit
3872
3873
3878SUBROUTINE timedelta_vect_read_unit(this, unit)
3879TYPE(timedelta) :: this(:)
3880INTEGER, INTENT(in) :: unit
3881
3882CHARACTER(len=40) :: form
3883CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3884INTEGER :: i
3885
3886ALLOCATE(dateiso(SIZE(this)))
3887INQUIRE(unit, form=form)
3888IF (form == 'FORMATTED') THEN
3889 READ(unit,'(3(A23,1X))')dateiso
3890ELSE
3891 READ(unit)dateiso
3892ENDIF
3893DO i = 1, SIZE(dateiso)
3894 CALL init(this(i), isodate=dateiso(i))
3895ENDDO
3896DEALLOCATE(dateiso)
3897
3898END SUBROUTINE timedelta_vect_read_unit
3899
3900
3905SUBROUTINE timedelta_write_unit(this, unit)
3906TYPE(timedelta),INTENT(in) :: this
3907INTEGER, INTENT(in) :: unit
3908
3909CALL timedelta_vect_write_unit((/this/), unit)
3910
3911END SUBROUTINE timedelta_write_unit
3912
3913
3918SUBROUTINE timedelta_vect_write_unit(this, unit)
3919TYPE(timedelta),INTENT(in) :: this(:)
3920INTEGER, INTENT(in) :: unit
3921
3922CHARACTER(len=40) :: form
3923CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3924INTEGER :: i
3925
3926ALLOCATE(dateiso(SIZE(this)))
3927DO i = 1, SIZE(dateiso)
3928 CALL getval(this(i), isodate=dateiso(i))
3929ENDDO
3930INQUIRE(unit, form=form)
3931IF (form == 'FORMATTED') THEN
3932 WRITE(unit,'(3(A23,1X))')dateiso
3933ELSE
3934 WRITE(unit)dateiso
3935ENDIF
3936DEALLOCATE(dateiso)
3937
3938END SUBROUTINE timedelta_vect_write_unit
3939
3940
3941ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
3942TYPE(timedelta),INTENT(in) :: this
3943LOGICAL :: res
3944
3945res = .not. this == timedelta_miss
3946
3947end FUNCTION c_e_timedelta
3948
3949
3950elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
3951
3952!!omstart JELADATA5
3953! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3954! 1 IMINUTI)
3955!
3956! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
3957!
3958! variabili integer*4
3959! IN:
3960! IDAY,IMONTH,IYEAR, I*4
3961! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3962!
3963! OUT:
3964! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3965!!OMEND
3966
3967INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
3968INTEGER,intent(out) :: iminuti
3969
3970iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
3971
3972END SUBROUTINE jeladata5
3973
3974
3975elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
3976INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
3977INTEGER(KIND=int_ll),intent(out) :: imillisec
3978
3979imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
3980 + imsec
3981
3982END SUBROUTINE jeladata5_1
3983
3984
3985
3986elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
3987
3988!!omstart JELADATA6
3989! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3990! 1 IMINUTI)
3991!
3992! Calcola la data e l'ora corrispondente a IMINUTI dopo il
3993! 1/1/1
3994!
3995! variabili integer*4
3996! IN:
3997! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3998!
3999! OUT:
4000! IDAY,IMONTH,IYEAR, I*4
4001! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4002!!OMEND
4003
4004
4005INTEGER,intent(in) :: iminuti
4006INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4007
4008INTEGER ::igiorno
4009
4010imin = mod(iminuti,60)
4011ihour = mod(iminuti,1440)/60
4012igiorno = iminuti/1440
4013IF (mod(iminuti,1440) < 0) igiorno = igiorno-1
4014CALL ndyin(igiorno,iday,imonth,iyear)
4015
4016END SUBROUTINE jeladata6
4017
4018
4019elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4020INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4021INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4022
4023INTEGER :: igiorno
4024
4025imsec = int(mod(imillisec, 60000_int_ll)) ! partial msec
4026!imin = MOD(imillisec/60000_int_ll, 60)
4027!ihour = MOD(imillisec/3600000_int_ll, 24)
4028imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4029ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4030igiorno = int(imillisec/86400000_int_ll)
4031!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4032CALL ndyin(igiorno,iday,imonth,iyear)
4033
4034END SUBROUTINE jeladata6_1
4035
4036
4037elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4038
4039!!OMSTART NDYIN
4040! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4041! restituisce la data fornendo in input il numero di
4042! giorni dal 1/1/1
4043!
4044!!omend
4045
4046INTEGER,intent(in) :: ndays
4047INTEGER,intent(out) :: igg, imm, iaa
4048integer :: n,lndays
4049
4050lndays=ndays
4051
4052n = lndays/d400
4053lndays = lndays - n*d400
4054iaa = year0 + n*400
4055n = min(lndays/d100, 3)
4056lndays = lndays - n*d100
4057iaa = iaa + n*100
4058n = lndays/d4
4059lndays = lndays - n*d4
4060iaa = iaa + n*4
4061n = min(lndays/d1, 3)
4062lndays = lndays - n*d1
4063iaa = iaa + n
4064n = bisextilis(iaa)
4065DO imm = 1, 12
4066 IF (lndays < ianno(imm+1,n)) EXIT
4067ENDDO
4068igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4069
4070END SUBROUTINE ndyin
4071
4072
4073integer elemental FUNCTION ndays(igg,imm,iaa)
4074
4075!!OMSTART NDAYS
4076! FUNCTION NDAYS(IGG,IMM,IAA)
4077! restituisce il numero di giorni dal 1/1/1
4078! fornendo in input la data
4079!
4080!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4081! nota bene E' SICURO !!!
4082! un anno e' bisestile se divisibile per 4
4083! un anno rimane bisestile se divisibile per 400
4084! un anno NON e' bisestile se divisibile per 100
4085!
4086!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4087!
4088!!omend
4089
4090INTEGER, intent(in) :: igg, imm, iaa
4091
4092INTEGER :: lmonth, lyear
4093
4094! Limito il mese a [1-12] e correggo l'anno coerentemente
4095lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4096lyear = iaa + (imm - lmonth)/12
4097ndays = igg+ianno(lmonth, bisextilis(lyear))
4098ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4099 (lyear-year0)/400
4100
4101END FUNCTION ndays
4102
4103
4104elemental FUNCTION bisextilis(annum)
4105INTEGER,INTENT(in) :: annum
4106INTEGER :: bisextilis
4107
4108IF (mod(annum,4) == 0 .AND. (mod(annum,400) == 0 .EQV. mod(annum,100) == 0)) THEN
4109 bisextilis = 2
4110ELSE
4111 bisextilis = 1
4112ENDIF
4113END FUNCTION bisextilis
4114
4115
4116ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4117TYPE(cyclicdatetime),INTENT(IN) :: this, that
4118LOGICAL :: res
4119
4120res = .true.
4121if (this%minute /= that%minute) res=.false.
4122if (this%hour /= that%hour) res=.false.
4123if (this%day /= that%day) res=.false.
4124if (this%month /= that%month) res=.false.
4125if (this%tendaysp /= that%tendaysp) res=.false.
4126
4127END FUNCTION cyclicdatetime_eq
4128
4129
4130ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4131TYPE(cyclicdatetime),INTENT(IN) :: this
4132TYPE(datetime),INTENT(IN) :: that
4133LOGICAL :: res
4134
4135integer :: minute,hour,day,month
4136
4137call getval(that,minute=minute,hour=hour,day=day,month=month)
4138
4139res = .true.
4140if (c_e(this%minute) .and. this%minute /= minute) res=.false.
4141if (c_e(this%hour) .and. this%hour /= hour) res=.false.
4142if (c_e(this%day) .and. this%day /= day) res=.false.
4143if (c_e(this%month) .and. this%month /= month) res=.false.
4144if (c_e(this%tendaysp)) then
4145 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4146end if
4147
4148END FUNCTION cyclicdatetime_datetime_eq
4149
4150
4151ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4152TYPE(datetime),INTENT(IN) :: this
4153TYPE(cyclicdatetime),INTENT(IN) :: that
4154LOGICAL :: res
4155
4156integer :: minute,hour,day,month
4157
4158call getval(this,minute=minute,hour=hour,day=day,month=month)
4159
4160res = .true.
4161if (c_e(that%minute) .and. that%minute /= minute) res=.false.
4162if (c_e(that%hour) .and. that%hour /= hour) res=.false.
4163if (c_e(that%day) .and. that%day /= day) res=.false.
4164if (c_e(that%month) .and. that%month /= month) res=.false.
4165
4166if (c_e(that%tendaysp)) then
4167 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4168end if
4169
4170
4171END FUNCTION datetime_cyclicdatetime_eq
4172
4173ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4174TYPE(cyclicdatetime),INTENT(in) :: this
4175LOGICAL :: res
4176
4177res = .not. this == cyclicdatetime_miss
4178
4179end FUNCTION c_e_cyclicdatetime
4180
4181
4184FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4185INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4186INTEGER,INTENT(IN),OPTIONAL :: month
4187INTEGER,INTENT(IN),OPTIONAL :: day
4188INTEGER,INTENT(IN),OPTIONAL :: hour
4189INTEGER,INTENT(IN),OPTIONAL :: minute
4190CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4191
4192integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4193
4194
4195TYPE(cyclicdatetime) :: this
4196
4197if (present(chardate)) then
4198
4199 ltendaysp=imiss
4200 lmonth=imiss
4201 lday=imiss
4202 lhour=imiss
4203 lminute=imiss
4204
4205 if (c_e(chardate))then
4206 ! TMMGGhhmm
4207 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4208 !print*,chardate(1:1),ios,ltendaysp
4209 if (ios /= 0)ltendaysp=imiss
4210
4211 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4212 !print*,chardate(2:3),ios,lmonth
4213 if (ios /= 0)lmonth=imiss
4214
4215 read(chardate(4:5),'(i2)',iostat=ios)lday
4216 !print*,chardate(4:5),ios,lday
4217 if (ios /= 0)lday=imiss
4218
4219 read(chardate(6:7),'(i2)',iostat=ios)lhour
4220 !print*,chardate(6:7),ios,lhour
4221 if (ios /= 0)lhour=imiss
4222
4223 read(chardate(8:9),'(i2)',iostat=ios)lminute
4224 !print*,chardate(8:9),ios,lminute
4225 if (ios /= 0)lminute=imiss
4226 end if
4227
4228 this%tendaysp=ltendaysp
4229 this%month=lmonth
4230 this%day=lday
4231 this%hour=lhour
4232 this%minute=lminute
4233else
4234 this%tendaysp=optio_l(tendaysp)
4235 this%month=optio_l(month)
4236 this%day=optio_l(day)
4237 this%hour=optio_l(hour)
4238 this%minute=optio_l(minute)
4239end if
4240
4241END FUNCTION cyclicdatetime_new
4242
4245elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4246TYPE(cyclicdatetime),INTENT(IN) :: this
4247
4248CHARACTER(len=80) :: char
4249
4250char=to_char(this%tendaysp)//";"//to_char(this%month)//";"//to_char(this%day)//";"//&
4251to_char(this%hour)//";"//to_char(this%minute)
4252
4253END FUNCTION cyclicdatetime_to_char
4254
4255
4268FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4269TYPE(cyclicdatetime),INTENT(IN) :: this
4270
4271TYPE(datetime) :: dtc
4272
4273integer :: year,month,day,hour
4274
4275dtc = datetime_miss
4276
4277! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4278if ( .not. c_e(this)) then
4279 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4280 return
4281end if
4282
4283! minute present -> not good for conventional datetime
4284if (c_e(this%minute)) return
4285! day, month and tendaysp present -> no good
4286if (c_e(this%day) .and. c_e(this%month) .and. c_e(this%tendaysp)) return
4287
4288if (c_e(this%day) .and. c_e(this%month)) then
4289 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4290else if (c_e(this%tendaysp) .and. c_e(this%month)) then
4291 day=(this%tendaysp-1)*10+1
4292 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4293else if (c_e(this%month)) then
4294 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4295else if (c_e(this%day)) then
4296 ! only day present -> no good
4297 return
4298end if
4299
4300if (c_e(this%hour)) then
4301 call getval(dtc,year=year,month=month,day=day,hour=hour)
4302 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4303end if
4304
4305
4306END FUNCTION cyclicdatetime_to_conventional
4307
4308
4309
4310FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4311TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4312
4313CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4314
4315char=cyclicdatetime_to_char(in)
4316
4317END FUNCTION trim_cyclicdatetime_to_char
4318
4319
4320
4321SUBROUTINE display_cyclicdatetime(this)
4322TYPE(cyclicdatetime),INTENT(in) :: this
4323
4324print*,"CYCLICDATETIME: ",to_char(this)
4325
4326end subroutine display_cyclicdatetime
4327
4328
4329#include "array_utilities_inc.F90"
4330
4331END MODULE datetime_class
4332
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.