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