libsim Versione 7.1.11

◆ pack_distinct_sorted_datetime()

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

compatta gli elementi distinti di vect in un sorted array

Definizione alla linea 2605 del file datetime_class.F90.

2607! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2608! authors:
2609! Davide Cesari <dcesari@arpa.emr.it>
2610! Paolo Patruno <ppatruno@arpa.emr.it>
2611
2612! This program is free software; you can redistribute it and/or
2613! modify it under the terms of the GNU General Public License as
2614! published by the Free Software Foundation; either version 2 of
2615! the License, or (at your option) any later version.
2616
2617! This program is distributed in the hope that it will be useful,
2618! but WITHOUT ANY WARRANTY; without even the implied warranty of
2619! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2620! GNU General Public License for more details.
2621
2622! You should have received a copy of the GNU General Public License
2623! along with this program. If not, see <http://www.gnu.org/licenses/>.
2624#include "config.h"
2625
2639MODULE datetime_class
2640USE kinds
2641USE log4fortran
2642USE err_handling
2646IMPLICIT NONE
2647
2648INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2649
2651TYPE datetime
2652 PRIVATE
2653 INTEGER(KIND=int_ll) :: iminuti
2654END TYPE datetime
2655
2663TYPE timedelta
2664 PRIVATE
2665 INTEGER(KIND=int_ll) :: iminuti
2666 INTEGER :: month
2667END TYPE timedelta
2668
2669
2673TYPE cyclicdatetime
2674 PRIVATE
2675 INTEGER :: minute
2676 INTEGER :: hour
2677 INTEGER :: day
2678 INTEGER :: tendaysp
2679 INTEGER :: month
2680END TYPE cyclicdatetime
2681
2682
2684TYPE(datetime), PARAMETER :: datetime_miss=datetime(illmiss)
2686TYPE(timedelta), PARAMETER :: timedelta_miss=timedelta(illmiss, 0)
2688TYPE(timedelta), PARAMETER :: timedelta_0=timedelta(0, 0)
2690INTEGER, PARAMETER :: datetime_utc=1
2692INTEGER, PARAMETER :: datetime_local=2
2694TYPE(datetime), PARAMETER :: datetime_min=datetime(-huge(1_int_ll)-1)
2696TYPE(datetime), PARAMETER :: datetime_max=datetime(huge(1_int_ll)-1)
2698TYPE(timedelta), PARAMETER :: timedelta_min=timedelta(-huge(1_int_ll)-1,0)
2700TYPE(timedelta), PARAMETER :: timedelta_max=timedelta(huge(1_int_ll)-1,0)
2702TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2703
2704
2705INTEGER(kind=dateint), PARAMETER :: &
2706 sec_in_day=86400, &
2707 sec_in_hour=3600, &
2708 sec_in_min=60, &
2709 min_in_day=1440, &
2710 min_in_hour=60, &
2711 hour_in_day=24
2712
2713INTEGER,PARAMETER :: &
2714 year0=1, & ! anno di origine per iminuti
2715 d1=365, & ! giorni/1 anno nel calendario gregoriano
2716 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2717 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2718 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2719 ianno(13,2)=reshape((/ &
2720 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2721 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2722
2723INTEGER(KIND=int_ll),PARAMETER :: &
2724 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2725
2729INTERFACE init
2730 MODULE PROCEDURE datetime_init, timedelta_init
2731END INTERFACE
2732
2735INTERFACE delete
2736 MODULE PROCEDURE datetime_delete, timedelta_delete
2737END INTERFACE
2738
2740INTERFACE getval
2741 MODULE PROCEDURE datetime_getval, timedelta_getval
2742END INTERFACE
2743
2745INTERFACE to_char
2746 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2747END INTERFACE
2748
2749
2767INTERFACE t2c
2768 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2769END INTERFACE
2770
2776INTERFACE OPERATOR (==)
2777 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2778 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2779END INTERFACE
2780
2786INTERFACE OPERATOR (/=)
2787 MODULE PROCEDURE datetime_ne, timedelta_ne
2788END INTERFACE
2789
2797INTERFACE OPERATOR (>)
2798 MODULE PROCEDURE datetime_gt, timedelta_gt
2799END INTERFACE
2800
2808INTERFACE OPERATOR (<)
2809 MODULE PROCEDURE datetime_lt, timedelta_lt
2810END INTERFACE
2811
2819INTERFACE OPERATOR (>=)
2820 MODULE PROCEDURE datetime_ge, timedelta_ge
2821END INTERFACE
2822
2830INTERFACE OPERATOR (<=)
2831 MODULE PROCEDURE datetime_le, timedelta_le
2832END INTERFACE
2833
2840INTERFACE OPERATOR (+)
2841 MODULE PROCEDURE datetime_add, timedelta_add
2842END INTERFACE
2843
2851INTERFACE OPERATOR (-)
2852 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
2853END INTERFACE
2854
2860INTERFACE OPERATOR (*)
2861 MODULE PROCEDURE timedelta_mult, timedelta_tlum
2862END INTERFACE
2863
2870INTERFACE OPERATOR (/)
2871 MODULE PROCEDURE timedelta_divint, timedelta_divtd
2872END INTERFACE
2873
2884INTERFACE mod
2885 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2886END INTERFACE
2887
2890INTERFACE abs
2891 MODULE PROCEDURE timedelta_abs
2892END INTERFACE
2893
2896INTERFACE read_unit
2897 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2898 timedelta_read_unit, timedelta_vect_read_unit
2899END INTERFACE
2900
2903INTERFACE write_unit
2904 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2905 timedelta_write_unit, timedelta_vect_write_unit
2906END INTERFACE
2907
2909INTERFACE display
2910 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2911END INTERFACE
2912
2914INTERFACE c_e
2915 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
2916END INTERFACE
2917
2918#undef VOL7D_POLY_TYPE
2919#undef VOL7D_POLY_TYPES
2920#undef ENABLE_SORT
2921#define VOL7D_POLY_TYPE TYPE(datetime)
2922#define VOL7D_POLY_TYPES _datetime
2923#define ENABLE_SORT
2924#include "array_utilities_pre.F90"
2925
2926
2927#define ARRAYOF_ORIGTYPE TYPE(datetime)
2928#define ARRAYOF_TYPE arrayof_datetime
2929#define ARRAYOF_ORIGEQ 1
2930#include "arrayof_pre.F90"
2931! from arrayof
2932
2933PRIVATE
2934
2935PUBLIC datetime, datetime_miss, datetime_utc, datetime_local, &
2936 datetime_min, datetime_max, &
2937 datetime_new, datetime_new_now, init, delete, getval, to_char, t2c, &
2939 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2940 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2941 OPERATOR(*), OPERATOR(/), mod, abs, &
2942 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2943 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2944 display, c_e, &
2945 count_distinct, pack_distinct, &
2946 count_distinct_sorted, pack_distinct_sorted, &
2947 count_and_pack_distinct, &
2948 map_distinct, map_inv_distinct, index, index_sorted, sort, &
2949 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
2950PUBLIC insert, append, remove, packarray
2951PUBLIC insert_unique, append_unique
2952PUBLIC cyclicdatetime_to_conventional
2953
2954CONTAINS
2955
2956
2957! ==============
2958! == datetime ==
2959! ==============
2960
2967ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
2968 unixtime, isodate, simpledate) RESULT(this)
2969INTEGER,INTENT(IN),OPTIONAL :: year
2970INTEGER,INTENT(IN),OPTIONAL :: month
2971INTEGER,INTENT(IN),OPTIONAL :: day
2972INTEGER,INTENT(IN),OPTIONAL :: hour
2973INTEGER,INTENT(IN),OPTIONAL :: minute
2974INTEGER,INTENT(IN),OPTIONAL :: msec
2975INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2976CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2977CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2978
2979TYPE(datetime) :: this
2980INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2981CHARACTER(len=23) :: datebuf
2982
2983IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
2984 lyear = year
2985 IF (PRESENT(month)) THEN
2986 lmonth = month
2987 ELSE
2988 lmonth = 1
2989 ENDIF
2990 IF (PRESENT(day)) THEN
2991 lday = day
2992 ELSE
2993 lday = 1
2994 ENDIF
2995 IF (PRESENT(hour)) THEN
2996 lhour = hour
2997 ELSE
2998 lhour = 0
2999 ENDIF
3000 IF (PRESENT(minute)) THEN
3001 lminute = minute
3002 ELSE
3003 lminute = 0
3004 ENDIF
3005 IF (PRESENT(msec)) THEN
3006 lmsec = msec
3007 ELSE
3008 lmsec = 0
3009 ENDIF
3010
3011 if (c_e(lday) .and. c_e(lmonth) .and. c_e(lyear) .and. c_e(lhour) &
3012 .and. c_e(lminute) .and. c_e(lmsec)) then
3013 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3014 else
3015 this=datetime_miss
3016 end if
3017
3018ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3019 if (c_e(unixtime)) then
3020 this%iminuti = (unixtime + unsec)*1000
3021 else
3022 this=datetime_miss
3023 end if
3024
3025ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3026
3027 IF (c_e(isodate) .AND. len_trim(isodate) > 0) THEN
3028 datebuf(1:23) = '0001-01-01 00:00:00.000'
3029 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3030 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3031 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3032 lmsec = lmsec + lsec*1000
3033 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3034 RETURN
3035
3036100 CONTINUE ! condizione di errore in isodate
3037 CALL delete(this)
3038 RETURN
3039 ELSE
3040 this = datetime_miss
3041 ENDIF
3042
3043ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3044 IF (c_e(simpledate) .AND. len_trim(simpledate) > 0)THEN
3045 datebuf(1:17) = '00010101000000000'
3046 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3047 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3048 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3049 lmsec = lmsec + lsec*1000
3050 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3051 RETURN
3052
3053120 CONTINUE ! condizione di errore in simpledate
3054 CALL delete(this)
3055 RETURN
3056 ELSE
3057 this = datetime_miss
3058 ENDIF
3059
3060ELSE
3061 this = datetime_miss
3062ENDIF
3063
3064END FUNCTION datetime_new
3065
3066
3068FUNCTION datetime_new_now(now) RESULT(this)
3069INTEGER,INTENT(IN) :: now
3070TYPE(datetime) :: this
3071
3072INTEGER :: dt(8)
3073
3074IF (c_e(now)) THEN
3075 CALL date_and_time(values=dt)
3076 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3077 CALL init(this, year=dt(1), month=dt(2), day=dt(3), hour=dt(5), minute=dt(6), &
3078 msec=dt(7)*1000+dt(8))
3079ELSE
3080 this = datetime_miss
3081ENDIF
3082
3083END FUNCTION datetime_new_now
3084
3085
3092SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3093 unixtime, isodate, simpledate, now)
3094TYPE(datetime),INTENT(INOUT) :: this
3095INTEGER,INTENT(IN),OPTIONAL :: year
3096INTEGER,INTENT(IN),OPTIONAL :: month
3097INTEGER,INTENT(IN),OPTIONAL :: day
3098INTEGER,INTENT(IN),OPTIONAL :: hour
3099INTEGER,INTENT(IN),OPTIONAL :: minute
3100INTEGER,INTENT(IN),OPTIONAL :: msec
3101INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3102CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3103CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3104INTEGER,INTENT(IN),OPTIONAL :: now
3105
3106IF (PRESENT(now)) THEN
3107 this = datetime_new_now(now)
3108ELSE
3109 this = datetime_new(year, month, day, hour, minute, msec, &
3110 unixtime, isodate, simpledate)
3111ENDIF
3112
3113END SUBROUTINE datetime_init
3114
3115
3116ELEMENTAL SUBROUTINE datetime_delete(this)
3117TYPE(datetime),INTENT(INOUT) :: this
3118
3119this%iminuti = illmiss
3120
3121END SUBROUTINE datetime_delete
3122
3123
3128PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3129 unixtime, isodate, simpledate, oraclesimdate)
3130TYPE(datetime),INTENT(IN) :: this
3131INTEGER,INTENT(OUT),OPTIONAL :: year
3132INTEGER,INTENT(OUT),OPTIONAL :: month
3133INTEGER,INTENT(OUT),OPTIONAL :: day
3134INTEGER,INTENT(OUT),OPTIONAL :: hour
3135INTEGER,INTENT(OUT),OPTIONAL :: minute
3136INTEGER,INTENT(OUT),OPTIONAL :: msec
3137INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3138CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3139CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3140CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3141
3142INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3143CHARACTER(len=23) :: datebuf
3144
3145IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3146 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3147 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3148
3149 IF (this == datetime_miss) THEN
3150
3151 IF (PRESENT(msec)) THEN
3152 msec = imiss
3153 ENDIF
3154 IF (PRESENT(minute)) THEN
3155 minute = imiss
3156 ENDIF
3157 IF (PRESENT(hour)) THEN
3158 hour = imiss
3159 ENDIF
3160 IF (PRESENT(day)) THEN
3161 day = imiss
3162 ENDIF
3163 IF (PRESENT(month)) THEN
3164 month = imiss
3165 ENDIF
3166 IF (PRESENT(year)) THEN
3167 year = imiss
3168 ENDIF
3169 IF (PRESENT(isodate)) THEN
3170 isodate = cmiss
3171 ENDIF
3172 IF (PRESENT(simpledate)) THEN
3173 simpledate = cmiss
3174 ENDIF
3175 IF (PRESENT(oraclesimdate)) THEN
3176!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3177!!$ 'obsoleto, usare piuttosto simpledate')
3178 oraclesimdate=cmiss
3179 ENDIF
3180 IF (PRESENT(unixtime)) THEN
3181 unixtime = illmiss
3182 ENDIF
3183
3184 ELSE
3185
3186 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3187 IF (PRESENT(msec)) THEN
3188 msec = lmsec
3189 ENDIF
3190 IF (PRESENT(minute)) THEN
3191 minute = lminute
3192 ENDIF
3193 IF (PRESENT(hour)) THEN
3194 hour = lhour
3195 ENDIF
3196 IF (PRESENT(day)) THEN
3197 day = lday
3198 ENDIF
3199 IF (PRESENT(month)) THEN
3200 month = lmonth
3201 ENDIF
3202 IF (PRESENT(year)) THEN
3203 year = lyear
3204 ENDIF
3205 IF (PRESENT(isodate)) THEN
3206 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3207 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3208 '.', mod(lmsec, 1000)
3209 isodate = datebuf(1:min(len(isodate),23))
3210 ENDIF
3211 IF (PRESENT(simpledate)) THEN
3212 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3213 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3214 simpledate = datebuf(1:min(len(simpledate),17))
3215 ENDIF
3216 IF (PRESENT(oraclesimdate)) THEN
3217!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3218!!$ 'obsoleto, usare piuttosto simpledate')
3219 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3220 ENDIF
3221 IF (PRESENT(unixtime)) THEN
3222 unixtime = this%iminuti/1000_int_ll-unsec
3223 ENDIF
3224
3225 ENDIF
3226ENDIF
3227
3228END SUBROUTINE datetime_getval
3229
3230
3233elemental FUNCTION datetime_to_char(this) RESULT(char)
3234TYPE(datetime),INTENT(IN) :: this
3235
3236CHARACTER(len=23) :: char
3237
3238CALL getval(this, isodate=char)
3239
3240END FUNCTION datetime_to_char
3241
3242
3243FUNCTION trim_datetime_to_char(in) RESULT(char)
3244TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3245
3246CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3247
3248char=datetime_to_char(in)
3249
3250END FUNCTION trim_datetime_to_char
3251
3252
3253
3254SUBROUTINE display_datetime(this)
3255TYPE(datetime),INTENT(in) :: this
3256
3257print*,"TIME: ",to_char(this)
3258
3259end subroutine display_datetime
3260
3261
3262
3263SUBROUTINE display_timedelta(this)
3264TYPE(timedelta),INTENT(in) :: this
3265
3266print*,"TIMEDELTA: ",to_char(this)
3267
3268end subroutine display_timedelta
3269
3270
3271
3272ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3273TYPE(datetime),INTENT(in) :: this
3274LOGICAL :: res
3275
3276res = .not. this == datetime_miss
3277
3278end FUNCTION c_e_datetime
3279
3280
3281ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3282TYPE(datetime),INTENT(IN) :: this, that
3283LOGICAL :: res
3284
3285res = this%iminuti == that%iminuti
3286
3287END FUNCTION datetime_eq
3288
3289
3290ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3291TYPE(datetime),INTENT(IN) :: this, that
3292LOGICAL :: res
3293
3294res = .NOT.(this == that)
3295
3296END FUNCTION datetime_ne
3297
3298
3299ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3300TYPE(datetime),INTENT(IN) :: this, that
3301LOGICAL :: res
3302
3303res = this%iminuti > that%iminuti
3304
3305END FUNCTION datetime_gt
3306
3307
3308ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3309TYPE(datetime),INTENT(IN) :: this, that
3310LOGICAL :: res
3311
3312res = this%iminuti < that%iminuti
3313
3314END FUNCTION datetime_lt
3315
3316
3317ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3318TYPE(datetime),INTENT(IN) :: this, that
3319LOGICAL :: res
3320
3321IF (this == that) THEN
3322 res = .true.
3323ELSE IF (this > that) THEN
3324 res = .true.
3325ELSE
3326 res = .false.
3327ENDIF
3328
3329END FUNCTION datetime_ge
3330
3331
3332ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3333TYPE(datetime),INTENT(IN) :: this, that
3334LOGICAL :: res
3335
3336IF (this == that) THEN
3337 res = .true.
3338ELSE IF (this < that) THEN
3339 res = .true.
3340ELSE
3341 res = .false.
3342ENDIF
3343
3344END FUNCTION datetime_le
3345
3346
3347FUNCTION datetime_add(this, that) RESULT(res)
3348TYPE(datetime),INTENT(IN) :: this
3349TYPE(timedelta),INTENT(IN) :: that
3350TYPE(datetime) :: res
3351
3352INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3353
3354IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3355 res = datetime_miss
3356ELSE
3357 res%iminuti = this%iminuti + that%iminuti
3358 IF (that%month /= 0) THEN
3359 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3360 minute=lminute, msec=lmsec)
3361 CALL init(res, year=lyear, month=lmonth+that%month, day=lday, &
3362 hour=lhour, minute=lminute, msec=lmsec)
3363 ENDIF
3364ENDIF
3365
3366END FUNCTION datetime_add
3367
3368
3369ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3370TYPE(datetime),INTENT(IN) :: this, that
3371TYPE(timedelta) :: res
3372
3373IF (this == datetime_miss .OR. that == datetime_miss) THEN
3374 res = timedelta_miss
3375ELSE
3376 res%iminuti = this%iminuti - that%iminuti
3377 res%month = 0
3378ENDIF
3379
3380END FUNCTION datetime_subdt
3381
3382
3383FUNCTION datetime_subtd(this, that) RESULT(res)
3384TYPE(datetime),INTENT(IN) :: this
3385TYPE(timedelta),INTENT(IN) :: that
3386TYPE(datetime) :: res
3387
3388INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3389
3390IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3391 res = datetime_miss
3392ELSE
3393 res%iminuti = this%iminuti - that%iminuti
3394 IF (that%month /= 0) THEN
3395 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3396 minute=lminute, msec=lmsec)
3397 CALL init(res, year=lyear, month=lmonth-that%month, day=lday, &
3398 hour=lhour, minute=lminute, msec=lmsec)
3399 ENDIF
3400ENDIF
3401
3402END FUNCTION datetime_subtd
3403
3404
3409SUBROUTINE datetime_read_unit(this, unit)
3410TYPE(datetime),INTENT(out) :: this
3411INTEGER, INTENT(in) :: unit
3412CALL datetime_vect_read_unit((/this/), unit)
3413
3414END SUBROUTINE datetime_read_unit
3415
3416
3421SUBROUTINE datetime_vect_read_unit(this, unit)
3422TYPE(datetime) :: this(:)
3423INTEGER, INTENT(in) :: unit
3424
3425CHARACTER(len=40) :: form
3426CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3427INTEGER :: i
3428
3429ALLOCATE(dateiso(SIZE(this)))
3430INQUIRE(unit, form=form)
3431IF (form == 'FORMATTED') THEN
3432 READ(unit,'(A23,1X)')dateiso
3433ELSE
3434 READ(unit)dateiso
3435ENDIF
3436DO i = 1, SIZE(dateiso)
3437 CALL init(this(i), isodate=dateiso(i))
3438ENDDO
3439DEALLOCATE(dateiso)
3440
3441END SUBROUTINE datetime_vect_read_unit
3442
3443
3448SUBROUTINE datetime_write_unit(this, unit)
3449TYPE(datetime),INTENT(in) :: this
3450INTEGER, INTENT(in) :: unit
3451
3452CALL datetime_vect_write_unit((/this/), unit)
3453
3454END SUBROUTINE datetime_write_unit
3455
3456
3461SUBROUTINE datetime_vect_write_unit(this, unit)
3462TYPE(datetime),INTENT(in) :: this(:)
3463INTEGER, INTENT(in) :: unit
3464
3465CHARACTER(len=40) :: form
3466CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3467INTEGER :: i
3468
3469ALLOCATE(dateiso(SIZE(this)))
3470DO i = 1, SIZE(dateiso)
3471 CALL getval(this(i), isodate=dateiso(i))
3472ENDDO
3473INQUIRE(unit, form=form)
3474IF (form == 'FORMATTED') THEN
3475 WRITE(unit,'(A23,1X)')dateiso
3476ELSE
3477 WRITE(unit)dateiso
3478ENDIF
3479DEALLOCATE(dateiso)
3480
3481END SUBROUTINE datetime_vect_write_unit
3482
3483
3484#include "arrayof_post.F90"
3485
3486
3487! ===============
3488! == timedelta ==
3489! ===============
3496FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3497 isodate, simpledate, oraclesimdate) RESULT (this)
3498INTEGER,INTENT(IN),OPTIONAL :: year
3499INTEGER,INTENT(IN),OPTIONAL :: month
3500INTEGER,INTENT(IN),OPTIONAL :: day
3501INTEGER,INTENT(IN),OPTIONAL :: hour
3502INTEGER,INTENT(IN),OPTIONAL :: minute
3503INTEGER,INTENT(IN),OPTIONAL :: sec
3504INTEGER,INTENT(IN),OPTIONAL :: msec
3505CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3506CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3507CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3508
3509TYPE(timedelta) :: this
3510
3511CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3512 isodate, simpledate, oraclesimdate)
3513
3514END FUNCTION timedelta_new
3515
3516
3521SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3522 isodate, simpledate, oraclesimdate)
3523TYPE(timedelta),INTENT(INOUT) :: this
3524INTEGER,INTENT(IN),OPTIONAL :: year
3525INTEGER,INTENT(IN),OPTIONAL :: month
3526INTEGER,INTENT(IN),OPTIONAL :: day
3527INTEGER,INTENT(IN),OPTIONAL :: hour
3528INTEGER,INTENT(IN),OPTIONAL :: minute
3529INTEGER,INTENT(IN),OPTIONAL :: sec
3530INTEGER,INTENT(IN),OPTIONAL :: msec
3531CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3532CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3533CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3534
3535INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3536CHARACTER(len=23) :: datebuf
3537
3538this%month = 0
3539
3540IF (PRESENT(isodate)) THEN
3541 datebuf(1:23) = '0000000000 00:00:00.000'
3542 l = len_trim(isodate)
3543! IF (l > 0) THEN
3544 n = index(trim(isodate), ' ') ! align blank space separator
3545 IF (n > 0) THEN
3546 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3547 datebuf(12-n:12-n+l-1) = isodate(:l)
3548 ELSE
3549 datebuf(1:l) = isodate(1:l)
3550 ENDIF
3551! ENDIF
3552
3553! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3554 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3555 h, m, s, ms
3556 this%month = lmonth + 12*lyear
3557 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3558 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3559 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3560 RETURN
3561
3562200 CONTINUE ! condizione di errore in isodate
3563 CALL delete(this)
3564 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3565 CALL raise_error()
3566
3567ELSE IF (PRESENT(simpledate)) THEN
3568 datebuf(1:17) = '00000000000000000'
3569 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3570 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3571 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3572 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3573 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3574
3575220 CONTINUE ! condizione di errore in simpledate
3576 CALL delete(this)
3577 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3578 CALL raise_error()
3579 RETURN
3580
3581ELSE IF (PRESENT(oraclesimdate)) THEN
3582 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3583 'obsoleto, usare piuttosto simpledate')
3584 READ(oraclesimdate, '(I8,2I2)')d, h, m
3585 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3586 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3587
3588ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3589 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3590 .and. .not. present(msec) .and. .not. present(isodate) &
3591 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3592
3593 this=timedelta_miss
3594
3595ELSE
3596 this%iminuti = 0
3597 IF (PRESENT(year)) THEN
3598 if (c_e(year))then
3599 this%month = this%month + year*12
3600 else
3601 this=timedelta_miss
3602 return
3603 end if
3604 ENDIF
3605 IF (PRESENT(month)) THEN
3606 if (c_e(month))then
3607 this%month = this%month + month
3608 else
3609 this=timedelta_miss
3610 return
3611 end if
3612 ENDIF
3613 IF (PRESENT(day)) THEN
3614 if (c_e(day))then
3615 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3616 else
3617 this=timedelta_miss
3618 return
3619 end if
3620 ENDIF
3621 IF (PRESENT(hour)) THEN
3622 if (c_e(hour))then
3623 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3624 else
3625 this=timedelta_miss
3626 return
3627 end if
3628 ENDIF
3629 IF (PRESENT(minute)) THEN
3630 if (c_e(minute))then
3631 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3632 else
3633 this=timedelta_miss
3634 return
3635 end if
3636 ENDIF
3637 IF (PRESENT(sec)) THEN
3638 if (c_e(sec))then
3639 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3640 else
3641 this=timedelta_miss
3642 return
3643 end if
3644 ENDIF
3645 IF (PRESENT(msec)) THEN
3646 if (c_e(msec))then
3647 this%iminuti = this%iminuti + msec
3648 else
3649 this=timedelta_miss
3650 return
3651 end if
3652 ENDIF
3653ENDIF
3654
3655
3656
3657
3658END SUBROUTINE timedelta_init
3659
3660
3661SUBROUTINE timedelta_delete(this)
3662TYPE(timedelta),INTENT(INOUT) :: this
3663
3664this%iminuti = imiss
3665this%month = 0
3666
3667END SUBROUTINE timedelta_delete
3668
3669
3674PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3675 day, hour, minute, sec, msec, &
3676 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3677TYPE(timedelta),INTENT(IN) :: this
3678INTEGER,INTENT(OUT),OPTIONAL :: year
3679INTEGER,INTENT(OUT),OPTIONAL :: month
3680INTEGER,INTENT(OUT),OPTIONAL :: amonth
3681INTEGER,INTENT(OUT),OPTIONAL :: day
3682INTEGER,INTENT(OUT),OPTIONAL :: hour
3683INTEGER,INTENT(OUT),OPTIONAL :: minute
3684INTEGER,INTENT(OUT),OPTIONAL :: sec
3685INTEGER,INTENT(OUT),OPTIONAL :: msec
3686INTEGER,INTENT(OUT),OPTIONAL :: ahour
3687INTEGER,INTENT(OUT),OPTIONAL :: aminute
3688INTEGER,INTENT(OUT),OPTIONAL :: asec
3689INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
3690CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3691CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3692CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3693
3694CHARACTER(len=23) :: datebuf
3695
3696IF (PRESENT(amsec)) THEN
3697 amsec = this%iminuti
3698ENDIF
3699IF (PRESENT(asec)) THEN
3700 asec = int(this%iminuti/1000_int_ll)
3701ENDIF
3702IF (PRESENT(aminute)) THEN
3703 aminute = int(this%iminuti/60000_int_ll)
3704ENDIF
3705IF (PRESENT(ahour)) THEN
3706 ahour = int(this%iminuti/3600000_int_ll)
3707ENDIF
3708IF (PRESENT(msec)) THEN
3709 msec = int(mod(this%iminuti, 1000_int_ll))
3710ENDIF
3711IF (PRESENT(sec)) THEN
3712 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3713ENDIF
3714IF (PRESENT(minute)) THEN
3715 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3716ENDIF
3717IF (PRESENT(hour)) THEN
3718 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3719ENDIF
3720IF (PRESENT(day)) THEN
3721 day = int(this%iminuti/86400000_int_ll)
3722ENDIF
3723IF (PRESENT(amonth)) THEN
3724 amonth = this%month
3725ENDIF
3726IF (PRESENT(month)) THEN
3727 month = mod(this%month-1,12)+1
3728ENDIF
3729IF (PRESENT(year)) THEN
3730 year = this%month/12
3731ENDIF
3732IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3733 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3734 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), ':', &
3735 mod(this%iminuti/60000_int_ll, 60_int_ll), ':', mod(this%iminuti/1000_int_ll, 60_int_ll), &
3736 '.', mod(this%iminuti, 1000_int_ll)
3737 isodate = datebuf(1:min(len(isodate),23))
3738
3739ENDIF
3740IF (PRESENT(simpledate)) THEN
3741 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3742 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3743 mod(this%iminuti/60000_int_ll, 60_int_ll), mod(this%iminuti/1000_int_ll, 60_int_ll), &
3744 mod(this%iminuti, 1000_int_ll)
3745 simpledate = datebuf(1:min(len(simpledate),17))
3746ENDIF
3747IF (PRESENT(oraclesimdate)) THEN
3748!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3749!!$ 'obsoleto, usare piuttosto simpledate')
3750 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3751 mod(this%iminuti/3600000_int_ll, 24_int_ll), mod(this%iminuti/60000_int_ll, 60_int_ll)
3752ENDIF
3753
3754END SUBROUTINE timedelta_getval
3755
3756
3759elemental FUNCTION timedelta_to_char(this) RESULT(char)
3760TYPE(timedelta),INTENT(IN) :: this
3761
3762CHARACTER(len=23) :: char
3763
3764CALL getval(this, isodate=char)
3765
3766END FUNCTION timedelta_to_char
3767
3768
3769FUNCTION trim_timedelta_to_char(in) RESULT(char)
3770TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3771
3772CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3773
3774char=timedelta_to_char(in)
3775
3776END FUNCTION trim_timedelta_to_char
3777
3778
3780elemental FUNCTION timedelta_getamsec(this)
3781TYPE(timedelta),INTENT(IN) :: this
3782INTEGER(kind=int_ll) :: timedelta_getamsec
3783
3784timedelta_getamsec = this%iminuti
3785
3786END FUNCTION timedelta_getamsec
3787
3788
3794FUNCTION timedelta_depop(this)
3795TYPE(timedelta),INTENT(IN) :: this
3796TYPE(timedelta) :: timedelta_depop
3797
3798TYPE(datetime) :: tmpdt
3799
3800IF (this%month == 0) THEN
3801 timedelta_depop = this
3802ELSE
3803 tmpdt = datetime_new(1970, 1, 1)
3804 timedelta_depop = (tmpdt + this) - tmpdt
3805ENDIF
3806
3807END FUNCTION timedelta_depop
3808
3809
3810elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3811TYPE(timedelta),INTENT(IN) :: this, that
3812LOGICAL :: res
3813
3814res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3815
3816END FUNCTION timedelta_eq
3817
3818
3819ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3820TYPE(timedelta),INTENT(IN) :: this, that
3821LOGICAL :: res
3822
3823res = .NOT.(this == that)
3824
3825END FUNCTION timedelta_ne
3826
3827
3828ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
3829TYPE(timedelta),INTENT(IN) :: this, that
3830LOGICAL :: res
3831
3832res = this%iminuti > that%iminuti
3833
3834END FUNCTION timedelta_gt
3835
3836
3837ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
3838TYPE(timedelta),INTENT(IN) :: this, that
3839LOGICAL :: res
3840
3841res = this%iminuti < that%iminuti
3842
3843END FUNCTION timedelta_lt
3844
3845
3846ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
3847TYPE(timedelta),INTENT(IN) :: this, that
3848LOGICAL :: res
3849
3850IF (this == that) THEN
3851 res = .true.
3852ELSE IF (this > that) THEN
3853 res = .true.
3854ELSE
3855 res = .false.
3856ENDIF
3857
3858END FUNCTION timedelta_ge
3859
3860
3861elemental FUNCTION timedelta_le(this, that) RESULT(res)
3862TYPE(timedelta),INTENT(IN) :: this, that
3863LOGICAL :: res
3864
3865IF (this == that) THEN
3866 res = .true.
3867ELSE IF (this < that) THEN
3868 res = .true.
3869ELSE
3870 res = .false.
3871ENDIF
3872
3873END FUNCTION timedelta_le
3874
3875
3876ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
3877TYPE(timedelta),INTENT(IN) :: this, that
3878TYPE(timedelta) :: res
3879
3880res%iminuti = this%iminuti + that%iminuti
3881res%month = this%month + that%month
3882
3883END FUNCTION timedelta_add
3884
3885
3886ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
3887TYPE(timedelta),INTENT(IN) :: this, that
3888TYPE(timedelta) :: res
3889
3890res%iminuti = this%iminuti - that%iminuti
3891res%month = this%month - that%month
3892
3893END FUNCTION timedelta_sub
3894
3895
3896ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
3897TYPE(timedelta),INTENT(IN) :: this
3898INTEGER,INTENT(IN) :: n
3899TYPE(timedelta) :: res
3900
3901res%iminuti = this%iminuti*n
3902res%month = this%month*n
3903
3904END FUNCTION timedelta_mult
3905
3906
3907ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
3908INTEGER,INTENT(IN) :: n
3909TYPE(timedelta),INTENT(IN) :: this
3910TYPE(timedelta) :: res
3911
3912res%iminuti = this%iminuti*n
3913res%month = this%month*n
3914
3915END FUNCTION timedelta_tlum
3916
3917
3918ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
3919TYPE(timedelta),INTENT(IN) :: this
3920INTEGER,INTENT(IN) :: n
3921TYPE(timedelta) :: res
3922
3923res%iminuti = this%iminuti/n
3924res%month = this%month/n
3925
3926END FUNCTION timedelta_divint
3927
3928
3929ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
3930TYPE(timedelta),INTENT(IN) :: this, that
3931INTEGER :: res
3932
3933res = int(this%iminuti/that%iminuti)
3934
3935END FUNCTION timedelta_divtd
3936
3937
3938elemental FUNCTION timedelta_mod(this, that) RESULT(res)
3939TYPE(timedelta),INTENT(IN) :: this, that
3940TYPE(timedelta) :: res
3941
3942res%iminuti = mod(this%iminuti, that%iminuti)
3943res%month = 0
3944
3945END FUNCTION timedelta_mod
3946
3947
3948ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
3949TYPE(datetime),INTENT(IN) :: this
3950TYPE(timedelta),INTENT(IN) :: that
3951TYPE(timedelta) :: res
3952
3953IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
3954 res = timedelta_0
3955ELSE
3956 res%iminuti = mod(this%iminuti, that%iminuti)
3957 res%month = 0
3958ENDIF
3959
3960END FUNCTION datetime_timedelta_mod
3961
3962
3963ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
3964TYPE(timedelta),INTENT(IN) :: this
3965TYPE(timedelta) :: res
3966
3967res%iminuti = abs(this%iminuti)
3968res%month = abs(this%month)
3969
3970END FUNCTION timedelta_abs
3971
3972
3977SUBROUTINE timedelta_read_unit(this, unit)
3978TYPE(timedelta),INTENT(out) :: this
3979INTEGER, INTENT(in) :: unit
3980
3981CALL timedelta_vect_read_unit((/this/), unit)
3982
3983END SUBROUTINE timedelta_read_unit
3984
3985
3990SUBROUTINE timedelta_vect_read_unit(this, unit)
3991TYPE(timedelta) :: this(:)
3992INTEGER, INTENT(in) :: unit
3993
3994CHARACTER(len=40) :: form
3995CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3996INTEGER :: i
3997
3998ALLOCATE(dateiso(SIZE(this)))
3999INQUIRE(unit, form=form)
4000IF (form == 'FORMATTED') THEN
4001 READ(unit,'(3(A23,1X))')dateiso
4002ELSE
4003 READ(unit)dateiso
4004ENDIF
4005DO i = 1, SIZE(dateiso)
4006 CALL init(this(i), isodate=dateiso(i))
4007ENDDO
4008DEALLOCATE(dateiso)
4009
4010END SUBROUTINE timedelta_vect_read_unit
4011
4012
4017SUBROUTINE timedelta_write_unit(this, unit)
4018TYPE(timedelta),INTENT(in) :: this
4019INTEGER, INTENT(in) :: unit
4020
4021CALL timedelta_vect_write_unit((/this/), unit)
4022
4023END SUBROUTINE timedelta_write_unit
4024
4025
4030SUBROUTINE timedelta_vect_write_unit(this, unit)
4031TYPE(timedelta),INTENT(in) :: this(:)
4032INTEGER, INTENT(in) :: unit
4033
4034CHARACTER(len=40) :: form
4035CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4036INTEGER :: i
4037
4038ALLOCATE(dateiso(SIZE(this)))
4039DO i = 1, SIZE(dateiso)
4040 CALL getval(this(i), isodate=dateiso(i))
4041ENDDO
4042INQUIRE(unit, form=form)
4043IF (form == 'FORMATTED') THEN
4044 WRITE(unit,'(3(A23,1X))')dateiso
4045ELSE
4046 WRITE(unit)dateiso
4047ENDIF
4048DEALLOCATE(dateiso)
4049
4050END SUBROUTINE timedelta_vect_write_unit
4051
4052
4053ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4054TYPE(timedelta),INTENT(in) :: this
4055LOGICAL :: res
4056
4057res = .not. this == timedelta_miss
4058
4059end FUNCTION c_e_timedelta
4060
4061
4062elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4063
4064!!omstart JELADATA5
4065! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4066! 1 IMINUTI)
4067!
4068! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4069!
4070! variabili integer*4
4071! IN:
4072! IDAY,IMONTH,IYEAR, I*4
4073! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4074!
4075! OUT:
4076! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4077!!OMEND
4078
4079INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4080INTEGER,intent(out) :: iminuti
4081
4082iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4083
4084END SUBROUTINE jeladata5
4085
4086
4087elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4088INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4089INTEGER(KIND=int_ll),intent(out) :: imillisec
4090
4091imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4092 + imsec
4093
4094END SUBROUTINE jeladata5_1
4095
4096
4097
4098elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4099
4100!!omstart JELADATA6
4101! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4102! 1 IMINUTI)
4103!
4104! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4105! 1/1/1
4106!
4107! variabili integer*4
4108! IN:
4109! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4110!
4111! OUT:
4112! IDAY,IMONTH,IYEAR, I*4
4113! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4114!!OMEND
4115
4116
4117INTEGER,intent(in) :: iminuti
4118INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4119
4120INTEGER ::igiorno
4121
4122imin = mod(iminuti,60)
4123ihour = mod(iminuti,1440)/60
4124igiorno = iminuti/1440
4125IF (mod(iminuti,1440) < 0) igiorno = igiorno-1
4126CALL ndyin(igiorno,iday,imonth,iyear)
4127
4128END SUBROUTINE jeladata6
4129
4130
4131elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4132INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4133INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4134
4135INTEGER :: igiorno
4136
4137imsec = int(mod(imillisec, 60000_int_ll)) ! partial msec
4138!imin = MOD(imillisec/60000_int_ll, 60)
4139!ihour = MOD(imillisec/3600000_int_ll, 24)
4140imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4141ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4142igiorno = int(imillisec/86400000_int_ll)
4143!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4144CALL ndyin(igiorno,iday,imonth,iyear)
4145
4146END SUBROUTINE jeladata6_1
4147
4148
4149elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4150
4151!!OMSTART NDYIN
4152! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4153! restituisce la data fornendo in input il numero di
4154! giorni dal 1/1/1
4155!
4156!!omend
4157
4158INTEGER,intent(in) :: ndays
4159INTEGER,intent(out) :: igg, imm, iaa
4160integer :: n,lndays
4161
4162lndays=ndays
4163
4164n = lndays/d400
4165lndays = lndays - n*d400
4166iaa = year0 + n*400
4167n = min(lndays/d100, 3)
4168lndays = lndays - n*d100
4169iaa = iaa + n*100
4170n = lndays/d4
4171lndays = lndays - n*d4
4172iaa = iaa + n*4
4173n = min(lndays/d1, 3)
4174lndays = lndays - n*d1
4175iaa = iaa + n
4176n = bisextilis(iaa)
4177DO imm = 1, 12
4178 IF (lndays < ianno(imm+1,n)) EXIT
4179ENDDO
4180igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4181
4182END SUBROUTINE ndyin
4183
4184
4185integer elemental FUNCTION ndays(igg,imm,iaa)
4186
4187!!OMSTART NDAYS
4188! FUNCTION NDAYS(IGG,IMM,IAA)
4189! restituisce il numero di giorni dal 1/1/1
4190! fornendo in input la data
4191!
4192!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4193! nota bene E' SICURO !!!
4194! un anno e' bisestile se divisibile per 4
4195! un anno rimane bisestile se divisibile per 400
4196! un anno NON e' bisestile se divisibile per 100
4197!
4198!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4199!
4200!!omend
4201
4202INTEGER, intent(in) :: igg, imm, iaa
4203
4204INTEGER :: lmonth, lyear
4205
4206! Limito il mese a [1-12] e correggo l'anno coerentemente
4207lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4208lyear = iaa + (imm - lmonth)/12
4209ndays = igg+ianno(lmonth, bisextilis(lyear))
4210ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4211 (lyear-year0)/400
4212
4213END FUNCTION ndays
4214
4215
4216elemental FUNCTION bisextilis(annum)
4217INTEGER,INTENT(in) :: annum
4218INTEGER :: bisextilis
4219
4220IF (mod(annum,4) == 0 .AND. (mod(annum,400) == 0 .EQV. mod(annum,100) == 0)) THEN
4221 bisextilis = 2
4222ELSE
4223 bisextilis = 1
4224ENDIF
4225END FUNCTION bisextilis
4226
4227
4228ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4229TYPE(cyclicdatetime),INTENT(IN) :: this, that
4230LOGICAL :: res
4231
4232res = .true.
4233if (this%minute /= that%minute) res=.false.
4234if (this%hour /= that%hour) res=.false.
4235if (this%day /= that%day) res=.false.
4236if (this%month /= that%month) res=.false.
4237if (this%tendaysp /= that%tendaysp) res=.false.
4238
4239END FUNCTION cyclicdatetime_eq
4240
4241
4242ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4243TYPE(cyclicdatetime),INTENT(IN) :: this
4244TYPE(datetime),INTENT(IN) :: that
4245LOGICAL :: res
4246
4247integer :: minute,hour,day,month
4248
4249call getval(that,minute=minute,hour=hour,day=day,month=month)
4250
4251res = .true.
4252if (c_e(this%minute) .and. this%minute /= minute) res=.false.
4253if (c_e(this%hour) .and. this%hour /= hour) res=.false.
4254if (c_e(this%day) .and. this%day /= day) res=.false.
4255if (c_e(this%month) .and. this%month /= month) res=.false.
4256if (c_e(this%tendaysp)) then
4257 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4258end if
4259
4260END FUNCTION cyclicdatetime_datetime_eq
4261
4262
4263ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4264TYPE(datetime),INTENT(IN) :: this
4265TYPE(cyclicdatetime),INTENT(IN) :: that
4266LOGICAL :: res
4267
4268integer :: minute,hour,day,month
4269
4270call getval(this,minute=minute,hour=hour,day=day,month=month)
4271
4272res = .true.
4273if (c_e(that%minute) .and. that%minute /= minute) res=.false.
4274if (c_e(that%hour) .and. that%hour /= hour) res=.false.
4275if (c_e(that%day) .and. that%day /= day) res=.false.
4276if (c_e(that%month) .and. that%month /= month) res=.false.
4277
4278if (c_e(that%tendaysp)) then
4279 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4280end if
4281
4282
4283END FUNCTION datetime_cyclicdatetime_eq
4284
4285ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4286TYPE(cyclicdatetime),INTENT(in) :: this
4287LOGICAL :: res
4288
4289res = .not. this == cyclicdatetime_miss
4290
4291end FUNCTION c_e_cyclicdatetime
4292
4293
4296FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4297INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4298INTEGER,INTENT(IN),OPTIONAL :: month
4299INTEGER,INTENT(IN),OPTIONAL :: day
4300INTEGER,INTENT(IN),OPTIONAL :: hour
4301INTEGER,INTENT(IN),OPTIONAL :: minute
4302CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4303
4304integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4305
4306
4307TYPE(cyclicdatetime) :: this
4308
4309if (present(chardate)) then
4310
4311 ltendaysp=imiss
4312 lmonth=imiss
4313 lday=imiss
4314 lhour=imiss
4315 lminute=imiss
4316
4317 if (c_e(chardate))then
4318 ! TMMGGhhmm
4319 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4320 !print*,chardate(1:1),ios,ltendaysp
4321 if (ios /= 0)ltendaysp=imiss
4322
4323 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4324 !print*,chardate(2:3),ios,lmonth
4325 if (ios /= 0)lmonth=imiss
4326
4327 read(chardate(4:5),'(i2)',iostat=ios)lday
4328 !print*,chardate(4:5),ios,lday
4329 if (ios /= 0)lday=imiss
4330
4331 read(chardate(6:7),'(i2)',iostat=ios)lhour
4332 !print*,chardate(6:7),ios,lhour
4333 if (ios /= 0)lhour=imiss
4334
4335 read(chardate(8:9),'(i2)',iostat=ios)lminute
4336 !print*,chardate(8:9),ios,lminute
4337 if (ios /= 0)lminute=imiss
4338 end if
4339
4340 this%tendaysp=ltendaysp
4341 this%month=lmonth
4342 this%day=lday
4343 this%hour=lhour
4344 this%minute=lminute
4345else
4346 this%tendaysp=optio_l(tendaysp)
4347 this%month=optio_l(month)
4348 this%day=optio_l(day)
4349 this%hour=optio_l(hour)
4350 this%minute=optio_l(minute)
4351end if
4352
4353END FUNCTION cyclicdatetime_new
4354
4357elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4358TYPE(cyclicdatetime),INTENT(IN) :: this
4359
4360CHARACTER(len=80) :: char
4361
4362char=to_char(this%tendaysp)//";"//to_char(this%month)//";"//to_char(this%day)//";"//&
4363to_char(this%hour)//";"//to_char(this%minute)
4364
4365END FUNCTION cyclicdatetime_to_char
4366
4367
4380FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4381TYPE(cyclicdatetime),INTENT(IN) :: this
4382
4383TYPE(datetime) :: dtc
4384
4385integer :: year,month,day,hour
4386
4387dtc = datetime_miss
4388
4389! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4390if ( .not. c_e(this)) then
4391 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4392 return
4393end if
4394
4395! minute present -> not good for conventional datetime
4396if (c_e(this%minute)) return
4397! day, month and tendaysp present -> no good
4398if (c_e(this%day) .and. c_e(this%month) .and. c_e(this%tendaysp)) return
4399
4400if (c_e(this%day) .and. c_e(this%month)) then
4401 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4402else if (c_e(this%tendaysp) .and. c_e(this%month)) then
4403 day=(this%tendaysp-1)*10+1
4404 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4405else if (c_e(this%month)) then
4406 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4407else if (c_e(this%day)) then
4408 ! only day present -> no good
4409 return
4410end if
4411
4412if (c_e(this%hour)) then
4413 call getval(dtc,year=year,month=month,day=day,hour=hour)
4414 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4415end if
4416
4417
4418END FUNCTION cyclicdatetime_to_conventional
4419
4420
4421
4422FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4423TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4424
4425CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4426
4427char=cyclicdatetime_to_char(in)
4428
4429END FUNCTION trim_cyclicdatetime_to_char
4430
4431
4432
4433SUBROUTINE display_cyclicdatetime(this)
4434TYPE(cyclicdatetime),INTENT(in) :: this
4435
4436print*,"CYCLICDATETIME: ",to_char(this)
4437
4438end subroutine display_cyclicdatetime
4439
4440
4441#include "array_utilities_inc.F90"
4442
4443END MODULE datetime_class
4444
Operatore di valore assoluto di un intervallo.
Quick method to append an element to the array.
Distruttori per le 2 classi.
Restituiscono il valore dell'oggetto nella forma desiderata.
Index method with sorted array.
Costruttori per le classi datetime e timedelta.
Method for inserting elements of the array at a desired position.
Operatore di resto della divisione.
Method for packing the array object reducing at a minimum the memory occupation, without destroying i...
Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o...
Method for removing elements of the array at a desired position.
Functions that return a trimmed CHARACTER representation of the input variable.
Restituiscono il valore dell'oggetto in forma di stringa stampabile.
Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ...
Index method.
Utilities for CHARACTER variables.
Classi per la gestione delle coordinate temporali.
Gestione degli errori.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:251
classe per la gestione del logging
Definitions of constants and functions for working with missing values.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Class for expressing a cyclic datetime.
Class for expressing an absolute time value.
Class for expressing a relative time interval.

Generated with Doxygen.