libsim Versione 7.2.1

◆ 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 2488 del file datetime_class.F90.

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