libsim Versione 7.2.1
|
◆ count_distinct_sorted_datetime()
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
2528IMPLICIT NONE
2529
2530INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2531
2534 PRIVATE
2535 INTEGER(KIND=int_ll) :: iminuti
2537
2546 PRIVATE
2547 INTEGER(KIND=int_ll) :: iminuti
2548 INTEGER :: month
2550
2551
2556 PRIVATE
2557 INTEGER :: minute
2558 INTEGER :: hour
2559 INTEGER :: day
2560 INTEGER :: tendaysp
2561 INTEGER :: month
2563
2564
2572INTEGER, PARAMETER :: datetime_utc=1
2574INTEGER, PARAMETER :: datetime_local=2
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
2612 MODULE PROCEDURE datetime_init, timedelta_init
2613END INTERFACE
2614
2618 MODULE PROCEDURE datetime_delete, timedelta_delete
2619END INTERFACE
2620
2623 MODULE PROCEDURE datetime_getval, timedelta_getval
2624END INTERFACE
2625
2628 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2629END INTERFACE
2630
2631
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
2767 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2768END INTERFACE
2769
2773 MODULE PROCEDURE timedelta_abs
2774END INTERFACE
2775
2779 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2780 timedelta_read_unit, timedelta_vect_read_unit
2781END INTERFACE
2782
2786 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2787 timedelta_write_unit, timedelta_vect_write_unit
2788END INTERFACE
2789
2792 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2793END INTERFACE
2794
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
2818 datetime_min, datetime_max, &
2821 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2822 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2824 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2825 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2827 count_distinct, pack_distinct, &
2828 count_distinct_sorted, pack_distinct_sorted, &
2829 count_and_pack_distinct, &
2831 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
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
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)
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
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
2920 RETURN
2921 ELSE
2922 this = datetime_miss
2923 ENDIF
2924
2925ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
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
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
2957 CALL date_and_time(values=dt)
2958 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
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, &
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
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
3140
3141end subroutine display_datetime
3142
3143
3144
3145SUBROUTINE display_timedelta(this)
3146TYPE(timedelta),INTENT(in) :: this
3147
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
3242 minute=lminute, msec=lmsec)
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
3278 minute=lminute, msec=lmsec)
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)
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)
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
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
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
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
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
3489 this%month = this%month + month
3490 else
3491 this=timedelta_miss
3492 return
3493 end if
3494 ENDIF
3495 IF (PRESENT(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
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
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
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
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)') &
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), &
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, &
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
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)
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)
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
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
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
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
4132
4133res = .true.
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
4153
4154res = .true.
4159
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
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
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)
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
4279! day, month and tendaysp present -> no good
4281
4283 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4285 day=(this%tendaysp-1)*10+1
4286 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4288 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4290 ! only day present -> no good
4291 return
4292end if
4293
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
4319
4320end subroutine display_cyclicdatetime
4321
4322
4323#include "array_utilities_inc.F90"
4324
4326
Quick method to append an element to the array. Definition datetime_class.F90:616 Restituiscono il valore dell'oggetto nella forma desiderata. Definition datetime_class.F90:322 Costruttori per le classi datetime e timedelta. Definition datetime_class.F90:311 Method for inserting elements of the array at a desired position. Definition datetime_class.F90:607 Method for packing the array object reducing at a minimum the memory occupation, without destroying i... Definition datetime_class.F90:639 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition datetime_class.F90:478 Method for removing elements of the array at a desired position. Definition datetime_class.F90:622 Functions that return a trimmed CHARACTER representation of the input variable. Definition datetime_class.F90:349 Restituiscono il valore dell'oggetto in forma di stringa stampabile. Definition datetime_class.F90:327 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition datetime_class.F90:485 Definition of constants to be used for declaring variables of a desired type. Definition kinds.F90:245 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:255 Class for expressing an absolute time value. Definition datetime_class.F90:233 Class for expressing a relative time interval. Definition datetime_class.F90:245 |