libsim Versione 7.2.4
|
◆ cyclicdatetime_to_char()
Restituisce una rappresentazione carattere stampabile di un oggetto cyclicdatetime. Definizione alla linea 2379 del file datetime_class.F90. 2380! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2381! authors:
2382! Davide Cesari <dcesari@arpa.emr.it>
2383! Paolo Patruno <ppatruno@arpa.emr.it>
2384
2385! This program is free software; you can redistribute it and/or
2386! modify it under the terms of the GNU General Public License as
2387! published by the Free Software Foundation; either version 2 of
2388! the License, or (at your option) any later version.
2389
2390! This program is distributed in the hope that it will be useful,
2391! but WITHOUT ANY WARRANTY; without even the implied warranty of
2392! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2393! GNU General Public License for more details.
2394
2395! You should have received a copy of the GNU General Public License
2396! along with this program. If not, see <http://www.gnu.org/licenses/>.
2397#include "config.h"
2398
2419IMPLICIT NONE
2420
2421INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2422
2425 PRIVATE
2426 INTEGER(KIND=int_ll) :: iminuti
2428
2437 PRIVATE
2438 INTEGER(KIND=int_ll) :: iminuti
2439 INTEGER :: month
2441
2442
2447 PRIVATE
2448 INTEGER :: minute
2449 INTEGER :: hour
2450 INTEGER :: day
2451 INTEGER :: tendaysp
2452 INTEGER :: month
2454
2455
2463INTEGER, PARAMETER :: datetime_utc=1
2465INTEGER, PARAMETER :: datetime_local=2
2475TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2476
2477
2478INTEGER(kind=dateint), PARAMETER :: &
2479 sec_in_day=86400, &
2480 sec_in_hour=3600, &
2481 sec_in_min=60, &
2482 min_in_day=1440, &
2483 min_in_hour=60, &
2484 hour_in_day=24
2485
2486INTEGER,PARAMETER :: &
2487 year0=1, & ! anno di origine per iminuti
2488 d1=365, & ! giorni/1 anno nel calendario gregoriano
2489 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2490 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2491 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2492 ianno(13,2)=reshape((/ &
2493 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2494 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2495
2496INTEGER(KIND=int_ll),PARAMETER :: &
2497 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2498
2503 MODULE PROCEDURE datetime_init, timedelta_init
2504END INTERFACE
2505
2509 MODULE PROCEDURE datetime_delete, timedelta_delete
2510END INTERFACE
2511
2514 MODULE PROCEDURE datetime_getval, timedelta_getval
2515END INTERFACE
2516
2519 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2520END INTERFACE
2521
2522
2541 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2542END INTERFACE
2543
2549INTERFACE OPERATOR (==)
2550 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2551 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2552END INTERFACE
2553
2559INTERFACE OPERATOR (/=)
2560 MODULE PROCEDURE datetime_ne, timedelta_ne
2561END INTERFACE
2562
2570INTERFACE OPERATOR (>)
2571 MODULE PROCEDURE datetime_gt, timedelta_gt
2572END INTERFACE
2573
2581INTERFACE OPERATOR (<)
2582 MODULE PROCEDURE datetime_lt, timedelta_lt
2583END INTERFACE
2584
2592INTERFACE OPERATOR (>=)
2593 MODULE PROCEDURE datetime_ge, timedelta_ge
2594END INTERFACE
2595
2603INTERFACE OPERATOR (<=)
2604 MODULE PROCEDURE datetime_le, timedelta_le
2605END INTERFACE
2606
2613INTERFACE OPERATOR (+)
2614 MODULE PROCEDURE datetime_add, timedelta_add
2615END INTERFACE
2616
2624INTERFACE OPERATOR (-)
2625 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
2626END INTERFACE
2627
2633INTERFACE OPERATOR (*)
2634 MODULE PROCEDURE timedelta_mult, timedelta_tlum
2635END INTERFACE
2636
2643INTERFACE OPERATOR (/)
2644 MODULE PROCEDURE timedelta_divint, timedelta_divtd
2645END INTERFACE
2646
2658 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2659END INTERFACE
2660
2664 MODULE PROCEDURE timedelta_abs
2665END INTERFACE
2666
2670 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2671 timedelta_read_unit, timedelta_vect_read_unit
2672END INTERFACE
2673
2677 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2678 timedelta_write_unit, timedelta_vect_write_unit
2679END INTERFACE
2680
2683 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2684END INTERFACE
2685
2688 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
2689END INTERFACE
2690
2691#undef VOL7D_POLY_TYPE
2692#undef VOL7D_POLY_TYPES
2693#undef ENABLE_SORT
2694#define VOL7D_POLY_TYPE TYPE(datetime)
2695#define VOL7D_POLY_TYPES _datetime
2696#define ENABLE_SORT
2697#include "array_utilities_pre.F90"
2698
2699
2700#define ARRAYOF_ORIGTYPE TYPE(datetime)
2701#define ARRAYOF_TYPE arrayof_datetime
2702#define ARRAYOF_ORIGEQ 1
2703#include "arrayof_pre.F90"
2704! from arrayof
2705
2706PRIVATE
2707
2709 datetime_min, datetime_max, &
2712 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2713 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2715 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2716 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2718 count_distinct, pack_distinct, &
2719 count_distinct_sorted, pack_distinct_sorted, &
2720 count_and_pack_distinct, &
2722 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
2724PUBLIC insert_unique, append_unique
2725PUBLIC cyclicdatetime_to_conventional
2726
2727CONTAINS
2728
2729
2730! ==============
2731! == datetime ==
2732! ==============
2733
2740ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
2741 unixtime, isodate, simpledate) RESULT(this)
2742INTEGER,INTENT(IN),OPTIONAL :: year
2743INTEGER,INTENT(IN),OPTIONAL :: month
2744INTEGER,INTENT(IN),OPTIONAL :: day
2745INTEGER,INTENT(IN),OPTIONAL :: hour
2746INTEGER,INTENT(IN),OPTIONAL :: minute
2747INTEGER,INTENT(IN),OPTIONAL :: msec
2748INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2749CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2750CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2751
2752TYPE(datetime) :: this
2753INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2754CHARACTER(len=23) :: datebuf
2755
2756IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
2757 lyear = year
2758 IF (PRESENT(month)) THEN
2759 lmonth = month
2760 ELSE
2761 lmonth = 1
2762 ENDIF
2763 IF (PRESENT(day)) THEN
2764 lday = day
2765 ELSE
2766 lday = 1
2767 ENDIF
2768 IF (PRESENT(hour)) THEN
2769 lhour = hour
2770 ELSE
2771 lhour = 0
2772 ENDIF
2773 IF (PRESENT(minute)) THEN
2774 lminute = minute
2775 ELSE
2776 lminute = 0
2777 ENDIF
2778 IF (PRESENT(msec)) THEN
2779 lmsec = msec
2780 ELSE
2781 lmsec = 0
2782 ENDIF
2783
2786 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2787 else
2788 this=datetime_miss
2789 end if
2790
2791ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
2793 this%iminuti = (unixtime + unsec)*1000
2794 else
2795 this=datetime_miss
2796 end if
2797
2798ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
2799
2801 datebuf(1:23) = '0001-01-01 00:00:00.000'
2802 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
2803 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
2804 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2805 lmsec = lmsec + lsec*1000
2806 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2807 RETURN
2808
2809100 CONTINUE ! condizione di errore in isodate
2811 RETURN
2812 ELSE
2813 this = datetime_miss
2814 ENDIF
2815
2816ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
2818 datebuf(1:17) = '00010101000000000'
2819 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
2820 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
2821 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2822 lmsec = lmsec + lsec*1000
2823 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2824 RETURN
2825
2826120 CONTINUE ! condizione di errore in simpledate
2828 RETURN
2829 ELSE
2830 this = datetime_miss
2831 ENDIF
2832
2833ELSE
2834 this = datetime_miss
2835ENDIF
2836
2837END FUNCTION datetime_new
2838
2839
2841FUNCTION datetime_new_now(now) RESULT(this)
2842INTEGER,INTENT(IN) :: now
2843TYPE(datetime) :: this
2844
2845INTEGER :: dt(8)
2846
2848 CALL date_and_time(values=dt)
2849 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
2851 msec=dt(7)*1000+dt(8))
2852ELSE
2853 this = datetime_miss
2854ENDIF
2855
2856END FUNCTION datetime_new_now
2857
2858
2865SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
2866 unixtime, isodate, simpledate, now)
2867TYPE(datetime),INTENT(INOUT) :: this
2868INTEGER,INTENT(IN),OPTIONAL :: year
2869INTEGER,INTENT(IN),OPTIONAL :: month
2870INTEGER,INTENT(IN),OPTIONAL :: day
2871INTEGER,INTENT(IN),OPTIONAL :: hour
2872INTEGER,INTENT(IN),OPTIONAL :: minute
2873INTEGER,INTENT(IN),OPTIONAL :: msec
2874INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2875CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2876CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2877INTEGER,INTENT(IN),OPTIONAL :: now
2878
2879IF (PRESENT(now)) THEN
2880 this = datetime_new_now(now)
2881ELSE
2882 this = datetime_new(year, month, day, hour, minute, msec, &
2883 unixtime, isodate, simpledate)
2884ENDIF
2885
2886END SUBROUTINE datetime_init
2887
2888
2889ELEMENTAL SUBROUTINE datetime_delete(this)
2890TYPE(datetime),INTENT(INOUT) :: this
2891
2892this%iminuti = illmiss
2893
2894END SUBROUTINE datetime_delete
2895
2896
2901PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
2902 unixtime, isodate, simpledate, oraclesimdate)
2903TYPE(datetime),INTENT(IN) :: this
2904INTEGER,INTENT(OUT),OPTIONAL :: year
2905INTEGER,INTENT(OUT),OPTIONAL :: month
2906INTEGER,INTENT(OUT),OPTIONAL :: day
2907INTEGER,INTENT(OUT),OPTIONAL :: hour
2908INTEGER,INTENT(OUT),OPTIONAL :: minute
2909INTEGER,INTENT(OUT),OPTIONAL :: msec
2910INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
2911CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
2912CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
2913CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
2914
2915INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2916CHARACTER(len=23) :: datebuf
2917
2918IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
2919 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
2920 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
2921
2922 IF (this == datetime_miss) THEN
2923
2924 IF (PRESENT(msec)) THEN
2925 msec = imiss
2926 ENDIF
2927 IF (PRESENT(minute)) THEN
2928 minute = imiss
2929 ENDIF
2930 IF (PRESENT(hour)) THEN
2931 hour = imiss
2932 ENDIF
2933 IF (PRESENT(day)) THEN
2934 day = imiss
2935 ENDIF
2936 IF (PRESENT(month)) THEN
2937 month = imiss
2938 ENDIF
2939 IF (PRESENT(year)) THEN
2940 year = imiss
2941 ENDIF
2942 IF (PRESENT(isodate)) THEN
2943 isodate = cmiss
2944 ENDIF
2945 IF (PRESENT(simpledate)) THEN
2946 simpledate = cmiss
2947 ENDIF
2948 IF (PRESENT(oraclesimdate)) THEN
2949!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2950!!$ 'obsoleto, usare piuttosto simpledate')
2951 oraclesimdate=cmiss
2952 ENDIF
2953 IF (PRESENT(unixtime)) THEN
2954 unixtime = illmiss
2955 ENDIF
2956
2957 ELSE
2958
2959 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2960 IF (PRESENT(msec)) THEN
2961 msec = lmsec
2962 ENDIF
2963 IF (PRESENT(minute)) THEN
2964 minute = lminute
2965 ENDIF
2966 IF (PRESENT(hour)) THEN
2967 hour = lhour
2968 ENDIF
2969 IF (PRESENT(day)) THEN
2970 day = lday
2971 ENDIF
2972 IF (PRESENT(month)) THEN
2973 month = lmonth
2974 ENDIF
2975 IF (PRESENT(year)) THEN
2976 year = lyear
2977 ENDIF
2978 IF (PRESENT(isodate)) THEN
2979 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
2980 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
2982 isodate = datebuf(1:min(len(isodate),23))
2983 ENDIF
2984 IF (PRESENT(simpledate)) THEN
2985 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
2986 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
2987 simpledate = datebuf(1:min(len(simpledate),17))
2988 ENDIF
2989 IF (PRESENT(oraclesimdate)) THEN
2990!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2991!!$ 'obsoleto, usare piuttosto simpledate')
2992 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
2993 ENDIF
2994 IF (PRESENT(unixtime)) THEN
2995 unixtime = this%iminuti/1000_int_ll-unsec
2996 ENDIF
2997
2998 ENDIF
2999ENDIF
3000
3001END SUBROUTINE datetime_getval
3002
3003
3006elemental FUNCTION datetime_to_char(this) RESULT(char)
3007TYPE(datetime),INTENT(IN) :: this
3008
3009CHARACTER(len=23) :: char
3010
3012
3013END FUNCTION datetime_to_char
3014
3015
3016FUNCTION trim_datetime_to_char(in) RESULT(char)
3017TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3018
3019CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3020
3021char=datetime_to_char(in)
3022
3023END FUNCTION trim_datetime_to_char
3024
3025
3026
3027SUBROUTINE display_datetime(this)
3028TYPE(datetime),INTENT(in) :: this
3029
3031
3032end subroutine display_datetime
3033
3034
3035
3036SUBROUTINE display_timedelta(this)
3037TYPE(timedelta),INTENT(in) :: this
3038
3040
3041end subroutine display_timedelta
3042
3043
3044
3045ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3046TYPE(datetime),INTENT(in) :: this
3047LOGICAL :: res
3048
3049res = .not. this == datetime_miss
3050
3051end FUNCTION c_e_datetime
3052
3053
3054ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3055TYPE(datetime),INTENT(IN) :: this, that
3056LOGICAL :: res
3057
3058res = this%iminuti == that%iminuti
3059
3060END FUNCTION datetime_eq
3061
3062
3063ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3064TYPE(datetime),INTENT(IN) :: this, that
3065LOGICAL :: res
3066
3067res = .NOT.(this == that)
3068
3069END FUNCTION datetime_ne
3070
3071
3072ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3073TYPE(datetime),INTENT(IN) :: this, that
3074LOGICAL :: res
3075
3076res = this%iminuti > that%iminuti
3077
3078END FUNCTION datetime_gt
3079
3080
3081ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3082TYPE(datetime),INTENT(IN) :: this, that
3083LOGICAL :: res
3084
3085res = this%iminuti < that%iminuti
3086
3087END FUNCTION datetime_lt
3088
3089
3090ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3091TYPE(datetime),INTENT(IN) :: this, that
3092LOGICAL :: res
3093
3094IF (this == that) THEN
3095 res = .true.
3096ELSE IF (this > that) THEN
3097 res = .true.
3098ELSE
3099 res = .false.
3100ENDIF
3101
3102END FUNCTION datetime_ge
3103
3104
3105ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3106TYPE(datetime),INTENT(IN) :: this, that
3107LOGICAL :: res
3108
3109IF (this == that) THEN
3110 res = .true.
3111ELSE IF (this < that) THEN
3112 res = .true.
3113ELSE
3114 res = .false.
3115ENDIF
3116
3117END FUNCTION datetime_le
3118
3119
3120FUNCTION datetime_add(this, that) RESULT(res)
3121TYPE(datetime),INTENT(IN) :: this
3122TYPE(timedelta),INTENT(IN) :: that
3123TYPE(datetime) :: res
3124
3125INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3126
3127IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3128 res = datetime_miss
3129ELSE
3130 res%iminuti = this%iminuti + that%iminuti
3131 IF (that%month /= 0) THEN
3133 minute=lminute, msec=lmsec)
3135 hour=lhour, minute=lminute, msec=lmsec)
3136 ENDIF
3137ENDIF
3138
3139END FUNCTION datetime_add
3140
3141
3142ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3143TYPE(datetime),INTENT(IN) :: this, that
3144TYPE(timedelta) :: res
3145
3146IF (this == datetime_miss .OR. that == datetime_miss) THEN
3147 res = timedelta_miss
3148ELSE
3149 res%iminuti = this%iminuti - that%iminuti
3150 res%month = 0
3151ENDIF
3152
3153END FUNCTION datetime_subdt
3154
3155
3156FUNCTION datetime_subtd(this, that) RESULT(res)
3157TYPE(datetime),INTENT(IN) :: this
3158TYPE(timedelta),INTENT(IN) :: that
3159TYPE(datetime) :: res
3160
3161INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3162
3163IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3164 res = datetime_miss
3165ELSE
3166 res%iminuti = this%iminuti - that%iminuti
3167 IF (that%month /= 0) THEN
3169 minute=lminute, msec=lmsec)
3171 hour=lhour, minute=lminute, msec=lmsec)
3172 ENDIF
3173ENDIF
3174
3175END FUNCTION datetime_subtd
3176
3177
3182SUBROUTINE datetime_read_unit(this, unit)
3183TYPE(datetime),INTENT(out) :: this
3184INTEGER, INTENT(in) :: unit
3185CALL datetime_vect_read_unit((/this/), unit)
3186
3187END SUBROUTINE datetime_read_unit
3188
3189
3194SUBROUTINE datetime_vect_read_unit(this, unit)
3195TYPE(datetime) :: this(:)
3196INTEGER, INTENT(in) :: unit
3197
3198CHARACTER(len=40) :: form
3199CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3200INTEGER :: i
3201
3202ALLOCATE(dateiso(SIZE(this)))
3203INQUIRE(unit, form=form)
3204IF (form == 'FORMATTED') THEN
3205 READ(unit,'(A23,1X)')dateiso
3206ELSE
3207 READ(unit)dateiso
3208ENDIF
3209DO i = 1, SIZE(dateiso)
3211ENDDO
3212DEALLOCATE(dateiso)
3213
3214END SUBROUTINE datetime_vect_read_unit
3215
3216
3221SUBROUTINE datetime_write_unit(this, unit)
3222TYPE(datetime),INTENT(in) :: this
3223INTEGER, INTENT(in) :: unit
3224
3225CALL datetime_vect_write_unit((/this/), unit)
3226
3227END SUBROUTINE datetime_write_unit
3228
3229
3234SUBROUTINE datetime_vect_write_unit(this, unit)
3235TYPE(datetime),INTENT(in) :: this(:)
3236INTEGER, INTENT(in) :: unit
3237
3238CHARACTER(len=40) :: form
3239CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3240INTEGER :: i
3241
3242ALLOCATE(dateiso(SIZE(this)))
3243DO i = 1, SIZE(dateiso)
3245ENDDO
3246INQUIRE(unit, form=form)
3247IF (form == 'FORMATTED') THEN
3248 WRITE(unit,'(A23,1X)')dateiso
3249ELSE
3250 WRITE(unit)dateiso
3251ENDIF
3252DEALLOCATE(dateiso)
3253
3254END SUBROUTINE datetime_vect_write_unit
3255
3256
3257#include "arrayof_post.F90"
3258
3259
3260! ===============
3261! == timedelta ==
3262! ===============
3269FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3270 isodate, simpledate, oraclesimdate) RESULT (this)
3271INTEGER,INTENT(IN),OPTIONAL :: year
3272INTEGER,INTENT(IN),OPTIONAL :: month
3273INTEGER,INTENT(IN),OPTIONAL :: day
3274INTEGER,INTENT(IN),OPTIONAL :: hour
3275INTEGER,INTENT(IN),OPTIONAL :: minute
3276INTEGER,INTENT(IN),OPTIONAL :: sec
3277INTEGER,INTENT(IN),OPTIONAL :: msec
3278CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3279CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3280CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3281
3282TYPE(timedelta) :: this
3283
3284CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3285 isodate, simpledate, oraclesimdate)
3286
3287END FUNCTION timedelta_new
3288
3289
3294SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3295 isodate, simpledate, oraclesimdate)
3296TYPE(timedelta),INTENT(INOUT) :: this
3297INTEGER,INTENT(IN),OPTIONAL :: year
3298INTEGER,INTENT(IN),OPTIONAL :: month
3299INTEGER,INTENT(IN),OPTIONAL :: day
3300INTEGER,INTENT(IN),OPTIONAL :: hour
3301INTEGER,INTENT(IN),OPTIONAL :: minute
3302INTEGER,INTENT(IN),OPTIONAL :: sec
3303INTEGER,INTENT(IN),OPTIONAL :: msec
3304CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3305CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3306CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3307
3308INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3309CHARACTER(len=23) :: datebuf
3310
3311this%month = 0
3312
3313IF (PRESENT(isodate)) THEN
3314 datebuf(1:23) = '0000000000 00:00:00.000'
3315 l = len_trim(isodate)
3316! IF (l > 0) THEN
3318 IF (n > 0) THEN
3319 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3320 datebuf(12-n:12-n+l-1) = isodate(:l)
3321 ELSE
3322 datebuf(1:l) = isodate(1:l)
3323 ENDIF
3324! ENDIF
3325
3326! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3327 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3328 h, m, s, ms
3329 this%month = lmonth + 12*lyear
3330 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3331 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3332 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3333 RETURN
3334
3335200 CONTINUE ! condizione di errore in isodate
3337 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3338 CALL raise_error()
3339
3340ELSE IF (PRESENT(simpledate)) THEN
3341 datebuf(1:17) = '00000000000000000'
3342 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3343 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3344 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3345 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3346 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3347
3348220 CONTINUE ! condizione di errore in simpledate
3350 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3351 CALL raise_error()
3352 RETURN
3353
3354ELSE IF (PRESENT(oraclesimdate)) THEN
3355 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3356 'obsoleto, usare piuttosto simpledate')
3357 READ(oraclesimdate, '(I8,2I2)')d, h, m
3358 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3359 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3360
3361ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3362 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3363 .and. .not. present(msec) .and. .not. present(isodate) &
3364 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3365
3366 this=timedelta_miss
3367
3368ELSE
3369 this%iminuti = 0
3370 IF (PRESENT(year)) THEN
3372 this%month = this%month + year*12
3373 else
3374 this=timedelta_miss
3375 return
3376 end if
3377 ENDIF
3378 IF (PRESENT(month)) THEN
3380 this%month = this%month + month
3381 else
3382 this=timedelta_miss
3383 return
3384 end if
3385 ENDIF
3386 IF (PRESENT(day)) THEN
3388 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3389 else
3390 this=timedelta_miss
3391 return
3392 end if
3393 ENDIF
3394 IF (PRESENT(hour)) THEN
3396 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3397 else
3398 this=timedelta_miss
3399 return
3400 end if
3401 ENDIF
3402 IF (PRESENT(minute)) THEN
3404 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3405 else
3406 this=timedelta_miss
3407 return
3408 end if
3409 ENDIF
3410 IF (PRESENT(sec)) THEN
3412 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3413 else
3414 this=timedelta_miss
3415 return
3416 end if
3417 ENDIF
3418 IF (PRESENT(msec)) THEN
3420 this%iminuti = this%iminuti + msec
3421 else
3422 this=timedelta_miss
3423 return
3424 end if
3425 ENDIF
3426ENDIF
3427
3428
3429
3430
3431END SUBROUTINE timedelta_init
3432
3433
3434SUBROUTINE timedelta_delete(this)
3435TYPE(timedelta),INTENT(INOUT) :: this
3436
3437this%iminuti = imiss
3438this%month = 0
3439
3440END SUBROUTINE timedelta_delete
3441
3442
3447PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3448 day, hour, minute, sec, msec, &
3449 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3450TYPE(timedelta),INTENT(IN) :: this
3451INTEGER,INTENT(OUT),OPTIONAL :: year
3452INTEGER,INTENT(OUT),OPTIONAL :: month
3453INTEGER,INTENT(OUT),OPTIONAL :: amonth
3454INTEGER,INTENT(OUT),OPTIONAL :: day
3455INTEGER,INTENT(OUT),OPTIONAL :: hour
3456INTEGER,INTENT(OUT),OPTIONAL :: minute
3457INTEGER,INTENT(OUT),OPTIONAL :: sec
3458INTEGER,INTENT(OUT),OPTIONAL :: msec
3459INTEGER,INTENT(OUT),OPTIONAL :: ahour
3460INTEGER,INTENT(OUT),OPTIONAL :: aminute
3461INTEGER,INTENT(OUT),OPTIONAL :: asec
3462INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
3463CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3464CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3465CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3466
3467CHARACTER(len=23) :: datebuf
3468
3469IF (PRESENT(amsec)) THEN
3470 amsec = this%iminuti
3471ENDIF
3472IF (PRESENT(asec)) THEN
3473 asec = int(this%iminuti/1000_int_ll)
3474ENDIF
3475IF (PRESENT(aminute)) THEN
3476 aminute = int(this%iminuti/60000_int_ll)
3477ENDIF
3478IF (PRESENT(ahour)) THEN
3479 ahour = int(this%iminuti/3600000_int_ll)
3480ENDIF
3481IF (PRESENT(msec)) THEN
3482 msec = int(mod(this%iminuti, 1000_int_ll))
3483ENDIF
3484IF (PRESENT(sec)) THEN
3485 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3486ENDIF
3487IF (PRESENT(minute)) THEN
3488 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3489ENDIF
3490IF (PRESENT(hour)) THEN
3491 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3492ENDIF
3493IF (PRESENT(day)) THEN
3494 day = int(this%iminuti/86400000_int_ll)
3495ENDIF
3496IF (PRESENT(amonth)) THEN
3497 amonth = this%month
3498ENDIF
3499IF (PRESENT(month)) THEN
3500 month = mod(this%month-1,12)+1
3501ENDIF
3502IF (PRESENT(year)) THEN
3503 year = this%month/12
3504ENDIF
3505IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3506 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3510 isodate = datebuf(1:min(len(isodate),23))
3511
3512ENDIF
3513IF (PRESENT(simpledate)) THEN
3514 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3515 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3517 mod(this%iminuti, 1000_int_ll)
3518 simpledate = datebuf(1:min(len(simpledate),17))
3519ENDIF
3520IF (PRESENT(oraclesimdate)) THEN
3521!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3522!!$ 'obsoleto, usare piuttosto simpledate')
3523 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3525ENDIF
3526
3527END SUBROUTINE timedelta_getval
3528
3529
3532elemental FUNCTION timedelta_to_char(this) RESULT(char)
3533TYPE(timedelta),INTENT(IN) :: this
3534
3535CHARACTER(len=23) :: char
3536
3538
3539END FUNCTION timedelta_to_char
3540
3541
3542FUNCTION trim_timedelta_to_char(in) RESULT(char)
3543TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3544
3545CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3546
3547char=timedelta_to_char(in)
3548
3549END FUNCTION trim_timedelta_to_char
3550
3551
3553elemental FUNCTION timedelta_getamsec(this)
3554TYPE(timedelta),INTENT(IN) :: this
3555INTEGER(kind=int_ll) :: timedelta_getamsec
3556
3557timedelta_getamsec = this%iminuti
3558
3559END FUNCTION timedelta_getamsec
3560
3561
3567FUNCTION timedelta_depop(this)
3568TYPE(timedelta),INTENT(IN) :: this
3569TYPE(timedelta) :: timedelta_depop
3570
3571TYPE(datetime) :: tmpdt
3572
3573IF (this%month == 0) THEN
3574 timedelta_depop = this
3575ELSE
3576 tmpdt = datetime_new(1970, 1, 1)
3577 timedelta_depop = (tmpdt + this) - tmpdt
3578ENDIF
3579
3580END FUNCTION timedelta_depop
3581
3582
3583elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3584TYPE(timedelta),INTENT(IN) :: this, that
3585LOGICAL :: res
3586
3587res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3588
3589END FUNCTION timedelta_eq
3590
3591
3592ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3593TYPE(timedelta),INTENT(IN) :: this, that
3594LOGICAL :: res
3595
3596res = .NOT.(this == that)
3597
3598END FUNCTION timedelta_ne
3599
3600
3601ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
3602TYPE(timedelta),INTENT(IN) :: this, that
3603LOGICAL :: res
3604
3605res = this%iminuti > that%iminuti
3606
3607END FUNCTION timedelta_gt
3608
3609
3610ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
3611TYPE(timedelta),INTENT(IN) :: this, that
3612LOGICAL :: res
3613
3614res = this%iminuti < that%iminuti
3615
3616END FUNCTION timedelta_lt
3617
3618
3619ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
3620TYPE(timedelta),INTENT(IN) :: this, that
3621LOGICAL :: res
3622
3623IF (this == that) THEN
3624 res = .true.
3625ELSE IF (this > that) THEN
3626 res = .true.
3627ELSE
3628 res = .false.
3629ENDIF
3630
3631END FUNCTION timedelta_ge
3632
3633
3634elemental FUNCTION timedelta_le(this, that) RESULT(res)
3635TYPE(timedelta),INTENT(IN) :: this, that
3636LOGICAL :: res
3637
3638IF (this == that) THEN
3639 res = .true.
3640ELSE IF (this < that) THEN
3641 res = .true.
3642ELSE
3643 res = .false.
3644ENDIF
3645
3646END FUNCTION timedelta_le
3647
3648
3649ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
3650TYPE(timedelta),INTENT(IN) :: this, that
3651TYPE(timedelta) :: res
3652
3653res%iminuti = this%iminuti + that%iminuti
3654res%month = this%month + that%month
3655
3656END FUNCTION timedelta_add
3657
3658
3659ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
3660TYPE(timedelta),INTENT(IN) :: this, that
3661TYPE(timedelta) :: res
3662
3663res%iminuti = this%iminuti - that%iminuti
3664res%month = this%month - that%month
3665
3666END FUNCTION timedelta_sub
3667
3668
3669ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
3670TYPE(timedelta),INTENT(IN) :: this
3671INTEGER,INTENT(IN) :: n
3672TYPE(timedelta) :: res
3673
3674res%iminuti = this%iminuti*n
3675res%month = this%month*n
3676
3677END FUNCTION timedelta_mult
3678
3679
3680ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
3681INTEGER,INTENT(IN) :: n
3682TYPE(timedelta),INTENT(IN) :: this
3683TYPE(timedelta) :: res
3684
3685res%iminuti = this%iminuti*n
3686res%month = this%month*n
3687
3688END FUNCTION timedelta_tlum
3689
3690
3691ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
3692TYPE(timedelta),INTENT(IN) :: this
3693INTEGER,INTENT(IN) :: n
3694TYPE(timedelta) :: res
3695
3696res%iminuti = this%iminuti/n
3697res%month = this%month/n
3698
3699END FUNCTION timedelta_divint
3700
3701
3702ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
3703TYPE(timedelta),INTENT(IN) :: this, that
3704INTEGER :: res
3705
3706res = int(this%iminuti/that%iminuti)
3707
3708END FUNCTION timedelta_divtd
3709
3710
3711elemental FUNCTION timedelta_mod(this, that) RESULT(res)
3712TYPE(timedelta),INTENT(IN) :: this, that
3713TYPE(timedelta) :: res
3714
3715res%iminuti = mod(this%iminuti, that%iminuti)
3716res%month = 0
3717
3718END FUNCTION timedelta_mod
3719
3720
3721ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
3722TYPE(datetime),INTENT(IN) :: this
3723TYPE(timedelta),INTENT(IN) :: that
3724TYPE(timedelta) :: res
3725
3726IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
3727 res = timedelta_0
3728ELSE
3729 res%iminuti = mod(this%iminuti, that%iminuti)
3730 res%month = 0
3731ENDIF
3732
3733END FUNCTION datetime_timedelta_mod
3734
3735
3736ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
3737TYPE(timedelta),INTENT(IN) :: this
3738TYPE(timedelta) :: res
3739
3740res%iminuti = abs(this%iminuti)
3741res%month = abs(this%month)
3742
3743END FUNCTION timedelta_abs
3744
3745
3750SUBROUTINE timedelta_read_unit(this, unit)
3751TYPE(timedelta),INTENT(out) :: this
3752INTEGER, INTENT(in) :: unit
3753
3754CALL timedelta_vect_read_unit((/this/), unit)
3755
3756END SUBROUTINE timedelta_read_unit
3757
3758
3763SUBROUTINE timedelta_vect_read_unit(this, unit)
3764TYPE(timedelta) :: this(:)
3765INTEGER, INTENT(in) :: unit
3766
3767CHARACTER(len=40) :: form
3768CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3769INTEGER :: i
3770
3771ALLOCATE(dateiso(SIZE(this)))
3772INQUIRE(unit, form=form)
3773IF (form == 'FORMATTED') THEN
3774 READ(unit,'(3(A23,1X))')dateiso
3775ELSE
3776 READ(unit)dateiso
3777ENDIF
3778DO i = 1, SIZE(dateiso)
3780ENDDO
3781DEALLOCATE(dateiso)
3782
3783END SUBROUTINE timedelta_vect_read_unit
3784
3785
3790SUBROUTINE timedelta_write_unit(this, unit)
3791TYPE(timedelta),INTENT(in) :: this
3792INTEGER, INTENT(in) :: unit
3793
3794CALL timedelta_vect_write_unit((/this/), unit)
3795
3796END SUBROUTINE timedelta_write_unit
3797
3798
3803SUBROUTINE timedelta_vect_write_unit(this, unit)
3804TYPE(timedelta),INTENT(in) :: this(:)
3805INTEGER, INTENT(in) :: unit
3806
3807CHARACTER(len=40) :: form
3808CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3809INTEGER :: i
3810
3811ALLOCATE(dateiso(SIZE(this)))
3812DO i = 1, SIZE(dateiso)
3814ENDDO
3815INQUIRE(unit, form=form)
3816IF (form == 'FORMATTED') THEN
3817 WRITE(unit,'(3(A23,1X))')dateiso
3818ELSE
3819 WRITE(unit)dateiso
3820ENDIF
3821DEALLOCATE(dateiso)
3822
3823END SUBROUTINE timedelta_vect_write_unit
3824
3825
3826ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
3827TYPE(timedelta),INTENT(in) :: this
3828LOGICAL :: res
3829
3830res = .not. this == timedelta_miss
3831
3832end FUNCTION c_e_timedelta
3833
3834
3835elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
3836
3837!!omstart JELADATA5
3838! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3839! 1 IMINUTI)
3840!
3841! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
3842!
3843! variabili integer*4
3844! IN:
3845! IDAY,IMONTH,IYEAR, I*4
3846! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3847!
3848! OUT:
3849! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3850!!OMEND
3851
3852INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
3853INTEGER,intent(out) :: iminuti
3854
3855iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
3856
3857END SUBROUTINE jeladata5
3858
3859
3860elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
3861INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
3862INTEGER(KIND=int_ll),intent(out) :: imillisec
3863
3864imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
3865 + imsec
3866
3867END SUBROUTINE jeladata5_1
3868
3869
3870
3871elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
3872
3873!!omstart JELADATA6
3874! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3875! 1 IMINUTI)
3876!
3877! Calcola la data e l'ora corrispondente a IMINUTI dopo il
3878! 1/1/1
3879!
3880! variabili integer*4
3881! IN:
3882! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3883!
3884! OUT:
3885! IDAY,IMONTH,IYEAR, I*4
3886! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3887!!OMEND
3888
3889
3890INTEGER,intent(in) :: iminuti
3891INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
3892
3893INTEGER ::igiorno
3894
3895imin = mod(iminuti,60)
3896ihour = mod(iminuti,1440)/60
3897igiorno = iminuti/1440
3899CALL ndyin(igiorno,iday,imonth,iyear)
3900
3901END SUBROUTINE jeladata6
3902
3903
3904elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
3905INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
3906INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
3907
3908INTEGER :: igiorno
3909
3911!imin = MOD(imillisec/60000_int_ll, 60)
3912!ihour = MOD(imillisec/3600000_int_ll, 24)
3913imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
3914ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
3915igiorno = int(imillisec/86400000_int_ll)
3916!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
3917CALL ndyin(igiorno,iday,imonth,iyear)
3918
3919END SUBROUTINE jeladata6_1
3920
3921
3922elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
3923
3924!!OMSTART NDYIN
3925! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
3926! restituisce la data fornendo in input il numero di
3927! giorni dal 1/1/1
3928!
3929!!omend
3930
3931INTEGER,intent(in) :: ndays
3932INTEGER,intent(out) :: igg, imm, iaa
3933integer :: n,lndays
3934
3935lndays=ndays
3936
3937n = lndays/d400
3938lndays = lndays - n*d400
3939iaa = year0 + n*400
3940n = min(lndays/d100, 3)
3941lndays = lndays - n*d100
3942iaa = iaa + n*100
3943n = lndays/d4
3944lndays = lndays - n*d4
3945iaa = iaa + n*4
3946n = min(lndays/d1, 3)
3947lndays = lndays - n*d1
3948iaa = iaa + n
3949n = bisextilis(iaa)
3950DO imm = 1, 12
3951 IF (lndays < ianno(imm+1,n)) EXIT
3952ENDDO
3953igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
3954
3955END SUBROUTINE ndyin
3956
3957
3958integer elemental FUNCTION ndays(igg,imm,iaa)
3959
3960!!OMSTART NDAYS
3961! FUNCTION NDAYS(IGG,IMM,IAA)
3962! restituisce il numero di giorni dal 1/1/1
3963! fornendo in input la data
3964!
3965!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3966! nota bene E' SICURO !!!
3967! un anno e' bisestile se divisibile per 4
3968! un anno rimane bisestile se divisibile per 400
3969! un anno NON e' bisestile se divisibile per 100
3970!
3971!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3972!
3973!!omend
3974
3975INTEGER, intent(in) :: igg, imm, iaa
3976
3977INTEGER :: lmonth, lyear
3978
3979! Limito il mese a [1-12] e correggo l'anno coerentemente
3980lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
3981lyear = iaa + (imm - lmonth)/12
3982ndays = igg+ianno(lmonth, bisextilis(lyear))
3983ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
3984 (lyear-year0)/400
3985
3986END FUNCTION ndays
3987
3988
3989elemental FUNCTION bisextilis(annum)
3990INTEGER,INTENT(in) :: annum
3991INTEGER :: bisextilis
3992
3994 bisextilis = 2
3995ELSE
3996 bisextilis = 1
3997ENDIF
3998END FUNCTION bisextilis
3999
4000
4001ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4002TYPE(cyclicdatetime),INTENT(IN) :: this, that
4003LOGICAL :: res
4004
4005res = .true.
4006if (this%minute /= that%minute) res=.false.
4007if (this%hour /= that%hour) res=.false.
4008if (this%day /= that%day) res=.false.
4009if (this%month /= that%month) res=.false.
4010if (this%tendaysp /= that%tendaysp) res=.false.
4011
4012END FUNCTION cyclicdatetime_eq
4013
4014
4015ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4016TYPE(cyclicdatetime),INTENT(IN) :: this
4017TYPE(datetime),INTENT(IN) :: that
4018LOGICAL :: res
4019
4020integer :: minute,hour,day,month
4021
4023
4024res = .true.
4030 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4031end if
4032
4033END FUNCTION cyclicdatetime_datetime_eq
4034
4035
4036ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4037TYPE(datetime),INTENT(IN) :: this
4038TYPE(cyclicdatetime),INTENT(IN) :: that
4039LOGICAL :: res
4040
4041integer :: minute,hour,day,month
4042
4044
4045res = .true.
4050
4052 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4053end if
4054
4055
4056END FUNCTION datetime_cyclicdatetime_eq
4057
4058ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4059TYPE(cyclicdatetime),INTENT(in) :: this
4060LOGICAL :: res
4061
4062res = .not. this == cyclicdatetime_miss
4063
4064end FUNCTION c_e_cyclicdatetime
4065
4066
4069FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4070INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4071INTEGER,INTENT(IN),OPTIONAL :: month
4072INTEGER,INTENT(IN),OPTIONAL :: day
4073INTEGER,INTENT(IN),OPTIONAL :: hour
4074INTEGER,INTENT(IN),OPTIONAL :: minute
4075CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4076
4077integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4078
4079
4080TYPE(cyclicdatetime) :: this
4081
4082if (present(chardate)) then
4083
4084 ltendaysp=imiss
4085 lmonth=imiss
4086 lday=imiss
4087 lhour=imiss
4088 lminute=imiss
4089
4091 ! TMMGGhhmm
4092 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4093 !print*,chardate(1:1),ios,ltendaysp
4094 if (ios /= 0)ltendaysp=imiss
4095
4096 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4097 !print*,chardate(2:3),ios,lmonth
4098 if (ios /= 0)lmonth=imiss
4099
4100 read(chardate(4:5),'(i2)',iostat=ios)lday
4101 !print*,chardate(4:5),ios,lday
4102 if (ios /= 0)lday=imiss
4103
4104 read(chardate(6:7),'(i2)',iostat=ios)lhour
4105 !print*,chardate(6:7),ios,lhour
4106 if (ios /= 0)lhour=imiss
4107
4108 read(chardate(8:9),'(i2)',iostat=ios)lminute
4109 !print*,chardate(8:9),ios,lminute
4110 if (ios /= 0)lminute=imiss
4111 end if
4112
4113 this%tendaysp=ltendaysp
4114 this%month=lmonth
4115 this%day=lday
4116 this%hour=lhour
4117 this%minute=lminute
4118else
4119 this%tendaysp=optio_l(tendaysp)
4120 this%month=optio_l(month)
4121 this%day=optio_l(day)
4122 this%hour=optio_l(hour)
4123 this%minute=optio_l(minute)
4124end if
4125
4126END FUNCTION cyclicdatetime_new
4127
4130elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4131TYPE(cyclicdatetime),INTENT(IN) :: this
4132
4133CHARACTER(len=80) :: char
4134
4137
4138END FUNCTION cyclicdatetime_to_char
4139
4140
4153FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4154TYPE(cyclicdatetime),INTENT(IN) :: this
4155
4156TYPE(datetime) :: dtc
4157
4158integer :: year,month,day,hour
4159
4160dtc = datetime_miss
4161
4162! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4164 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4165 return
4166end if
4167
4168! minute present -> not good for conventional datetime
4170! day, month and tendaysp present -> no good
4172
4174 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4176 day=(this%tendaysp-1)*10+1
4177 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4179 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4181 ! only day present -> no good
4182 return
4183end if
4184
4187 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4188end if
4189
4190
4191END FUNCTION cyclicdatetime_to_conventional
4192
4193
4194
4195FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4196TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4197
4198CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4199
4200char=cyclicdatetime_to_char(in)
4201
4202END FUNCTION trim_cyclicdatetime_to_char
4203
4204
4205
4206SUBROUTINE display_cyclicdatetime(this)
4207TYPE(cyclicdatetime),INTENT(in) :: this
4208
4210
4211end subroutine display_cyclicdatetime
4212
4213
4214#include "array_utilities_inc.F90"
4215
4217
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 |