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