libsim Versione 7.1.11
|
◆ count_distinct_datetime()
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
2568IMPLICIT NONE
2569
2570INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2571
2574 PRIVATE
2575 INTEGER(KIND=int_ll) :: iminuti
2577
2586 PRIVATE
2587 INTEGER(KIND=int_ll) :: iminuti
2588 INTEGER :: month
2590
2591
2596 PRIVATE
2597 INTEGER :: minute
2598 INTEGER :: hour
2599 INTEGER :: day
2600 INTEGER :: tendaysp
2601 INTEGER :: month
2603
2604
2612INTEGER, PARAMETER :: datetime_utc=1
2614INTEGER, PARAMETER :: datetime_local=2
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
2652 MODULE PROCEDURE datetime_init, timedelta_init
2653END INTERFACE
2654
2658 MODULE PROCEDURE datetime_delete, timedelta_delete
2659END INTERFACE
2660
2663 MODULE PROCEDURE datetime_getval, timedelta_getval
2664END INTERFACE
2665
2668 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2669END INTERFACE
2670
2671
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
2807 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2808END INTERFACE
2809
2813 MODULE PROCEDURE timedelta_abs
2814END INTERFACE
2815
2819 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2820 timedelta_read_unit, timedelta_vect_read_unit
2821END INTERFACE
2822
2826 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2827 timedelta_write_unit, timedelta_vect_write_unit
2828END INTERFACE
2829
2832 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2833END INTERFACE
2834
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
2858 datetime_min, datetime_max, &
2861 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2862 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2864 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2865 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2867 count_distinct, pack_distinct, &
2868 count_distinct_sorted, pack_distinct_sorted, &
2869 count_and_pack_distinct, &
2871 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
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
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)
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
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
2960 RETURN
2961 ELSE
2962 this = datetime_miss
2963 ENDIF
2964
2965ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
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
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
2997 CALL date_and_time(values=dt)
2998 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
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, &
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
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
3180
3181end subroutine display_datetime
3182
3183
3184
3185SUBROUTINE display_timedelta(this)
3186TYPE(timedelta),INTENT(in) :: this
3187
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
3282 minute=lminute, msec=lmsec)
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
3318 minute=lminute, msec=lmsec)
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)
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)
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
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
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
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
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
3529 this%month = this%month + month
3530 else
3531 this=timedelta_miss
3532 return
3533 end if
3534 ENDIF
3535 IF (PRESENT(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
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
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
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
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)') &
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), &
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, &
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
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)
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)
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
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
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
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
4172
4173res = .true.
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
4193
4194res = .true.
4199
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
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
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)
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
4319! day, month and tendaysp present -> no good
4321
4323 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4325 day=(this%tendaysp-1)*10+1
4326 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4328 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4330 ! only day present -> no good
4331 return
4332end if
4333
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
4359
4360end subroutine display_cyclicdatetime
4361
4362
4363#include "array_utilities_inc.F90"
4364
4366
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 |