libsim Versione 7.1.11
|
◆ pack_distinct_sorted_datetime()
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
2646IMPLICIT NONE
2647
2648INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2649
2652 PRIVATE
2653 INTEGER(KIND=int_ll) :: iminuti
2655
2664 PRIVATE
2665 INTEGER(KIND=int_ll) :: iminuti
2666 INTEGER :: month
2668
2669
2674 PRIVATE
2675 INTEGER :: minute
2676 INTEGER :: hour
2677 INTEGER :: day
2678 INTEGER :: tendaysp
2679 INTEGER :: month
2681
2682
2690INTEGER, PARAMETER :: datetime_utc=1
2692INTEGER, PARAMETER :: datetime_local=2
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
2730 MODULE PROCEDURE datetime_init, timedelta_init
2731END INTERFACE
2732
2736 MODULE PROCEDURE datetime_delete, timedelta_delete
2737END INTERFACE
2738
2741 MODULE PROCEDURE datetime_getval, timedelta_getval
2742END INTERFACE
2743
2746 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2747END INTERFACE
2748
2749
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
2885 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2886END INTERFACE
2887
2891 MODULE PROCEDURE timedelta_abs
2892END INTERFACE
2893
2897 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2898 timedelta_read_unit, timedelta_vect_read_unit
2899END INTERFACE
2900
2904 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2905 timedelta_write_unit, timedelta_vect_write_unit
2906END INTERFACE
2907
2910 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2911END INTERFACE
2912
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
2936 datetime_min, datetime_max, &
2939 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2940 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2942 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2943 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2945 count_distinct, pack_distinct, &
2946 count_distinct_sorted, pack_distinct_sorted, &
2947 count_and_pack_distinct, &
2949 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
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
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)
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
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
3038 RETURN
3039 ELSE
3040 this = datetime_miss
3041 ENDIF
3042
3043ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
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
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
3075 CALL date_and_time(values=dt)
3076 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
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, &
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
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
3258
3259end subroutine display_datetime
3260
3261
3262
3263SUBROUTINE display_timedelta(this)
3264TYPE(timedelta),INTENT(in) :: this
3265
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
3360 minute=lminute, msec=lmsec)
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
3396 minute=lminute, msec=lmsec)
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)
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)
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
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
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
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
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
3607 this%month = this%month + month
3608 else
3609 this=timedelta_miss
3610 return
3611 end if
3612 ENDIF
3613 IF (PRESENT(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
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
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
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
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)') &
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), &
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, &
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
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)
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)
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
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
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
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
4250
4251res = .true.
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
4271
4272res = .true.
4277
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
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
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)
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
4397! day, month and tendaysp present -> no good
4399
4401 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4403 day=(this%tendaysp-1)*10+1
4404 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4406 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4408 ! only day present -> no good
4409 return
4410end if
4411
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
4437
4438end subroutine display_cyclicdatetime
4439
4440
4441#include "array_utilities_inc.F90"
4442
4444
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 |