libsim Versione 7.1.11
|
◆ cyclicdatetime_new()
Costruisce un oggetto cyclicdatetime con i parametri opzionali forniti. Se non viene passato nulla lo inizializza a missing.
Definizione alla linea 2324 del file datetime_class.F90. 2325! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2326! authors:
2327! Davide Cesari <dcesari@arpa.emr.it>
2328! Paolo Patruno <ppatruno@arpa.emr.it>
2329
2330! This program is free software; you can redistribute it and/or
2331! modify it under the terms of the GNU General Public License as
2332! published by the Free Software Foundation; either version 2 of
2333! the License, or (at your option) any later version.
2334
2335! This program is distributed in the hope that it will be useful,
2336! but WITHOUT ANY WARRANTY; without even the implied warranty of
2337! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2338! GNU General Public License for more details.
2339
2340! You should have received a copy of the GNU General Public License
2341! along with this program. If not, see <http://www.gnu.org/licenses/>.
2342#include "config.h"
2343
2364IMPLICIT NONE
2365
2366INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2367
2370 PRIVATE
2371 INTEGER(KIND=int_ll) :: iminuti
2373
2382 PRIVATE
2383 INTEGER(KIND=int_ll) :: iminuti
2384 INTEGER :: month
2386
2387
2392 PRIVATE
2393 INTEGER :: minute
2394 INTEGER :: hour
2395 INTEGER :: day
2396 INTEGER :: tendaysp
2397 INTEGER :: month
2399
2400
2408INTEGER, PARAMETER :: datetime_utc=1
2410INTEGER, PARAMETER :: datetime_local=2
2420TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2421
2422
2423INTEGER(kind=dateint), PARAMETER :: &
2424 sec_in_day=86400, &
2425 sec_in_hour=3600, &
2426 sec_in_min=60, &
2427 min_in_day=1440, &
2428 min_in_hour=60, &
2429 hour_in_day=24
2430
2431INTEGER,PARAMETER :: &
2432 year0=1, & ! anno di origine per iminuti
2433 d1=365, & ! giorni/1 anno nel calendario gregoriano
2434 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2435 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2436 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2437 ianno(13,2)=reshape((/ &
2438 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2439 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2440
2441INTEGER(KIND=int_ll),PARAMETER :: &
2442 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2443
2448 MODULE PROCEDURE datetime_init, timedelta_init
2449END INTERFACE
2450
2454 MODULE PROCEDURE datetime_delete, timedelta_delete
2455END INTERFACE
2456
2459 MODULE PROCEDURE datetime_getval, timedelta_getval
2460END INTERFACE
2461
2464 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2465END INTERFACE
2466
2467
2486 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2487END INTERFACE
2488
2494INTERFACE OPERATOR (==)
2495 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2496 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2497END INTERFACE
2498
2504INTERFACE OPERATOR (/=)
2505 MODULE PROCEDURE datetime_ne, timedelta_ne
2506END INTERFACE
2507
2515INTERFACE OPERATOR (>)
2516 MODULE PROCEDURE datetime_gt, timedelta_gt
2517END INTERFACE
2518
2526INTERFACE OPERATOR (<)
2527 MODULE PROCEDURE datetime_lt, timedelta_lt
2528END INTERFACE
2529
2537INTERFACE OPERATOR (>=)
2538 MODULE PROCEDURE datetime_ge, timedelta_ge
2539END INTERFACE
2540
2548INTERFACE OPERATOR (<=)
2549 MODULE PROCEDURE datetime_le, timedelta_le
2550END INTERFACE
2551
2558INTERFACE OPERATOR (+)
2559 MODULE PROCEDURE datetime_add, timedelta_add
2560END INTERFACE
2561
2569INTERFACE OPERATOR (-)
2570 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
2571END INTERFACE
2572
2578INTERFACE OPERATOR (*)
2579 MODULE PROCEDURE timedelta_mult, timedelta_tlum
2580END INTERFACE
2581
2588INTERFACE OPERATOR (/)
2589 MODULE PROCEDURE timedelta_divint, timedelta_divtd
2590END INTERFACE
2591
2603 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2604END INTERFACE
2605
2609 MODULE PROCEDURE timedelta_abs
2610END INTERFACE
2611
2615 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2616 timedelta_read_unit, timedelta_vect_read_unit
2617END INTERFACE
2618
2622 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2623 timedelta_write_unit, timedelta_vect_write_unit
2624END INTERFACE
2625
2628 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2629END INTERFACE
2630
2633 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
2634END INTERFACE
2635
2636#undef VOL7D_POLY_TYPE
2637#undef VOL7D_POLY_TYPES
2638#undef ENABLE_SORT
2639#define VOL7D_POLY_TYPE TYPE(datetime)
2640#define VOL7D_POLY_TYPES _datetime
2641#define ENABLE_SORT
2642#include "array_utilities_pre.F90"
2643
2644
2645#define ARRAYOF_ORIGTYPE TYPE(datetime)
2646#define ARRAYOF_TYPE arrayof_datetime
2647#define ARRAYOF_ORIGEQ 1
2648#include "arrayof_pre.F90"
2649! from arrayof
2650
2651PRIVATE
2652
2654 datetime_min, datetime_max, &
2657 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2658 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2660 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2661 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2663 count_distinct, pack_distinct, &
2664 count_distinct_sorted, pack_distinct_sorted, &
2665 count_and_pack_distinct, &
2667 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
2669PUBLIC insert_unique, append_unique
2670PUBLIC cyclicdatetime_to_conventional
2671
2672CONTAINS
2673
2674
2675! ==============
2676! == datetime ==
2677! ==============
2678
2685ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
2686 unixtime, isodate, simpledate) RESULT(this)
2687INTEGER,INTENT(IN),OPTIONAL :: year
2688INTEGER,INTENT(IN),OPTIONAL :: month
2689INTEGER,INTENT(IN),OPTIONAL :: day
2690INTEGER,INTENT(IN),OPTIONAL :: hour
2691INTEGER,INTENT(IN),OPTIONAL :: minute
2692INTEGER,INTENT(IN),OPTIONAL :: msec
2693INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2694CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2695CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2696
2697TYPE(datetime) :: this
2698INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2699CHARACTER(len=23) :: datebuf
2700
2701IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
2702 lyear = year
2703 IF (PRESENT(month)) THEN
2704 lmonth = month
2705 ELSE
2706 lmonth = 1
2707 ENDIF
2708 IF (PRESENT(day)) THEN
2709 lday = day
2710 ELSE
2711 lday = 1
2712 ENDIF
2713 IF (PRESENT(hour)) THEN
2714 lhour = hour
2715 ELSE
2716 lhour = 0
2717 ENDIF
2718 IF (PRESENT(minute)) THEN
2719 lminute = minute
2720 ELSE
2721 lminute = 0
2722 ENDIF
2723 IF (PRESENT(msec)) THEN
2724 lmsec = msec
2725 ELSE
2726 lmsec = 0
2727 ENDIF
2728
2731 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2732 else
2733 this=datetime_miss
2734 end if
2735
2736ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
2738 this%iminuti = (unixtime + unsec)*1000
2739 else
2740 this=datetime_miss
2741 end if
2742
2743ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
2744
2746 datebuf(1:23) = '0001-01-01 00:00:00.000'
2747 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
2748 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
2749 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2750 lmsec = lmsec + lsec*1000
2751 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2752 RETURN
2753
2754100 CONTINUE ! condizione di errore in isodate
2756 RETURN
2757 ELSE
2758 this = datetime_miss
2759 ENDIF
2760
2761ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
2763 datebuf(1:17) = '00010101000000000'
2764 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
2765 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
2766 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2767 lmsec = lmsec + lsec*1000
2768 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2769 RETURN
2770
2771120 CONTINUE ! condizione di errore in simpledate
2773 RETURN
2774 ELSE
2775 this = datetime_miss
2776 ENDIF
2777
2778ELSE
2779 this = datetime_miss
2780ENDIF
2781
2782END FUNCTION datetime_new
2783
2784
2786FUNCTION datetime_new_now(now) RESULT(this)
2787INTEGER,INTENT(IN) :: now
2788TYPE(datetime) :: this
2789
2790INTEGER :: dt(8)
2791
2793 CALL date_and_time(values=dt)
2794 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
2796 msec=dt(7)*1000+dt(8))
2797ELSE
2798 this = datetime_miss
2799ENDIF
2800
2801END FUNCTION datetime_new_now
2802
2803
2810SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
2811 unixtime, isodate, simpledate, now)
2812TYPE(datetime),INTENT(INOUT) :: this
2813INTEGER,INTENT(IN),OPTIONAL :: year
2814INTEGER,INTENT(IN),OPTIONAL :: month
2815INTEGER,INTENT(IN),OPTIONAL :: day
2816INTEGER,INTENT(IN),OPTIONAL :: hour
2817INTEGER,INTENT(IN),OPTIONAL :: minute
2818INTEGER,INTENT(IN),OPTIONAL :: msec
2819INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2820CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2821CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2822INTEGER,INTENT(IN),OPTIONAL :: now
2823
2824IF (PRESENT(now)) THEN
2825 this = datetime_new_now(now)
2826ELSE
2827 this = datetime_new(year, month, day, hour, minute, msec, &
2828 unixtime, isodate, simpledate)
2829ENDIF
2830
2831END SUBROUTINE datetime_init
2832
2833
2834ELEMENTAL SUBROUTINE datetime_delete(this)
2835TYPE(datetime),INTENT(INOUT) :: this
2836
2837this%iminuti = illmiss
2838
2839END SUBROUTINE datetime_delete
2840
2841
2846PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
2847 unixtime, isodate, simpledate, oraclesimdate)
2848TYPE(datetime),INTENT(IN) :: this
2849INTEGER,INTENT(OUT),OPTIONAL :: year
2850INTEGER,INTENT(OUT),OPTIONAL :: month
2851INTEGER,INTENT(OUT),OPTIONAL :: day
2852INTEGER,INTENT(OUT),OPTIONAL :: hour
2853INTEGER,INTENT(OUT),OPTIONAL :: minute
2854INTEGER,INTENT(OUT),OPTIONAL :: msec
2855INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
2856CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
2857CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
2858CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
2859
2860INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2861CHARACTER(len=23) :: datebuf
2862
2863IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
2864 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
2865 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
2866
2867 IF (this == datetime_miss) THEN
2868
2869 IF (PRESENT(msec)) THEN
2870 msec = imiss
2871 ENDIF
2872 IF (PRESENT(minute)) THEN
2873 minute = imiss
2874 ENDIF
2875 IF (PRESENT(hour)) THEN
2876 hour = imiss
2877 ENDIF
2878 IF (PRESENT(day)) THEN
2879 day = imiss
2880 ENDIF
2881 IF (PRESENT(month)) THEN
2882 month = imiss
2883 ENDIF
2884 IF (PRESENT(year)) THEN
2885 year = imiss
2886 ENDIF
2887 IF (PRESENT(isodate)) THEN
2888 isodate = cmiss
2889 ENDIF
2890 IF (PRESENT(simpledate)) THEN
2891 simpledate = cmiss
2892 ENDIF
2893 IF (PRESENT(oraclesimdate)) THEN
2894!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2895!!$ 'obsoleto, usare piuttosto simpledate')
2896 oraclesimdate=cmiss
2897 ENDIF
2898 IF (PRESENT(unixtime)) THEN
2899 unixtime = illmiss
2900 ENDIF
2901
2902 ELSE
2903
2904 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2905 IF (PRESENT(msec)) THEN
2906 msec = lmsec
2907 ENDIF
2908 IF (PRESENT(minute)) THEN
2909 minute = lminute
2910 ENDIF
2911 IF (PRESENT(hour)) THEN
2912 hour = lhour
2913 ENDIF
2914 IF (PRESENT(day)) THEN
2915 day = lday
2916 ENDIF
2917 IF (PRESENT(month)) THEN
2918 month = lmonth
2919 ENDIF
2920 IF (PRESENT(year)) THEN
2921 year = lyear
2922 ENDIF
2923 IF (PRESENT(isodate)) THEN
2924 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
2925 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
2927 isodate = datebuf(1:min(len(isodate),23))
2928 ENDIF
2929 IF (PRESENT(simpledate)) THEN
2930 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
2931 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
2932 simpledate = datebuf(1:min(len(simpledate),17))
2933 ENDIF
2934 IF (PRESENT(oraclesimdate)) THEN
2935!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2936!!$ 'obsoleto, usare piuttosto simpledate')
2937 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
2938 ENDIF
2939 IF (PRESENT(unixtime)) THEN
2940 unixtime = this%iminuti/1000_int_ll-unsec
2941 ENDIF
2942
2943 ENDIF
2944ENDIF
2945
2946END SUBROUTINE datetime_getval
2947
2948
2951elemental FUNCTION datetime_to_char(this) RESULT(char)
2952TYPE(datetime),INTENT(IN) :: this
2953
2954CHARACTER(len=23) :: char
2955
2957
2958END FUNCTION datetime_to_char
2959
2960
2961FUNCTION trim_datetime_to_char(in) RESULT(char)
2962TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
2963
2964CHARACTER(len=len_trim(datetime_to_char(in))) :: char
2965
2966char=datetime_to_char(in)
2967
2968END FUNCTION trim_datetime_to_char
2969
2970
2971
2972SUBROUTINE display_datetime(this)
2973TYPE(datetime),INTENT(in) :: this
2974
2976
2977end subroutine display_datetime
2978
2979
2980
2981SUBROUTINE display_timedelta(this)
2982TYPE(timedelta),INTENT(in) :: this
2983
2985
2986end subroutine display_timedelta
2987
2988
2989
2990ELEMENTAL FUNCTION c_e_datetime(this) result (res)
2991TYPE(datetime),INTENT(in) :: this
2992LOGICAL :: res
2993
2994res = .not. this == datetime_miss
2995
2996end FUNCTION c_e_datetime
2997
2998
2999ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3000TYPE(datetime),INTENT(IN) :: this, that
3001LOGICAL :: res
3002
3003res = this%iminuti == that%iminuti
3004
3005END FUNCTION datetime_eq
3006
3007
3008ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3009TYPE(datetime),INTENT(IN) :: this, that
3010LOGICAL :: res
3011
3012res = .NOT.(this == that)
3013
3014END FUNCTION datetime_ne
3015
3016
3017ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3018TYPE(datetime),INTENT(IN) :: this, that
3019LOGICAL :: res
3020
3021res = this%iminuti > that%iminuti
3022
3023END FUNCTION datetime_gt
3024
3025
3026ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3027TYPE(datetime),INTENT(IN) :: this, that
3028LOGICAL :: res
3029
3030res = this%iminuti < that%iminuti
3031
3032END FUNCTION datetime_lt
3033
3034
3035ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3036TYPE(datetime),INTENT(IN) :: this, that
3037LOGICAL :: res
3038
3039IF (this == that) THEN
3040 res = .true.
3041ELSE IF (this > that) THEN
3042 res = .true.
3043ELSE
3044 res = .false.
3045ENDIF
3046
3047END FUNCTION datetime_ge
3048
3049
3050ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3051TYPE(datetime),INTENT(IN) :: this, that
3052LOGICAL :: res
3053
3054IF (this == that) THEN
3055 res = .true.
3056ELSE IF (this < that) THEN
3057 res = .true.
3058ELSE
3059 res = .false.
3060ENDIF
3061
3062END FUNCTION datetime_le
3063
3064
3065FUNCTION datetime_add(this, that) RESULT(res)
3066TYPE(datetime),INTENT(IN) :: this
3067TYPE(timedelta),INTENT(IN) :: that
3068TYPE(datetime) :: res
3069
3070INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3071
3072IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3073 res = datetime_miss
3074ELSE
3075 res%iminuti = this%iminuti + that%iminuti
3076 IF (that%month /= 0) THEN
3078 minute=lminute, msec=lmsec)
3080 hour=lhour, minute=lminute, msec=lmsec)
3081 ENDIF
3082ENDIF
3083
3084END FUNCTION datetime_add
3085
3086
3087ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3088TYPE(datetime),INTENT(IN) :: this, that
3089TYPE(timedelta) :: res
3090
3091IF (this == datetime_miss .OR. that == datetime_miss) THEN
3092 res = timedelta_miss
3093ELSE
3094 res%iminuti = this%iminuti - that%iminuti
3095 res%month = 0
3096ENDIF
3097
3098END FUNCTION datetime_subdt
3099
3100
3101FUNCTION datetime_subtd(this, that) RESULT(res)
3102TYPE(datetime),INTENT(IN) :: this
3103TYPE(timedelta),INTENT(IN) :: that
3104TYPE(datetime) :: res
3105
3106INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3107
3108IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3109 res = datetime_miss
3110ELSE
3111 res%iminuti = this%iminuti - that%iminuti
3112 IF (that%month /= 0) THEN
3114 minute=lminute, msec=lmsec)
3116 hour=lhour, minute=lminute, msec=lmsec)
3117 ENDIF
3118ENDIF
3119
3120END FUNCTION datetime_subtd
3121
3122
3127SUBROUTINE datetime_read_unit(this, unit)
3128TYPE(datetime),INTENT(out) :: this
3129INTEGER, INTENT(in) :: unit
3130CALL datetime_vect_read_unit((/this/), unit)
3131
3132END SUBROUTINE datetime_read_unit
3133
3134
3139SUBROUTINE datetime_vect_read_unit(this, unit)
3140TYPE(datetime) :: this(:)
3141INTEGER, INTENT(in) :: unit
3142
3143CHARACTER(len=40) :: form
3144CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3145INTEGER :: i
3146
3147ALLOCATE(dateiso(SIZE(this)))
3148INQUIRE(unit, form=form)
3149IF (form == 'FORMATTED') THEN
3150 READ(unit,'(A23,1X)')dateiso
3151ELSE
3152 READ(unit)dateiso
3153ENDIF
3154DO i = 1, SIZE(dateiso)
3156ENDDO
3157DEALLOCATE(dateiso)
3158
3159END SUBROUTINE datetime_vect_read_unit
3160
3161
3166SUBROUTINE datetime_write_unit(this, unit)
3167TYPE(datetime),INTENT(in) :: this
3168INTEGER, INTENT(in) :: unit
3169
3170CALL datetime_vect_write_unit((/this/), unit)
3171
3172END SUBROUTINE datetime_write_unit
3173
3174
3179SUBROUTINE datetime_vect_write_unit(this, unit)
3180TYPE(datetime),INTENT(in) :: this(:)
3181INTEGER, INTENT(in) :: unit
3182
3183CHARACTER(len=40) :: form
3184CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3185INTEGER :: i
3186
3187ALLOCATE(dateiso(SIZE(this)))
3188DO i = 1, SIZE(dateiso)
3190ENDDO
3191INQUIRE(unit, form=form)
3192IF (form == 'FORMATTED') THEN
3193 WRITE(unit,'(A23,1X)')dateiso
3194ELSE
3195 WRITE(unit)dateiso
3196ENDIF
3197DEALLOCATE(dateiso)
3198
3199END SUBROUTINE datetime_vect_write_unit
3200
3201
3202#include "arrayof_post.F90"
3203
3204
3205! ===============
3206! == timedelta ==
3207! ===============
3214FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3215 isodate, simpledate, oraclesimdate) RESULT (this)
3216INTEGER,INTENT(IN),OPTIONAL :: year
3217INTEGER,INTENT(IN),OPTIONAL :: month
3218INTEGER,INTENT(IN),OPTIONAL :: day
3219INTEGER,INTENT(IN),OPTIONAL :: hour
3220INTEGER,INTENT(IN),OPTIONAL :: minute
3221INTEGER,INTENT(IN),OPTIONAL :: sec
3222INTEGER,INTENT(IN),OPTIONAL :: msec
3223CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3224CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3225CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3226
3227TYPE(timedelta) :: this
3228
3229CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3230 isodate, simpledate, oraclesimdate)
3231
3232END FUNCTION timedelta_new
3233
3234
3239SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3240 isodate, simpledate, oraclesimdate)
3241TYPE(timedelta),INTENT(INOUT) :: this
3242INTEGER,INTENT(IN),OPTIONAL :: year
3243INTEGER,INTENT(IN),OPTIONAL :: month
3244INTEGER,INTENT(IN),OPTIONAL :: day
3245INTEGER,INTENT(IN),OPTIONAL :: hour
3246INTEGER,INTENT(IN),OPTIONAL :: minute
3247INTEGER,INTENT(IN),OPTIONAL :: sec
3248INTEGER,INTENT(IN),OPTIONAL :: msec
3249CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3250CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3251CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3252
3253INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3254CHARACTER(len=23) :: datebuf
3255
3256this%month = 0
3257
3258IF (PRESENT(isodate)) THEN
3259 datebuf(1:23) = '0000000000 00:00:00.000'
3260 l = len_trim(isodate)
3261! IF (l > 0) THEN
3263 IF (n > 0) THEN
3264 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3265 datebuf(12-n:12-n+l-1) = isodate(:l)
3266 ELSE
3267 datebuf(1:l) = isodate(1:l)
3268 ENDIF
3269! ENDIF
3270
3271! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3272 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3273 h, m, s, ms
3274 this%month = lmonth + 12*lyear
3275 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3276 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3277 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3278 RETURN
3279
3280200 CONTINUE ! condizione di errore in isodate
3282 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3283 CALL raise_error()
3284
3285ELSE IF (PRESENT(simpledate)) THEN
3286 datebuf(1:17) = '00000000000000000'
3287 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3288 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3289 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3290 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3291 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3292
3293220 CONTINUE ! condizione di errore in simpledate
3295 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3296 CALL raise_error()
3297 RETURN
3298
3299ELSE IF (PRESENT(oraclesimdate)) THEN
3300 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3301 'obsoleto, usare piuttosto simpledate')
3302 READ(oraclesimdate, '(I8,2I2)')d, h, m
3303 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3304 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3305
3306ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3307 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3308 .and. .not. present(msec) .and. .not. present(isodate) &
3309 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3310
3311 this=timedelta_miss
3312
3313ELSE
3314 this%iminuti = 0
3315 IF (PRESENT(year)) THEN
3317 this%month = this%month + year*12
3318 else
3319 this=timedelta_miss
3320 return
3321 end if
3322 ENDIF
3323 IF (PRESENT(month)) THEN
3325 this%month = this%month + month
3326 else
3327 this=timedelta_miss
3328 return
3329 end if
3330 ENDIF
3331 IF (PRESENT(day)) THEN
3333 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3334 else
3335 this=timedelta_miss
3336 return
3337 end if
3338 ENDIF
3339 IF (PRESENT(hour)) THEN
3341 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3342 else
3343 this=timedelta_miss
3344 return
3345 end if
3346 ENDIF
3347 IF (PRESENT(minute)) THEN
3349 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3350 else
3351 this=timedelta_miss
3352 return
3353 end if
3354 ENDIF
3355 IF (PRESENT(sec)) THEN
3357 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3358 else
3359 this=timedelta_miss
3360 return
3361 end if
3362 ENDIF
3363 IF (PRESENT(msec)) THEN
3365 this%iminuti = this%iminuti + msec
3366 else
3367 this=timedelta_miss
3368 return
3369 end if
3370 ENDIF
3371ENDIF
3372
3373
3374
3375
3376END SUBROUTINE timedelta_init
3377
3378
3379SUBROUTINE timedelta_delete(this)
3380TYPE(timedelta),INTENT(INOUT) :: this
3381
3382this%iminuti = imiss
3383this%month = 0
3384
3385END SUBROUTINE timedelta_delete
3386
3387
3392PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3393 day, hour, minute, sec, msec, &
3394 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3395TYPE(timedelta),INTENT(IN) :: this
3396INTEGER,INTENT(OUT),OPTIONAL :: year
3397INTEGER,INTENT(OUT),OPTIONAL :: month
3398INTEGER,INTENT(OUT),OPTIONAL :: amonth
3399INTEGER,INTENT(OUT),OPTIONAL :: day
3400INTEGER,INTENT(OUT),OPTIONAL :: hour
3401INTEGER,INTENT(OUT),OPTIONAL :: minute
3402INTEGER,INTENT(OUT),OPTIONAL :: sec
3403INTEGER,INTENT(OUT),OPTIONAL :: msec
3404INTEGER,INTENT(OUT),OPTIONAL :: ahour
3405INTEGER,INTENT(OUT),OPTIONAL :: aminute
3406INTEGER,INTENT(OUT),OPTIONAL :: asec
3407INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
3408CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3409CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3410CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3411
3412CHARACTER(len=23) :: datebuf
3413
3414IF (PRESENT(amsec)) THEN
3415 amsec = this%iminuti
3416ENDIF
3417IF (PRESENT(asec)) THEN
3418 asec = int(this%iminuti/1000_int_ll)
3419ENDIF
3420IF (PRESENT(aminute)) THEN
3421 aminute = int(this%iminuti/60000_int_ll)
3422ENDIF
3423IF (PRESENT(ahour)) THEN
3424 ahour = int(this%iminuti/3600000_int_ll)
3425ENDIF
3426IF (PRESENT(msec)) THEN
3427 msec = int(mod(this%iminuti, 1000_int_ll))
3428ENDIF
3429IF (PRESENT(sec)) THEN
3430 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3431ENDIF
3432IF (PRESENT(minute)) THEN
3433 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3434ENDIF
3435IF (PRESENT(hour)) THEN
3436 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3437ENDIF
3438IF (PRESENT(day)) THEN
3439 day = int(this%iminuti/86400000_int_ll)
3440ENDIF
3441IF (PRESENT(amonth)) THEN
3442 amonth = this%month
3443ENDIF
3444IF (PRESENT(month)) THEN
3445 month = mod(this%month-1,12)+1
3446ENDIF
3447IF (PRESENT(year)) THEN
3448 year = this%month/12
3449ENDIF
3450IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3451 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3455 isodate = datebuf(1:min(len(isodate),23))
3456
3457ENDIF
3458IF (PRESENT(simpledate)) THEN
3459 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3460 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3462 mod(this%iminuti, 1000_int_ll)
3463 simpledate = datebuf(1:min(len(simpledate),17))
3464ENDIF
3465IF (PRESENT(oraclesimdate)) THEN
3466!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3467!!$ 'obsoleto, usare piuttosto simpledate')
3468 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3470ENDIF
3471
3472END SUBROUTINE timedelta_getval
3473
3474
3477elemental FUNCTION timedelta_to_char(this) RESULT(char)
3478TYPE(timedelta),INTENT(IN) :: this
3479
3480CHARACTER(len=23) :: char
3481
3483
3484END FUNCTION timedelta_to_char
3485
3486
3487FUNCTION trim_timedelta_to_char(in) RESULT(char)
3488TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3489
3490CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3491
3492char=timedelta_to_char(in)
3493
3494END FUNCTION trim_timedelta_to_char
3495
3496
3498elemental FUNCTION timedelta_getamsec(this)
3499TYPE(timedelta),INTENT(IN) :: this
3500INTEGER(kind=int_ll) :: timedelta_getamsec
3501
3502timedelta_getamsec = this%iminuti
3503
3504END FUNCTION timedelta_getamsec
3505
3506
3512FUNCTION timedelta_depop(this)
3513TYPE(timedelta),INTENT(IN) :: this
3514TYPE(timedelta) :: timedelta_depop
3515
3516TYPE(datetime) :: tmpdt
3517
3518IF (this%month == 0) THEN
3519 timedelta_depop = this
3520ELSE
3521 tmpdt = datetime_new(1970, 1, 1)
3522 timedelta_depop = (tmpdt + this) - tmpdt
3523ENDIF
3524
3525END FUNCTION timedelta_depop
3526
3527
3528elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3529TYPE(timedelta),INTENT(IN) :: this, that
3530LOGICAL :: res
3531
3532res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3533
3534END FUNCTION timedelta_eq
3535
3536
3537ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3538TYPE(timedelta),INTENT(IN) :: this, that
3539LOGICAL :: res
3540
3541res = .NOT.(this == that)
3542
3543END FUNCTION timedelta_ne
3544
3545
3546ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
3547TYPE(timedelta),INTENT(IN) :: this, that
3548LOGICAL :: res
3549
3550res = this%iminuti > that%iminuti
3551
3552END FUNCTION timedelta_gt
3553
3554
3555ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
3556TYPE(timedelta),INTENT(IN) :: this, that
3557LOGICAL :: res
3558
3559res = this%iminuti < that%iminuti
3560
3561END FUNCTION timedelta_lt
3562
3563
3564ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
3565TYPE(timedelta),INTENT(IN) :: this, that
3566LOGICAL :: res
3567
3568IF (this == that) THEN
3569 res = .true.
3570ELSE IF (this > that) THEN
3571 res = .true.
3572ELSE
3573 res = .false.
3574ENDIF
3575
3576END FUNCTION timedelta_ge
3577
3578
3579elemental FUNCTION timedelta_le(this, that) RESULT(res)
3580TYPE(timedelta),INTENT(IN) :: this, that
3581LOGICAL :: res
3582
3583IF (this == that) THEN
3584 res = .true.
3585ELSE IF (this < that) THEN
3586 res = .true.
3587ELSE
3588 res = .false.
3589ENDIF
3590
3591END FUNCTION timedelta_le
3592
3593
3594ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
3595TYPE(timedelta),INTENT(IN) :: this, that
3596TYPE(timedelta) :: res
3597
3598res%iminuti = this%iminuti + that%iminuti
3599res%month = this%month + that%month
3600
3601END FUNCTION timedelta_add
3602
3603
3604ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
3605TYPE(timedelta),INTENT(IN) :: this, that
3606TYPE(timedelta) :: res
3607
3608res%iminuti = this%iminuti - that%iminuti
3609res%month = this%month - that%month
3610
3611END FUNCTION timedelta_sub
3612
3613
3614ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
3615TYPE(timedelta),INTENT(IN) :: this
3616INTEGER,INTENT(IN) :: n
3617TYPE(timedelta) :: res
3618
3619res%iminuti = this%iminuti*n
3620res%month = this%month*n
3621
3622END FUNCTION timedelta_mult
3623
3624
3625ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
3626INTEGER,INTENT(IN) :: n
3627TYPE(timedelta),INTENT(IN) :: this
3628TYPE(timedelta) :: res
3629
3630res%iminuti = this%iminuti*n
3631res%month = this%month*n
3632
3633END FUNCTION timedelta_tlum
3634
3635
3636ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
3637TYPE(timedelta),INTENT(IN) :: this
3638INTEGER,INTENT(IN) :: n
3639TYPE(timedelta) :: res
3640
3641res%iminuti = this%iminuti/n
3642res%month = this%month/n
3643
3644END FUNCTION timedelta_divint
3645
3646
3647ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
3648TYPE(timedelta),INTENT(IN) :: this, that
3649INTEGER :: res
3650
3651res = int(this%iminuti/that%iminuti)
3652
3653END FUNCTION timedelta_divtd
3654
3655
3656elemental FUNCTION timedelta_mod(this, that) RESULT(res)
3657TYPE(timedelta),INTENT(IN) :: this, that
3658TYPE(timedelta) :: res
3659
3660res%iminuti = mod(this%iminuti, that%iminuti)
3661res%month = 0
3662
3663END FUNCTION timedelta_mod
3664
3665
3666ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
3667TYPE(datetime),INTENT(IN) :: this
3668TYPE(timedelta),INTENT(IN) :: that
3669TYPE(timedelta) :: res
3670
3671IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
3672 res = timedelta_0
3673ELSE
3674 res%iminuti = mod(this%iminuti, that%iminuti)
3675 res%month = 0
3676ENDIF
3677
3678END FUNCTION datetime_timedelta_mod
3679
3680
3681ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
3682TYPE(timedelta),INTENT(IN) :: this
3683TYPE(timedelta) :: res
3684
3685res%iminuti = abs(this%iminuti)
3686res%month = abs(this%month)
3687
3688END FUNCTION timedelta_abs
3689
3690
3695SUBROUTINE timedelta_read_unit(this, unit)
3696TYPE(timedelta),INTENT(out) :: this
3697INTEGER, INTENT(in) :: unit
3698
3699CALL timedelta_vect_read_unit((/this/), unit)
3700
3701END SUBROUTINE timedelta_read_unit
3702
3703
3708SUBROUTINE timedelta_vect_read_unit(this, unit)
3709TYPE(timedelta) :: this(:)
3710INTEGER, INTENT(in) :: unit
3711
3712CHARACTER(len=40) :: form
3713CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3714INTEGER :: i
3715
3716ALLOCATE(dateiso(SIZE(this)))
3717INQUIRE(unit, form=form)
3718IF (form == 'FORMATTED') THEN
3719 READ(unit,'(3(A23,1X))')dateiso
3720ELSE
3721 READ(unit)dateiso
3722ENDIF
3723DO i = 1, SIZE(dateiso)
3725ENDDO
3726DEALLOCATE(dateiso)
3727
3728END SUBROUTINE timedelta_vect_read_unit
3729
3730
3735SUBROUTINE timedelta_write_unit(this, unit)
3736TYPE(timedelta),INTENT(in) :: this
3737INTEGER, INTENT(in) :: unit
3738
3739CALL timedelta_vect_write_unit((/this/), unit)
3740
3741END SUBROUTINE timedelta_write_unit
3742
3743
3748SUBROUTINE timedelta_vect_write_unit(this, unit)
3749TYPE(timedelta),INTENT(in) :: this(:)
3750INTEGER, INTENT(in) :: unit
3751
3752CHARACTER(len=40) :: form
3753CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3754INTEGER :: i
3755
3756ALLOCATE(dateiso(SIZE(this)))
3757DO i = 1, SIZE(dateiso)
3759ENDDO
3760INQUIRE(unit, form=form)
3761IF (form == 'FORMATTED') THEN
3762 WRITE(unit,'(3(A23,1X))')dateiso
3763ELSE
3764 WRITE(unit)dateiso
3765ENDIF
3766DEALLOCATE(dateiso)
3767
3768END SUBROUTINE timedelta_vect_write_unit
3769
3770
3771ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
3772TYPE(timedelta),INTENT(in) :: this
3773LOGICAL :: res
3774
3775res = .not. this == timedelta_miss
3776
3777end FUNCTION c_e_timedelta
3778
3779
3780elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
3781
3782!!omstart JELADATA5
3783! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3784! 1 IMINUTI)
3785!
3786! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
3787!
3788! variabili integer*4
3789! IN:
3790! IDAY,IMONTH,IYEAR, I*4
3791! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3792!
3793! OUT:
3794! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3795!!OMEND
3796
3797INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
3798INTEGER,intent(out) :: iminuti
3799
3800iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
3801
3802END SUBROUTINE jeladata5
3803
3804
3805elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
3806INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
3807INTEGER(KIND=int_ll),intent(out) :: imillisec
3808
3809imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
3810 + imsec
3811
3812END SUBROUTINE jeladata5_1
3813
3814
3815
3816elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
3817
3818!!omstart JELADATA6
3819! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3820! 1 IMINUTI)
3821!
3822! Calcola la data e l'ora corrispondente a IMINUTI dopo il
3823! 1/1/1
3824!
3825! variabili integer*4
3826! IN:
3827! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3828!
3829! OUT:
3830! IDAY,IMONTH,IYEAR, I*4
3831! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3832!!OMEND
3833
3834
3835INTEGER,intent(in) :: iminuti
3836INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
3837
3838INTEGER ::igiorno
3839
3840imin = mod(iminuti,60)
3841ihour = mod(iminuti,1440)/60
3842igiorno = iminuti/1440
3844CALL ndyin(igiorno,iday,imonth,iyear)
3845
3846END SUBROUTINE jeladata6
3847
3848
3849elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
3850INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
3851INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
3852
3853INTEGER :: igiorno
3854
3856!imin = MOD(imillisec/60000_int_ll, 60)
3857!ihour = MOD(imillisec/3600000_int_ll, 24)
3858imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
3859ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
3860igiorno = int(imillisec/86400000_int_ll)
3861!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
3862CALL ndyin(igiorno,iday,imonth,iyear)
3863
3864END SUBROUTINE jeladata6_1
3865
3866
3867elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
3868
3869!!OMSTART NDYIN
3870! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
3871! restituisce la data fornendo in input il numero di
3872! giorni dal 1/1/1
3873!
3874!!omend
3875
3876INTEGER,intent(in) :: ndays
3877INTEGER,intent(out) :: igg, imm, iaa
3878integer :: n,lndays
3879
3880lndays=ndays
3881
3882n = lndays/d400
3883lndays = lndays - n*d400
3884iaa = year0 + n*400
3885n = min(lndays/d100, 3)
3886lndays = lndays - n*d100
3887iaa = iaa + n*100
3888n = lndays/d4
3889lndays = lndays - n*d4
3890iaa = iaa + n*4
3891n = min(lndays/d1, 3)
3892lndays = lndays - n*d1
3893iaa = iaa + n
3894n = bisextilis(iaa)
3895DO imm = 1, 12
3896 IF (lndays < ianno(imm+1,n)) EXIT
3897ENDDO
3898igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
3899
3900END SUBROUTINE ndyin
3901
3902
3903integer elemental FUNCTION ndays(igg,imm,iaa)
3904
3905!!OMSTART NDAYS
3906! FUNCTION NDAYS(IGG,IMM,IAA)
3907! restituisce il numero di giorni dal 1/1/1
3908! fornendo in input la data
3909!
3910!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3911! nota bene E' SICURO !!!
3912! un anno e' bisestile se divisibile per 4
3913! un anno rimane bisestile se divisibile per 400
3914! un anno NON e' bisestile se divisibile per 100
3915!
3916!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3917!
3918!!omend
3919
3920INTEGER, intent(in) :: igg, imm, iaa
3921
3922INTEGER :: lmonth, lyear
3923
3924! Limito il mese a [1-12] e correggo l'anno coerentemente
3925lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
3926lyear = iaa + (imm - lmonth)/12
3927ndays = igg+ianno(lmonth, bisextilis(lyear))
3928ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
3929 (lyear-year0)/400
3930
3931END FUNCTION ndays
3932
3933
3934elemental FUNCTION bisextilis(annum)
3935INTEGER,INTENT(in) :: annum
3936INTEGER :: bisextilis
3937
3939 bisextilis = 2
3940ELSE
3941 bisextilis = 1
3942ENDIF
3943END FUNCTION bisextilis
3944
3945
3946ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
3947TYPE(cyclicdatetime),INTENT(IN) :: this, that
3948LOGICAL :: res
3949
3950res = .true.
3951if (this%minute /= that%minute) res=.false.
3952if (this%hour /= that%hour) res=.false.
3953if (this%day /= that%day) res=.false.
3954if (this%month /= that%month) res=.false.
3955if (this%tendaysp /= that%tendaysp) res=.false.
3956
3957END FUNCTION cyclicdatetime_eq
3958
3959
3960ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
3961TYPE(cyclicdatetime),INTENT(IN) :: this
3962TYPE(datetime),INTENT(IN) :: that
3963LOGICAL :: res
3964
3965integer :: minute,hour,day,month
3966
3968
3969res = .true.
3975 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
3976end if
3977
3978END FUNCTION cyclicdatetime_datetime_eq
3979
3980
3981ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
3982TYPE(datetime),INTENT(IN) :: this
3983TYPE(cyclicdatetime),INTENT(IN) :: that
3984LOGICAL :: res
3985
3986integer :: minute,hour,day,month
3987
3989
3990res = .true.
3995
3997 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
3998end if
3999
4000
4001END FUNCTION datetime_cyclicdatetime_eq
4002
4003ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4004TYPE(cyclicdatetime),INTENT(in) :: this
4005LOGICAL :: res
4006
4007res = .not. this == cyclicdatetime_miss
4008
4009end FUNCTION c_e_cyclicdatetime
4010
4011
4014FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4015INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4016INTEGER,INTENT(IN),OPTIONAL :: month
4017INTEGER,INTENT(IN),OPTIONAL :: day
4018INTEGER,INTENT(IN),OPTIONAL :: hour
4019INTEGER,INTENT(IN),OPTIONAL :: minute
4020CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4021
4022integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4023
4024
4025TYPE(cyclicdatetime) :: this
4026
4027if (present(chardate)) then
4028
4029 ltendaysp=imiss
4030 lmonth=imiss
4031 lday=imiss
4032 lhour=imiss
4033 lminute=imiss
4034
4036 ! TMMGGhhmm
4037 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4038 !print*,chardate(1:1),ios,ltendaysp
4039 if (ios /= 0)ltendaysp=imiss
4040
4041 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4042 !print*,chardate(2:3),ios,lmonth
4043 if (ios /= 0)lmonth=imiss
4044
4045 read(chardate(4:5),'(i2)',iostat=ios)lday
4046 !print*,chardate(4:5),ios,lday
4047 if (ios /= 0)lday=imiss
4048
4049 read(chardate(6:7),'(i2)',iostat=ios)lhour
4050 !print*,chardate(6:7),ios,lhour
4051 if (ios /= 0)lhour=imiss
4052
4053 read(chardate(8:9),'(i2)',iostat=ios)lminute
4054 !print*,chardate(8:9),ios,lminute
4055 if (ios /= 0)lminute=imiss
4056 end if
4057
4058 this%tendaysp=ltendaysp
4059 this%month=lmonth
4060 this%day=lday
4061 this%hour=lhour
4062 this%minute=lminute
4063else
4064 this%tendaysp=optio_l(tendaysp)
4065 this%month=optio_l(month)
4066 this%day=optio_l(day)
4067 this%hour=optio_l(hour)
4068 this%minute=optio_l(minute)
4069end if
4070
4071END FUNCTION cyclicdatetime_new
4072
4075elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4076TYPE(cyclicdatetime),INTENT(IN) :: this
4077
4078CHARACTER(len=80) :: char
4079
4082
4083END FUNCTION cyclicdatetime_to_char
4084
4085
4098FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4099TYPE(cyclicdatetime),INTENT(IN) :: this
4100
4101TYPE(datetime) :: dtc
4102
4103integer :: year,month,day,hour
4104
4105dtc = datetime_miss
4106
4107! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4109 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4110 return
4111end if
4112
4113! minute present -> not good for conventional datetime
4115! day, month and tendaysp present -> no good
4117
4119 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4121 day=(this%tendaysp-1)*10+1
4122 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4124 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4126 ! only day present -> no good
4127 return
4128end if
4129
4132 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4133end if
4134
4135
4136END FUNCTION cyclicdatetime_to_conventional
4137
4138
4139
4140FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4141TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4142
4143CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4144
4145char=cyclicdatetime_to_char(in)
4146
4147END FUNCTION trim_cyclicdatetime_to_char
4148
4149
4150
4151SUBROUTINE display_cyclicdatetime(this)
4152TYPE(cyclicdatetime),INTENT(in) :: this
4153
4155
4156end subroutine display_cyclicdatetime
4157
4158
4159#include "array_utilities_inc.F90"
4160
4162
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 |