libsim Versione 7.1.11

◆ count_distinct_datetime()

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

conta gli elementi distinti in vect

Definizione alla linea 2528 del file datetime_class.F90.

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