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