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