libsim Versione 7.1.11
|
◆ pack_distinct_datetime()
compatta gli elementi distinti di vect in un array Definizione alla linea 2638 del file datetime_class.F90. 2640! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2641! authors:
2642! Davide Cesari <dcesari@arpa.emr.it>
2643! Paolo Patruno <ppatruno@arpa.emr.it>
2644
2645! This program is free software; you can redistribute it and/or
2646! modify it under the terms of the GNU General Public License as
2647! published by the Free Software Foundation; either version 2 of
2648! the License, or (at your option) any later version.
2649
2650! This program is distributed in the hope that it will be useful,
2651! but WITHOUT ANY WARRANTY; without even the implied warranty of
2652! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2653! GNU General Public License for more details.
2654
2655! You should have received a copy of the GNU General Public License
2656! along with this program. If not, see <http://www.gnu.org/licenses/>.
2657#include "config.h"
2658
2679IMPLICIT NONE
2680
2681INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2682
2685 PRIVATE
2686 INTEGER(KIND=int_ll) :: iminuti
2688
2697 PRIVATE
2698 INTEGER(KIND=int_ll) :: iminuti
2699 INTEGER :: month
2701
2702
2707 PRIVATE
2708 INTEGER :: minute
2709 INTEGER :: hour
2710 INTEGER :: day
2711 INTEGER :: tendaysp
2712 INTEGER :: month
2714
2715
2723INTEGER, PARAMETER :: datetime_utc=1
2725INTEGER, PARAMETER :: datetime_local=2
2735TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2736
2737
2738INTEGER(kind=dateint), PARAMETER :: &
2739 sec_in_day=86400, &
2740 sec_in_hour=3600, &
2741 sec_in_min=60, &
2742 min_in_day=1440, &
2743 min_in_hour=60, &
2744 hour_in_day=24
2745
2746INTEGER,PARAMETER :: &
2747 year0=1, & ! anno di origine per iminuti
2748 d1=365, & ! giorni/1 anno nel calendario gregoriano
2749 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2750 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2751 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2752 ianno(13,2)=reshape((/ &
2753 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2754 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2755
2756INTEGER(KIND=int_ll),PARAMETER :: &
2757 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2758
2763 MODULE PROCEDURE datetime_init, timedelta_init
2764END INTERFACE
2765
2769 MODULE PROCEDURE datetime_delete, timedelta_delete
2770END INTERFACE
2771
2774 MODULE PROCEDURE datetime_getval, timedelta_getval
2775END INTERFACE
2776
2779 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2780END INTERFACE
2781
2782
2801 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2802END INTERFACE
2803
2809INTERFACE OPERATOR (==)
2810 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2811 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2812END INTERFACE
2813
2819INTERFACE OPERATOR (/=)
2820 MODULE PROCEDURE datetime_ne, timedelta_ne
2821END INTERFACE
2822
2830INTERFACE OPERATOR (>)
2831 MODULE PROCEDURE datetime_gt, timedelta_gt
2832END INTERFACE
2833
2841INTERFACE OPERATOR (<)
2842 MODULE PROCEDURE datetime_lt, timedelta_lt
2843END INTERFACE
2844
2852INTERFACE OPERATOR (>=)
2853 MODULE PROCEDURE datetime_ge, timedelta_ge
2854END INTERFACE
2855
2863INTERFACE OPERATOR (<=)
2864 MODULE PROCEDURE datetime_le, timedelta_le
2865END INTERFACE
2866
2873INTERFACE OPERATOR (+)
2874 MODULE PROCEDURE datetime_add, timedelta_add
2875END INTERFACE
2876
2884INTERFACE OPERATOR (-)
2885 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
2886END INTERFACE
2887
2893INTERFACE OPERATOR (*)
2894 MODULE PROCEDURE timedelta_mult, timedelta_tlum
2895END INTERFACE
2896
2903INTERFACE OPERATOR (/)
2904 MODULE PROCEDURE timedelta_divint, timedelta_divtd
2905END INTERFACE
2906
2918 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2919END INTERFACE
2920
2924 MODULE PROCEDURE timedelta_abs
2925END INTERFACE
2926
2930 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2931 timedelta_read_unit, timedelta_vect_read_unit
2932END INTERFACE
2933
2937 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2938 timedelta_write_unit, timedelta_vect_write_unit
2939END INTERFACE
2940
2943 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2944END INTERFACE
2945
2948 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
2949END INTERFACE
2950
2951#undef VOL7D_POLY_TYPE
2952#undef VOL7D_POLY_TYPES
2953#undef ENABLE_SORT
2954#define VOL7D_POLY_TYPE TYPE(datetime)
2955#define VOL7D_POLY_TYPES _datetime
2956#define ENABLE_SORT
2957#include "array_utilities_pre.F90"
2958
2959
2960#define ARRAYOF_ORIGTYPE TYPE(datetime)
2961#define ARRAYOF_TYPE arrayof_datetime
2962#define ARRAYOF_ORIGEQ 1
2963#include "arrayof_pre.F90"
2964! from arrayof
2965
2966PRIVATE
2967
2969 datetime_min, datetime_max, &
2972 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2973 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2975 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2976 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2978 count_distinct, pack_distinct, &
2979 count_distinct_sorted, pack_distinct_sorted, &
2980 count_and_pack_distinct, &
2982 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
2984PUBLIC insert_unique, append_unique
2985PUBLIC cyclicdatetime_to_conventional
2986
2987CONTAINS
2988
2989
2990! ==============
2991! == datetime ==
2992! ==============
2993
3000ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3001 unixtime, isodate, simpledate) RESULT(this)
3002INTEGER,INTENT(IN),OPTIONAL :: year
3003INTEGER,INTENT(IN),OPTIONAL :: month
3004INTEGER,INTENT(IN),OPTIONAL :: day
3005INTEGER,INTENT(IN),OPTIONAL :: hour
3006INTEGER,INTENT(IN),OPTIONAL :: minute
3007INTEGER,INTENT(IN),OPTIONAL :: msec
3008INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3009CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3010CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3011
3012TYPE(datetime) :: this
3013INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3014CHARACTER(len=23) :: datebuf
3015
3016IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3017 lyear = year
3018 IF (PRESENT(month)) THEN
3019 lmonth = month
3020 ELSE
3021 lmonth = 1
3022 ENDIF
3023 IF (PRESENT(day)) THEN
3024 lday = day
3025 ELSE
3026 lday = 1
3027 ENDIF
3028 IF (PRESENT(hour)) THEN
3029 lhour = hour
3030 ELSE
3031 lhour = 0
3032 ENDIF
3033 IF (PRESENT(minute)) THEN
3034 lminute = minute
3035 ELSE
3036 lminute = 0
3037 ENDIF
3038 IF (PRESENT(msec)) THEN
3039 lmsec = msec
3040 ELSE
3041 lmsec = 0
3042 ENDIF
3043
3046 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3047 else
3048 this=datetime_miss
3049 end if
3050
3051ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3053 this%iminuti = (unixtime + unsec)*1000
3054 else
3055 this=datetime_miss
3056 end if
3057
3058ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3059
3061 datebuf(1:23) = '0001-01-01 00:00:00.000'
3062 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3063 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3064 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3065 lmsec = lmsec + lsec*1000
3066 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3067 RETURN
3068
3069100 CONTINUE ! condizione di errore in isodate
3071 RETURN
3072 ELSE
3073 this = datetime_miss
3074 ENDIF
3075
3076ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3078 datebuf(1:17) = '00010101000000000'
3079 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3080 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3081 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3082 lmsec = lmsec + lsec*1000
3083 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3084 RETURN
3085
3086120 CONTINUE ! condizione di errore in simpledate
3088 RETURN
3089 ELSE
3090 this = datetime_miss
3091 ENDIF
3092
3093ELSE
3094 this = datetime_miss
3095ENDIF
3096
3097END FUNCTION datetime_new
3098
3099
3101FUNCTION datetime_new_now(now) RESULT(this)
3102INTEGER,INTENT(IN) :: now
3103TYPE(datetime) :: this
3104
3105INTEGER :: dt(8)
3106
3108 CALL date_and_time(values=dt)
3109 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3111 msec=dt(7)*1000+dt(8))
3112ELSE
3113 this = datetime_miss
3114ENDIF
3115
3116END FUNCTION datetime_new_now
3117
3118
3125SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3126 unixtime, isodate, simpledate, now)
3127TYPE(datetime),INTENT(INOUT) :: this
3128INTEGER,INTENT(IN),OPTIONAL :: year
3129INTEGER,INTENT(IN),OPTIONAL :: month
3130INTEGER,INTENT(IN),OPTIONAL :: day
3131INTEGER,INTENT(IN),OPTIONAL :: hour
3132INTEGER,INTENT(IN),OPTIONAL :: minute
3133INTEGER,INTENT(IN),OPTIONAL :: msec
3134INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3135CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3136CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3137INTEGER,INTENT(IN),OPTIONAL :: now
3138
3139IF (PRESENT(now)) THEN
3140 this = datetime_new_now(now)
3141ELSE
3142 this = datetime_new(year, month, day, hour, minute, msec, &
3143 unixtime, isodate, simpledate)
3144ENDIF
3145
3146END SUBROUTINE datetime_init
3147
3148
3149ELEMENTAL SUBROUTINE datetime_delete(this)
3150TYPE(datetime),INTENT(INOUT) :: this
3151
3152this%iminuti = illmiss
3153
3154END SUBROUTINE datetime_delete
3155
3156
3161PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3162 unixtime, isodate, simpledate, oraclesimdate)
3163TYPE(datetime),INTENT(IN) :: this
3164INTEGER,INTENT(OUT),OPTIONAL :: year
3165INTEGER,INTENT(OUT),OPTIONAL :: month
3166INTEGER,INTENT(OUT),OPTIONAL :: day
3167INTEGER,INTENT(OUT),OPTIONAL :: hour
3168INTEGER,INTENT(OUT),OPTIONAL :: minute
3169INTEGER,INTENT(OUT),OPTIONAL :: msec
3170INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3171CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3172CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3173CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3174
3175INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3176CHARACTER(len=23) :: datebuf
3177
3178IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3179 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3180 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3181
3182 IF (this == datetime_miss) THEN
3183
3184 IF (PRESENT(msec)) THEN
3185 msec = imiss
3186 ENDIF
3187 IF (PRESENT(minute)) THEN
3188 minute = imiss
3189 ENDIF
3190 IF (PRESENT(hour)) THEN
3191 hour = imiss
3192 ENDIF
3193 IF (PRESENT(day)) THEN
3194 day = imiss
3195 ENDIF
3196 IF (PRESENT(month)) THEN
3197 month = imiss
3198 ENDIF
3199 IF (PRESENT(year)) THEN
3200 year = imiss
3201 ENDIF
3202 IF (PRESENT(isodate)) THEN
3203 isodate = cmiss
3204 ENDIF
3205 IF (PRESENT(simpledate)) THEN
3206 simpledate = cmiss
3207 ENDIF
3208 IF (PRESENT(oraclesimdate)) THEN
3209!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3210!!$ 'obsoleto, usare piuttosto simpledate')
3211 oraclesimdate=cmiss
3212 ENDIF
3213 IF (PRESENT(unixtime)) THEN
3214 unixtime = illmiss
3215 ENDIF
3216
3217 ELSE
3218
3219 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3220 IF (PRESENT(msec)) THEN
3221 msec = lmsec
3222 ENDIF
3223 IF (PRESENT(minute)) THEN
3224 minute = lminute
3225 ENDIF
3226 IF (PRESENT(hour)) THEN
3227 hour = lhour
3228 ENDIF
3229 IF (PRESENT(day)) THEN
3230 day = lday
3231 ENDIF
3232 IF (PRESENT(month)) THEN
3233 month = lmonth
3234 ENDIF
3235 IF (PRESENT(year)) THEN
3236 year = lyear
3237 ENDIF
3238 IF (PRESENT(isodate)) THEN
3239 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3240 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3242 isodate = datebuf(1:min(len(isodate),23))
3243 ENDIF
3244 IF (PRESENT(simpledate)) THEN
3245 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3246 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3247 simpledate = datebuf(1:min(len(simpledate),17))
3248 ENDIF
3249 IF (PRESENT(oraclesimdate)) THEN
3250!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3251!!$ 'obsoleto, usare piuttosto simpledate')
3252 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3253 ENDIF
3254 IF (PRESENT(unixtime)) THEN
3255 unixtime = this%iminuti/1000_int_ll-unsec
3256 ENDIF
3257
3258 ENDIF
3259ENDIF
3260
3261END SUBROUTINE datetime_getval
3262
3263
3266elemental FUNCTION datetime_to_char(this) RESULT(char)
3267TYPE(datetime),INTENT(IN) :: this
3268
3269CHARACTER(len=23) :: char
3270
3272
3273END FUNCTION datetime_to_char
3274
3275
3276FUNCTION trim_datetime_to_char(in) RESULT(char)
3277TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3278
3279CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3280
3281char=datetime_to_char(in)
3282
3283END FUNCTION trim_datetime_to_char
3284
3285
3286
3287SUBROUTINE display_datetime(this)
3288TYPE(datetime),INTENT(in) :: this
3289
3291
3292end subroutine display_datetime
3293
3294
3295
3296SUBROUTINE display_timedelta(this)
3297TYPE(timedelta),INTENT(in) :: this
3298
3300
3301end subroutine display_timedelta
3302
3303
3304
3305ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3306TYPE(datetime),INTENT(in) :: this
3307LOGICAL :: res
3308
3309res = .not. this == datetime_miss
3310
3311end FUNCTION c_e_datetime
3312
3313
3314ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3315TYPE(datetime),INTENT(IN) :: this, that
3316LOGICAL :: res
3317
3318res = this%iminuti == that%iminuti
3319
3320END FUNCTION datetime_eq
3321
3322
3323ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3324TYPE(datetime),INTENT(IN) :: this, that
3325LOGICAL :: res
3326
3327res = .NOT.(this == that)
3328
3329END FUNCTION datetime_ne
3330
3331
3332ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3333TYPE(datetime),INTENT(IN) :: this, that
3334LOGICAL :: res
3335
3336res = this%iminuti > that%iminuti
3337
3338END FUNCTION datetime_gt
3339
3340
3341ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3342TYPE(datetime),INTENT(IN) :: this, that
3343LOGICAL :: res
3344
3345res = this%iminuti < that%iminuti
3346
3347END FUNCTION datetime_lt
3348
3349
3350ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3351TYPE(datetime),INTENT(IN) :: this, that
3352LOGICAL :: res
3353
3354IF (this == that) THEN
3355 res = .true.
3356ELSE IF (this > that) THEN
3357 res = .true.
3358ELSE
3359 res = .false.
3360ENDIF
3361
3362END FUNCTION datetime_ge
3363
3364
3365ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3366TYPE(datetime),INTENT(IN) :: this, that
3367LOGICAL :: res
3368
3369IF (this == that) THEN
3370 res = .true.
3371ELSE IF (this < that) THEN
3372 res = .true.
3373ELSE
3374 res = .false.
3375ENDIF
3376
3377END FUNCTION datetime_le
3378
3379
3380FUNCTION datetime_add(this, that) RESULT(res)
3381TYPE(datetime),INTENT(IN) :: this
3382TYPE(timedelta),INTENT(IN) :: that
3383TYPE(datetime) :: res
3384
3385INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3386
3387IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3388 res = datetime_miss
3389ELSE
3390 res%iminuti = this%iminuti + that%iminuti
3391 IF (that%month /= 0) THEN
3393 minute=lminute, msec=lmsec)
3395 hour=lhour, minute=lminute, msec=lmsec)
3396 ENDIF
3397ENDIF
3398
3399END FUNCTION datetime_add
3400
3401
3402ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3403TYPE(datetime),INTENT(IN) :: this, that
3404TYPE(timedelta) :: res
3405
3406IF (this == datetime_miss .OR. that == datetime_miss) THEN
3407 res = timedelta_miss
3408ELSE
3409 res%iminuti = this%iminuti - that%iminuti
3410 res%month = 0
3411ENDIF
3412
3413END FUNCTION datetime_subdt
3414
3415
3416FUNCTION datetime_subtd(this, that) RESULT(res)
3417TYPE(datetime),INTENT(IN) :: this
3418TYPE(timedelta),INTENT(IN) :: that
3419TYPE(datetime) :: res
3420
3421INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3422
3423IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3424 res = datetime_miss
3425ELSE
3426 res%iminuti = this%iminuti - that%iminuti
3427 IF (that%month /= 0) THEN
3429 minute=lminute, msec=lmsec)
3431 hour=lhour, minute=lminute, msec=lmsec)
3432 ENDIF
3433ENDIF
3434
3435END FUNCTION datetime_subtd
3436
3437
3442SUBROUTINE datetime_read_unit(this, unit)
3443TYPE(datetime),INTENT(out) :: this
3444INTEGER, INTENT(in) :: unit
3445CALL datetime_vect_read_unit((/this/), unit)
3446
3447END SUBROUTINE datetime_read_unit
3448
3449
3454SUBROUTINE datetime_vect_read_unit(this, unit)
3455TYPE(datetime) :: this(:)
3456INTEGER, INTENT(in) :: unit
3457
3458CHARACTER(len=40) :: form
3459CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3460INTEGER :: i
3461
3462ALLOCATE(dateiso(SIZE(this)))
3463INQUIRE(unit, form=form)
3464IF (form == 'FORMATTED') THEN
3465 READ(unit,'(A23,1X)')dateiso
3466ELSE
3467 READ(unit)dateiso
3468ENDIF
3469DO i = 1, SIZE(dateiso)
3471ENDDO
3472DEALLOCATE(dateiso)
3473
3474END SUBROUTINE datetime_vect_read_unit
3475
3476
3481SUBROUTINE datetime_write_unit(this, unit)
3482TYPE(datetime),INTENT(in) :: this
3483INTEGER, INTENT(in) :: unit
3484
3485CALL datetime_vect_write_unit((/this/), unit)
3486
3487END SUBROUTINE datetime_write_unit
3488
3489
3494SUBROUTINE datetime_vect_write_unit(this, unit)
3495TYPE(datetime),INTENT(in) :: this(:)
3496INTEGER, INTENT(in) :: unit
3497
3498CHARACTER(len=40) :: form
3499CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3500INTEGER :: i
3501
3502ALLOCATE(dateiso(SIZE(this)))
3503DO i = 1, SIZE(dateiso)
3505ENDDO
3506INQUIRE(unit, form=form)
3507IF (form == 'FORMATTED') THEN
3508 WRITE(unit,'(A23,1X)')dateiso
3509ELSE
3510 WRITE(unit)dateiso
3511ENDIF
3512DEALLOCATE(dateiso)
3513
3514END SUBROUTINE datetime_vect_write_unit
3515
3516
3517#include "arrayof_post.F90"
3518
3519
3520! ===============
3521! == timedelta ==
3522! ===============
3529FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3530 isodate, simpledate, oraclesimdate) RESULT (this)
3531INTEGER,INTENT(IN),OPTIONAL :: year
3532INTEGER,INTENT(IN),OPTIONAL :: month
3533INTEGER,INTENT(IN),OPTIONAL :: day
3534INTEGER,INTENT(IN),OPTIONAL :: hour
3535INTEGER,INTENT(IN),OPTIONAL :: minute
3536INTEGER,INTENT(IN),OPTIONAL :: sec
3537INTEGER,INTENT(IN),OPTIONAL :: msec
3538CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3539CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3540CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3541
3542TYPE(timedelta) :: this
3543
3544CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3545 isodate, simpledate, oraclesimdate)
3546
3547END FUNCTION timedelta_new
3548
3549
3554SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3555 isodate, simpledate, oraclesimdate)
3556TYPE(timedelta),INTENT(INOUT) :: this
3557INTEGER,INTENT(IN),OPTIONAL :: year
3558INTEGER,INTENT(IN),OPTIONAL :: month
3559INTEGER,INTENT(IN),OPTIONAL :: day
3560INTEGER,INTENT(IN),OPTIONAL :: hour
3561INTEGER,INTENT(IN),OPTIONAL :: minute
3562INTEGER,INTENT(IN),OPTIONAL :: sec
3563INTEGER,INTENT(IN),OPTIONAL :: msec
3564CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3565CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3566CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3567
3568INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3569CHARACTER(len=23) :: datebuf
3570
3571this%month = 0
3572
3573IF (PRESENT(isodate)) THEN
3574 datebuf(1:23) = '0000000000 00:00:00.000'
3575 l = len_trim(isodate)
3576! IF (l > 0) THEN
3578 IF (n > 0) THEN
3579 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3580 datebuf(12-n:12-n+l-1) = isodate(:l)
3581 ELSE
3582 datebuf(1:l) = isodate(1:l)
3583 ENDIF
3584! ENDIF
3585
3586! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3587 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3588 h, m, s, ms
3589 this%month = lmonth + 12*lyear
3590 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3591 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3592 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3593 RETURN
3594
3595200 CONTINUE ! condizione di errore in isodate
3597 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3598 CALL raise_error()
3599
3600ELSE IF (PRESENT(simpledate)) THEN
3601 datebuf(1:17) = '00000000000000000'
3602 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3603 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3604 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3605 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3606 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3607
3608220 CONTINUE ! condizione di errore in simpledate
3610 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3611 CALL raise_error()
3612 RETURN
3613
3614ELSE IF (PRESENT(oraclesimdate)) THEN
3615 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3616 'obsoleto, usare piuttosto simpledate')
3617 READ(oraclesimdate, '(I8,2I2)')d, h, m
3618 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3619 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3620
3621ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3622 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3623 .and. .not. present(msec) .and. .not. present(isodate) &
3624 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3625
3626 this=timedelta_miss
3627
3628ELSE
3629 this%iminuti = 0
3630 IF (PRESENT(year)) THEN
3632 this%month = this%month + year*12
3633 else
3634 this=timedelta_miss
3635 return
3636 end if
3637 ENDIF
3638 IF (PRESENT(month)) THEN
3640 this%month = this%month + month
3641 else
3642 this=timedelta_miss
3643 return
3644 end if
3645 ENDIF
3646 IF (PRESENT(day)) THEN
3648 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3649 else
3650 this=timedelta_miss
3651 return
3652 end if
3653 ENDIF
3654 IF (PRESENT(hour)) THEN
3656 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3657 else
3658 this=timedelta_miss
3659 return
3660 end if
3661 ENDIF
3662 IF (PRESENT(minute)) THEN
3664 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3665 else
3666 this=timedelta_miss
3667 return
3668 end if
3669 ENDIF
3670 IF (PRESENT(sec)) THEN
3672 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3673 else
3674 this=timedelta_miss
3675 return
3676 end if
3677 ENDIF
3678 IF (PRESENT(msec)) THEN
3680 this%iminuti = this%iminuti + msec
3681 else
3682 this=timedelta_miss
3683 return
3684 end if
3685 ENDIF
3686ENDIF
3687
3688
3689
3690
3691END SUBROUTINE timedelta_init
3692
3693
3694SUBROUTINE timedelta_delete(this)
3695TYPE(timedelta),INTENT(INOUT) :: this
3696
3697this%iminuti = imiss
3698this%month = 0
3699
3700END SUBROUTINE timedelta_delete
3701
3702
3707PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3708 day, hour, minute, sec, msec, &
3709 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3710TYPE(timedelta),INTENT(IN) :: this
3711INTEGER,INTENT(OUT),OPTIONAL :: year
3712INTEGER,INTENT(OUT),OPTIONAL :: month
3713INTEGER,INTENT(OUT),OPTIONAL :: amonth
3714INTEGER,INTENT(OUT),OPTIONAL :: day
3715INTEGER,INTENT(OUT),OPTIONAL :: hour
3716INTEGER,INTENT(OUT),OPTIONAL :: minute
3717INTEGER,INTENT(OUT),OPTIONAL :: sec
3718INTEGER,INTENT(OUT),OPTIONAL :: msec
3719INTEGER,INTENT(OUT),OPTIONAL :: ahour
3720INTEGER,INTENT(OUT),OPTIONAL :: aminute
3721INTEGER,INTENT(OUT),OPTIONAL :: asec
3722INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
3723CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3724CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3725CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3726
3727CHARACTER(len=23) :: datebuf
3728
3729IF (PRESENT(amsec)) THEN
3730 amsec = this%iminuti
3731ENDIF
3732IF (PRESENT(asec)) THEN
3733 asec = int(this%iminuti/1000_int_ll)
3734ENDIF
3735IF (PRESENT(aminute)) THEN
3736 aminute = int(this%iminuti/60000_int_ll)
3737ENDIF
3738IF (PRESENT(ahour)) THEN
3739 ahour = int(this%iminuti/3600000_int_ll)
3740ENDIF
3741IF (PRESENT(msec)) THEN
3742 msec = int(mod(this%iminuti, 1000_int_ll))
3743ENDIF
3744IF (PRESENT(sec)) THEN
3745 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3746ENDIF
3747IF (PRESENT(minute)) THEN
3748 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3749ENDIF
3750IF (PRESENT(hour)) THEN
3751 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3752ENDIF
3753IF (PRESENT(day)) THEN
3754 day = int(this%iminuti/86400000_int_ll)
3755ENDIF
3756IF (PRESENT(amonth)) THEN
3757 amonth = this%month
3758ENDIF
3759IF (PRESENT(month)) THEN
3760 month = mod(this%month-1,12)+1
3761ENDIF
3762IF (PRESENT(year)) THEN
3763 year = this%month/12
3764ENDIF
3765IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3766 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3770 isodate = datebuf(1:min(len(isodate),23))
3771
3772ENDIF
3773IF (PRESENT(simpledate)) THEN
3774 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3775 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3777 mod(this%iminuti, 1000_int_ll)
3778 simpledate = datebuf(1:min(len(simpledate),17))
3779ENDIF
3780IF (PRESENT(oraclesimdate)) THEN
3781!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3782!!$ 'obsoleto, usare piuttosto simpledate')
3783 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3785ENDIF
3786
3787END SUBROUTINE timedelta_getval
3788
3789
3792elemental FUNCTION timedelta_to_char(this) RESULT(char)
3793TYPE(timedelta),INTENT(IN) :: this
3794
3795CHARACTER(len=23) :: char
3796
3798
3799END FUNCTION timedelta_to_char
3800
3801
3802FUNCTION trim_timedelta_to_char(in) RESULT(char)
3803TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3804
3805CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3806
3807char=timedelta_to_char(in)
3808
3809END FUNCTION trim_timedelta_to_char
3810
3811
3813elemental FUNCTION timedelta_getamsec(this)
3814TYPE(timedelta),INTENT(IN) :: this
3815INTEGER(kind=int_ll) :: timedelta_getamsec
3816
3817timedelta_getamsec = this%iminuti
3818
3819END FUNCTION timedelta_getamsec
3820
3821
3827FUNCTION timedelta_depop(this)
3828TYPE(timedelta),INTENT(IN) :: this
3829TYPE(timedelta) :: timedelta_depop
3830
3831TYPE(datetime) :: tmpdt
3832
3833IF (this%month == 0) THEN
3834 timedelta_depop = this
3835ELSE
3836 tmpdt = datetime_new(1970, 1, 1)
3837 timedelta_depop = (tmpdt + this) - tmpdt
3838ENDIF
3839
3840END FUNCTION timedelta_depop
3841
3842
3843elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3844TYPE(timedelta),INTENT(IN) :: this, that
3845LOGICAL :: res
3846
3847res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3848
3849END FUNCTION timedelta_eq
3850
3851
3852ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3853TYPE(timedelta),INTENT(IN) :: this, that
3854LOGICAL :: res
3855
3856res = .NOT.(this == that)
3857
3858END FUNCTION timedelta_ne
3859
3860
3861ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
3862TYPE(timedelta),INTENT(IN) :: this, that
3863LOGICAL :: res
3864
3865res = this%iminuti > that%iminuti
3866
3867END FUNCTION timedelta_gt
3868
3869
3870ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
3871TYPE(timedelta),INTENT(IN) :: this, that
3872LOGICAL :: res
3873
3874res = this%iminuti < that%iminuti
3875
3876END FUNCTION timedelta_lt
3877
3878
3879ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
3880TYPE(timedelta),INTENT(IN) :: this, that
3881LOGICAL :: res
3882
3883IF (this == that) THEN
3884 res = .true.
3885ELSE IF (this > that) THEN
3886 res = .true.
3887ELSE
3888 res = .false.
3889ENDIF
3890
3891END FUNCTION timedelta_ge
3892
3893
3894elemental FUNCTION timedelta_le(this, that) RESULT(res)
3895TYPE(timedelta),INTENT(IN) :: this, that
3896LOGICAL :: res
3897
3898IF (this == that) THEN
3899 res = .true.
3900ELSE IF (this < that) THEN
3901 res = .true.
3902ELSE
3903 res = .false.
3904ENDIF
3905
3906END FUNCTION timedelta_le
3907
3908
3909ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
3910TYPE(timedelta),INTENT(IN) :: this, that
3911TYPE(timedelta) :: res
3912
3913res%iminuti = this%iminuti + that%iminuti
3914res%month = this%month + that%month
3915
3916END FUNCTION timedelta_add
3917
3918
3919ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
3920TYPE(timedelta),INTENT(IN) :: this, that
3921TYPE(timedelta) :: res
3922
3923res%iminuti = this%iminuti - that%iminuti
3924res%month = this%month - that%month
3925
3926END FUNCTION timedelta_sub
3927
3928
3929ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
3930TYPE(timedelta),INTENT(IN) :: this
3931INTEGER,INTENT(IN) :: n
3932TYPE(timedelta) :: res
3933
3934res%iminuti = this%iminuti*n
3935res%month = this%month*n
3936
3937END FUNCTION timedelta_mult
3938
3939
3940ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
3941INTEGER,INTENT(IN) :: n
3942TYPE(timedelta),INTENT(IN) :: this
3943TYPE(timedelta) :: res
3944
3945res%iminuti = this%iminuti*n
3946res%month = this%month*n
3947
3948END FUNCTION timedelta_tlum
3949
3950
3951ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
3952TYPE(timedelta),INTENT(IN) :: this
3953INTEGER,INTENT(IN) :: n
3954TYPE(timedelta) :: res
3955
3956res%iminuti = this%iminuti/n
3957res%month = this%month/n
3958
3959END FUNCTION timedelta_divint
3960
3961
3962ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
3963TYPE(timedelta),INTENT(IN) :: this, that
3964INTEGER :: res
3965
3966res = int(this%iminuti/that%iminuti)
3967
3968END FUNCTION timedelta_divtd
3969
3970
3971elemental FUNCTION timedelta_mod(this, that) RESULT(res)
3972TYPE(timedelta),INTENT(IN) :: this, that
3973TYPE(timedelta) :: res
3974
3975res%iminuti = mod(this%iminuti, that%iminuti)
3976res%month = 0
3977
3978END FUNCTION timedelta_mod
3979
3980
3981ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
3982TYPE(datetime),INTENT(IN) :: this
3983TYPE(timedelta),INTENT(IN) :: that
3984TYPE(timedelta) :: res
3985
3986IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
3987 res = timedelta_0
3988ELSE
3989 res%iminuti = mod(this%iminuti, that%iminuti)
3990 res%month = 0
3991ENDIF
3992
3993END FUNCTION datetime_timedelta_mod
3994
3995
3996ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
3997TYPE(timedelta),INTENT(IN) :: this
3998TYPE(timedelta) :: res
3999
4000res%iminuti = abs(this%iminuti)
4001res%month = abs(this%month)
4002
4003END FUNCTION timedelta_abs
4004
4005
4010SUBROUTINE timedelta_read_unit(this, unit)
4011TYPE(timedelta),INTENT(out) :: this
4012INTEGER, INTENT(in) :: unit
4013
4014CALL timedelta_vect_read_unit((/this/), unit)
4015
4016END SUBROUTINE timedelta_read_unit
4017
4018
4023SUBROUTINE timedelta_vect_read_unit(this, unit)
4024TYPE(timedelta) :: this(:)
4025INTEGER, INTENT(in) :: unit
4026
4027CHARACTER(len=40) :: form
4028CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4029INTEGER :: i
4030
4031ALLOCATE(dateiso(SIZE(this)))
4032INQUIRE(unit, form=form)
4033IF (form == 'FORMATTED') THEN
4034 READ(unit,'(3(A23,1X))')dateiso
4035ELSE
4036 READ(unit)dateiso
4037ENDIF
4038DO i = 1, SIZE(dateiso)
4040ENDDO
4041DEALLOCATE(dateiso)
4042
4043END SUBROUTINE timedelta_vect_read_unit
4044
4045
4050SUBROUTINE timedelta_write_unit(this, unit)
4051TYPE(timedelta),INTENT(in) :: this
4052INTEGER, INTENT(in) :: unit
4053
4054CALL timedelta_vect_write_unit((/this/), unit)
4055
4056END SUBROUTINE timedelta_write_unit
4057
4058
4063SUBROUTINE timedelta_vect_write_unit(this, unit)
4064TYPE(timedelta),INTENT(in) :: this(:)
4065INTEGER, INTENT(in) :: unit
4066
4067CHARACTER(len=40) :: form
4068CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4069INTEGER :: i
4070
4071ALLOCATE(dateiso(SIZE(this)))
4072DO i = 1, SIZE(dateiso)
4074ENDDO
4075INQUIRE(unit, form=form)
4076IF (form == 'FORMATTED') THEN
4077 WRITE(unit,'(3(A23,1X))')dateiso
4078ELSE
4079 WRITE(unit)dateiso
4080ENDIF
4081DEALLOCATE(dateiso)
4082
4083END SUBROUTINE timedelta_vect_write_unit
4084
4085
4086ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4087TYPE(timedelta),INTENT(in) :: this
4088LOGICAL :: res
4089
4090res = .not. this == timedelta_miss
4091
4092end FUNCTION c_e_timedelta
4093
4094
4095elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4096
4097!!omstart JELADATA5
4098! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4099! 1 IMINUTI)
4100!
4101! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4102!
4103! variabili integer*4
4104! IN:
4105! IDAY,IMONTH,IYEAR, I*4
4106! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4107!
4108! OUT:
4109! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4110!!OMEND
4111
4112INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4113INTEGER,intent(out) :: iminuti
4114
4115iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4116
4117END SUBROUTINE jeladata5
4118
4119
4120elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4121INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4122INTEGER(KIND=int_ll),intent(out) :: imillisec
4123
4124imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4125 + imsec
4126
4127END SUBROUTINE jeladata5_1
4128
4129
4130
4131elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4132
4133!!omstart JELADATA6
4134! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4135! 1 IMINUTI)
4136!
4137! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4138! 1/1/1
4139!
4140! variabili integer*4
4141! IN:
4142! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4143!
4144! OUT:
4145! IDAY,IMONTH,IYEAR, I*4
4146! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4147!!OMEND
4148
4149
4150INTEGER,intent(in) :: iminuti
4151INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4152
4153INTEGER ::igiorno
4154
4155imin = mod(iminuti,60)
4156ihour = mod(iminuti,1440)/60
4157igiorno = iminuti/1440
4159CALL ndyin(igiorno,iday,imonth,iyear)
4160
4161END SUBROUTINE jeladata6
4162
4163
4164elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4165INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4166INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4167
4168INTEGER :: igiorno
4169
4171!imin = MOD(imillisec/60000_int_ll, 60)
4172!ihour = MOD(imillisec/3600000_int_ll, 24)
4173imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4174ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4175igiorno = int(imillisec/86400000_int_ll)
4176!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4177CALL ndyin(igiorno,iday,imonth,iyear)
4178
4179END SUBROUTINE jeladata6_1
4180
4181
4182elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4183
4184!!OMSTART NDYIN
4185! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4186! restituisce la data fornendo in input il numero di
4187! giorni dal 1/1/1
4188!
4189!!omend
4190
4191INTEGER,intent(in) :: ndays
4192INTEGER,intent(out) :: igg, imm, iaa
4193integer :: n,lndays
4194
4195lndays=ndays
4196
4197n = lndays/d400
4198lndays = lndays - n*d400
4199iaa = year0 + n*400
4200n = min(lndays/d100, 3)
4201lndays = lndays - n*d100
4202iaa = iaa + n*100
4203n = lndays/d4
4204lndays = lndays - n*d4
4205iaa = iaa + n*4
4206n = min(lndays/d1, 3)
4207lndays = lndays - n*d1
4208iaa = iaa + n
4209n = bisextilis(iaa)
4210DO imm = 1, 12
4211 IF (lndays < ianno(imm+1,n)) EXIT
4212ENDDO
4213igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4214
4215END SUBROUTINE ndyin
4216
4217
4218integer elemental FUNCTION ndays(igg,imm,iaa)
4219
4220!!OMSTART NDAYS
4221! FUNCTION NDAYS(IGG,IMM,IAA)
4222! restituisce il numero di giorni dal 1/1/1
4223! fornendo in input la data
4224!
4225!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4226! nota bene E' SICURO !!!
4227! un anno e' bisestile se divisibile per 4
4228! un anno rimane bisestile se divisibile per 400
4229! un anno NON e' bisestile se divisibile per 100
4230!
4231!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4232!
4233!!omend
4234
4235INTEGER, intent(in) :: igg, imm, iaa
4236
4237INTEGER :: lmonth, lyear
4238
4239! Limito il mese a [1-12] e correggo l'anno coerentemente
4240lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4241lyear = iaa + (imm - lmonth)/12
4242ndays = igg+ianno(lmonth, bisextilis(lyear))
4243ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4244 (lyear-year0)/400
4245
4246END FUNCTION ndays
4247
4248
4249elemental FUNCTION bisextilis(annum)
4250INTEGER,INTENT(in) :: annum
4251INTEGER :: bisextilis
4252
4254 bisextilis = 2
4255ELSE
4256 bisextilis = 1
4257ENDIF
4258END FUNCTION bisextilis
4259
4260
4261ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4262TYPE(cyclicdatetime),INTENT(IN) :: this, that
4263LOGICAL :: res
4264
4265res = .true.
4266if (this%minute /= that%minute) res=.false.
4267if (this%hour /= that%hour) res=.false.
4268if (this%day /= that%day) res=.false.
4269if (this%month /= that%month) res=.false.
4270if (this%tendaysp /= that%tendaysp) res=.false.
4271
4272END FUNCTION cyclicdatetime_eq
4273
4274
4275ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4276TYPE(cyclicdatetime),INTENT(IN) :: this
4277TYPE(datetime),INTENT(IN) :: that
4278LOGICAL :: res
4279
4280integer :: minute,hour,day,month
4281
4283
4284res = .true.
4290 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4291end if
4292
4293END FUNCTION cyclicdatetime_datetime_eq
4294
4295
4296ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4297TYPE(datetime),INTENT(IN) :: this
4298TYPE(cyclicdatetime),INTENT(IN) :: that
4299LOGICAL :: res
4300
4301integer :: minute,hour,day,month
4302
4304
4305res = .true.
4310
4312 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4313end if
4314
4315
4316END FUNCTION datetime_cyclicdatetime_eq
4317
4318ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4319TYPE(cyclicdatetime),INTENT(in) :: this
4320LOGICAL :: res
4321
4322res = .not. this == cyclicdatetime_miss
4323
4324end FUNCTION c_e_cyclicdatetime
4325
4326
4329FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4330INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4331INTEGER,INTENT(IN),OPTIONAL :: month
4332INTEGER,INTENT(IN),OPTIONAL :: day
4333INTEGER,INTENT(IN),OPTIONAL :: hour
4334INTEGER,INTENT(IN),OPTIONAL :: minute
4335CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4336
4337integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4338
4339
4340TYPE(cyclicdatetime) :: this
4341
4342if (present(chardate)) then
4343
4344 ltendaysp=imiss
4345 lmonth=imiss
4346 lday=imiss
4347 lhour=imiss
4348 lminute=imiss
4349
4351 ! TMMGGhhmm
4352 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4353 !print*,chardate(1:1),ios,ltendaysp
4354 if (ios /= 0)ltendaysp=imiss
4355
4356 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4357 !print*,chardate(2:3),ios,lmonth
4358 if (ios /= 0)lmonth=imiss
4359
4360 read(chardate(4:5),'(i2)',iostat=ios)lday
4361 !print*,chardate(4:5),ios,lday
4362 if (ios /= 0)lday=imiss
4363
4364 read(chardate(6:7),'(i2)',iostat=ios)lhour
4365 !print*,chardate(6:7),ios,lhour
4366 if (ios /= 0)lhour=imiss
4367
4368 read(chardate(8:9),'(i2)',iostat=ios)lminute
4369 !print*,chardate(8:9),ios,lminute
4370 if (ios /= 0)lminute=imiss
4371 end if
4372
4373 this%tendaysp=ltendaysp
4374 this%month=lmonth
4375 this%day=lday
4376 this%hour=lhour
4377 this%minute=lminute
4378else
4379 this%tendaysp=optio_l(tendaysp)
4380 this%month=optio_l(month)
4381 this%day=optio_l(day)
4382 this%hour=optio_l(hour)
4383 this%minute=optio_l(minute)
4384end if
4385
4386END FUNCTION cyclicdatetime_new
4387
4390elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4391TYPE(cyclicdatetime),INTENT(IN) :: this
4392
4393CHARACTER(len=80) :: char
4394
4397
4398END FUNCTION cyclicdatetime_to_char
4399
4400
4413FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4414TYPE(cyclicdatetime),INTENT(IN) :: this
4415
4416TYPE(datetime) :: dtc
4417
4418integer :: year,month,day,hour
4419
4420dtc = datetime_miss
4421
4422! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4424 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4425 return
4426end if
4427
4428! minute present -> not good for conventional datetime
4430! day, month and tendaysp present -> no good
4432
4434 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4436 day=(this%tendaysp-1)*10+1
4437 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4439 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4441 ! only day present -> no good
4442 return
4443end if
4444
4447 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4448end if
4449
4450
4451END FUNCTION cyclicdatetime_to_conventional
4452
4453
4454
4455FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4456TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4457
4458CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4459
4460char=cyclicdatetime_to_char(in)
4461
4462END FUNCTION trim_cyclicdatetime_to_char
4463
4464
4465
4466SUBROUTINE display_cyclicdatetime(this)
4467TYPE(cyclicdatetime),INTENT(in) :: this
4468
4470
4471end subroutine display_cyclicdatetime
4472
4473
4474#include "array_utilities_inc.F90"
4475
4477
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 |