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