libsim Versione 7.1.11
|
◆ timedelta_vect_read_unit()
This method reads from a Fortran file unit the contents of the object this. The record to be read must have been written with the ::write_unit method. The method works both on formatted and unformatted files.
Definizione alla linea 2018 del file datetime_class.F90. 2019! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2020! authors:
2021! Davide Cesari <dcesari@arpa.emr.it>
2022! Paolo Patruno <ppatruno@arpa.emr.it>
2023
2024! This program is free software; you can redistribute it and/or
2025! modify it under the terms of the GNU General Public License as
2026! published by the Free Software Foundation; either version 2 of
2027! the License, or (at your option) any later version.
2028
2029! This program is distributed in the hope that it will be useful,
2030! but WITHOUT ANY WARRANTY; without even the implied warranty of
2031! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2032! GNU General Public License for more details.
2033
2034! You should have received a copy of the GNU General Public License
2035! along with this program. If not, see <http://www.gnu.org/licenses/>.
2036#include "config.h"
2037
2058IMPLICIT NONE
2059
2060INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2061
2064 PRIVATE
2065 INTEGER(KIND=int_ll) :: iminuti
2067
2076 PRIVATE
2077 INTEGER(KIND=int_ll) :: iminuti
2078 INTEGER :: month
2080
2081
2086 PRIVATE
2087 INTEGER :: minute
2088 INTEGER :: hour
2089 INTEGER :: day
2090 INTEGER :: tendaysp
2091 INTEGER :: month
2093
2094
2102INTEGER, PARAMETER :: datetime_utc=1
2104INTEGER, PARAMETER :: datetime_local=2
2114TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2115
2116
2117INTEGER(kind=dateint), PARAMETER :: &
2118 sec_in_day=86400, &
2119 sec_in_hour=3600, &
2120 sec_in_min=60, &
2121 min_in_day=1440, &
2122 min_in_hour=60, &
2123 hour_in_day=24
2124
2125INTEGER,PARAMETER :: &
2126 year0=1, & ! anno di origine per iminuti
2127 d1=365, & ! giorni/1 anno nel calendario gregoriano
2128 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2129 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2130 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2131 ianno(13,2)=reshape((/ &
2132 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2133 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2134
2135INTEGER(KIND=int_ll),PARAMETER :: &
2136 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2137
2142 MODULE PROCEDURE datetime_init, timedelta_init
2143END INTERFACE
2144
2148 MODULE PROCEDURE datetime_delete, timedelta_delete
2149END INTERFACE
2150
2153 MODULE PROCEDURE datetime_getval, timedelta_getval
2154END INTERFACE
2155
2158 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2159END INTERFACE
2160
2161
2180 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2181END INTERFACE
2182
2188INTERFACE OPERATOR (==)
2189 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2190 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2191END INTERFACE
2192
2198INTERFACE OPERATOR (/=)
2199 MODULE PROCEDURE datetime_ne, timedelta_ne
2200END INTERFACE
2201
2209INTERFACE OPERATOR (>)
2210 MODULE PROCEDURE datetime_gt, timedelta_gt
2211END INTERFACE
2212
2220INTERFACE OPERATOR (<)
2221 MODULE PROCEDURE datetime_lt, timedelta_lt
2222END INTERFACE
2223
2231INTERFACE OPERATOR (>=)
2232 MODULE PROCEDURE datetime_ge, timedelta_ge
2233END INTERFACE
2234
2242INTERFACE OPERATOR (<=)
2243 MODULE PROCEDURE datetime_le, timedelta_le
2244END INTERFACE
2245
2252INTERFACE OPERATOR (+)
2253 MODULE PROCEDURE datetime_add, timedelta_add
2254END INTERFACE
2255
2263INTERFACE OPERATOR (-)
2264 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
2265END INTERFACE
2266
2272INTERFACE OPERATOR (*)
2273 MODULE PROCEDURE timedelta_mult, timedelta_tlum
2274END INTERFACE
2275
2282INTERFACE OPERATOR (/)
2283 MODULE PROCEDURE timedelta_divint, timedelta_divtd
2284END INTERFACE
2285
2297 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2298END INTERFACE
2299
2303 MODULE PROCEDURE timedelta_abs
2304END INTERFACE
2305
2309 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2310 timedelta_read_unit, timedelta_vect_read_unit
2311END INTERFACE
2312
2316 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2317 timedelta_write_unit, timedelta_vect_write_unit
2318END INTERFACE
2319
2322 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2323END INTERFACE
2324
2327 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
2328END INTERFACE
2329
2330#undef VOL7D_POLY_TYPE
2331#undef VOL7D_POLY_TYPES
2332#undef ENABLE_SORT
2333#define VOL7D_POLY_TYPE TYPE(datetime)
2334#define VOL7D_POLY_TYPES _datetime
2335#define ENABLE_SORT
2336#include "array_utilities_pre.F90"
2337
2338
2339#define ARRAYOF_ORIGTYPE TYPE(datetime)
2340#define ARRAYOF_TYPE arrayof_datetime
2341#define ARRAYOF_ORIGEQ 1
2342#include "arrayof_pre.F90"
2343! from arrayof
2344
2345PRIVATE
2346
2348 datetime_min, datetime_max, &
2351 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2352 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2354 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2355 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2357 count_distinct, pack_distinct, &
2358 count_distinct_sorted, pack_distinct_sorted, &
2359 count_and_pack_distinct, &
2361 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
2363PUBLIC insert_unique, append_unique
2364PUBLIC cyclicdatetime_to_conventional
2365
2366CONTAINS
2367
2368
2369! ==============
2370! == datetime ==
2371! ==============
2372
2379ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
2380 unixtime, isodate, simpledate) RESULT(this)
2381INTEGER,INTENT(IN),OPTIONAL :: year
2382INTEGER,INTENT(IN),OPTIONAL :: month
2383INTEGER,INTENT(IN),OPTIONAL :: day
2384INTEGER,INTENT(IN),OPTIONAL :: hour
2385INTEGER,INTENT(IN),OPTIONAL :: minute
2386INTEGER,INTENT(IN),OPTIONAL :: msec
2387INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2388CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2389CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2390
2391TYPE(datetime) :: this
2392INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2393CHARACTER(len=23) :: datebuf
2394
2395IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
2396 lyear = year
2397 IF (PRESENT(month)) THEN
2398 lmonth = month
2399 ELSE
2400 lmonth = 1
2401 ENDIF
2402 IF (PRESENT(day)) THEN
2403 lday = day
2404 ELSE
2405 lday = 1
2406 ENDIF
2407 IF (PRESENT(hour)) THEN
2408 lhour = hour
2409 ELSE
2410 lhour = 0
2411 ENDIF
2412 IF (PRESENT(minute)) THEN
2413 lminute = minute
2414 ELSE
2415 lminute = 0
2416 ENDIF
2417 IF (PRESENT(msec)) THEN
2418 lmsec = msec
2419 ELSE
2420 lmsec = 0
2421 ENDIF
2422
2425 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2426 else
2427 this=datetime_miss
2428 end if
2429
2430ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
2432 this%iminuti = (unixtime + unsec)*1000
2433 else
2434 this=datetime_miss
2435 end if
2436
2437ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
2438
2440 datebuf(1:23) = '0001-01-01 00:00:00.000'
2441 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
2442 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
2443 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2444 lmsec = lmsec + lsec*1000
2445 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2446 RETURN
2447
2448100 CONTINUE ! condizione di errore in isodate
2450 RETURN
2451 ELSE
2452 this = datetime_miss
2453 ENDIF
2454
2455ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
2457 datebuf(1:17) = '00010101000000000'
2458 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
2459 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
2460 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2461 lmsec = lmsec + lsec*1000
2462 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2463 RETURN
2464
2465120 CONTINUE ! condizione di errore in simpledate
2467 RETURN
2468 ELSE
2469 this = datetime_miss
2470 ENDIF
2471
2472ELSE
2473 this = datetime_miss
2474ENDIF
2475
2476END FUNCTION datetime_new
2477
2478
2480FUNCTION datetime_new_now(now) RESULT(this)
2481INTEGER,INTENT(IN) :: now
2482TYPE(datetime) :: this
2483
2484INTEGER :: dt(8)
2485
2487 CALL date_and_time(values=dt)
2488 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
2490 msec=dt(7)*1000+dt(8))
2491ELSE
2492 this = datetime_miss
2493ENDIF
2494
2495END FUNCTION datetime_new_now
2496
2497
2504SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
2505 unixtime, isodate, simpledate, now)
2506TYPE(datetime),INTENT(INOUT) :: this
2507INTEGER,INTENT(IN),OPTIONAL :: year
2508INTEGER,INTENT(IN),OPTIONAL :: month
2509INTEGER,INTENT(IN),OPTIONAL :: day
2510INTEGER,INTENT(IN),OPTIONAL :: hour
2511INTEGER,INTENT(IN),OPTIONAL :: minute
2512INTEGER,INTENT(IN),OPTIONAL :: msec
2513INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2514CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2515CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2516INTEGER,INTENT(IN),OPTIONAL :: now
2517
2518IF (PRESENT(now)) THEN
2519 this = datetime_new_now(now)
2520ELSE
2521 this = datetime_new(year, month, day, hour, minute, msec, &
2522 unixtime, isodate, simpledate)
2523ENDIF
2524
2525END SUBROUTINE datetime_init
2526
2527
2528ELEMENTAL SUBROUTINE datetime_delete(this)
2529TYPE(datetime),INTENT(INOUT) :: this
2530
2531this%iminuti = illmiss
2532
2533END SUBROUTINE datetime_delete
2534
2535
2540PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
2541 unixtime, isodate, simpledate, oraclesimdate)
2542TYPE(datetime),INTENT(IN) :: this
2543INTEGER,INTENT(OUT),OPTIONAL :: year
2544INTEGER,INTENT(OUT),OPTIONAL :: month
2545INTEGER,INTENT(OUT),OPTIONAL :: day
2546INTEGER,INTENT(OUT),OPTIONAL :: hour
2547INTEGER,INTENT(OUT),OPTIONAL :: minute
2548INTEGER,INTENT(OUT),OPTIONAL :: msec
2549INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
2550CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
2551CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
2552CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
2553
2554INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2555CHARACTER(len=23) :: datebuf
2556
2557IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
2558 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
2559 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
2560
2561 IF (this == datetime_miss) THEN
2562
2563 IF (PRESENT(msec)) THEN
2564 msec = imiss
2565 ENDIF
2566 IF (PRESENT(minute)) THEN
2567 minute = imiss
2568 ENDIF
2569 IF (PRESENT(hour)) THEN
2570 hour = imiss
2571 ENDIF
2572 IF (PRESENT(day)) THEN
2573 day = imiss
2574 ENDIF
2575 IF (PRESENT(month)) THEN
2576 month = imiss
2577 ENDIF
2578 IF (PRESENT(year)) THEN
2579 year = imiss
2580 ENDIF
2581 IF (PRESENT(isodate)) THEN
2582 isodate = cmiss
2583 ENDIF
2584 IF (PRESENT(simpledate)) THEN
2585 simpledate = cmiss
2586 ENDIF
2587 IF (PRESENT(oraclesimdate)) THEN
2588!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2589!!$ 'obsoleto, usare piuttosto simpledate')
2590 oraclesimdate=cmiss
2591 ENDIF
2592 IF (PRESENT(unixtime)) THEN
2593 unixtime = illmiss
2594 ENDIF
2595
2596 ELSE
2597
2598 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2599 IF (PRESENT(msec)) THEN
2600 msec = lmsec
2601 ENDIF
2602 IF (PRESENT(minute)) THEN
2603 minute = lminute
2604 ENDIF
2605 IF (PRESENT(hour)) THEN
2606 hour = lhour
2607 ENDIF
2608 IF (PRESENT(day)) THEN
2609 day = lday
2610 ENDIF
2611 IF (PRESENT(month)) THEN
2612 month = lmonth
2613 ENDIF
2614 IF (PRESENT(year)) THEN
2615 year = lyear
2616 ENDIF
2617 IF (PRESENT(isodate)) THEN
2618 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
2619 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
2621 isodate = datebuf(1:min(len(isodate),23))
2622 ENDIF
2623 IF (PRESENT(simpledate)) THEN
2624 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
2625 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
2626 simpledate = datebuf(1:min(len(simpledate),17))
2627 ENDIF
2628 IF (PRESENT(oraclesimdate)) THEN
2629!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2630!!$ 'obsoleto, usare piuttosto simpledate')
2631 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
2632 ENDIF
2633 IF (PRESENT(unixtime)) THEN
2634 unixtime = this%iminuti/1000_int_ll-unsec
2635 ENDIF
2636
2637 ENDIF
2638ENDIF
2639
2640END SUBROUTINE datetime_getval
2641
2642
2645elemental FUNCTION datetime_to_char(this) RESULT(char)
2646TYPE(datetime),INTENT(IN) :: this
2647
2648CHARACTER(len=23) :: char
2649
2651
2652END FUNCTION datetime_to_char
2653
2654
2655FUNCTION trim_datetime_to_char(in) RESULT(char)
2656TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
2657
2658CHARACTER(len=len_trim(datetime_to_char(in))) :: char
2659
2660char=datetime_to_char(in)
2661
2662END FUNCTION trim_datetime_to_char
2663
2664
2665
2666SUBROUTINE display_datetime(this)
2667TYPE(datetime),INTENT(in) :: this
2668
2670
2671end subroutine display_datetime
2672
2673
2674
2675SUBROUTINE display_timedelta(this)
2676TYPE(timedelta),INTENT(in) :: this
2677
2679
2680end subroutine display_timedelta
2681
2682
2683
2684ELEMENTAL FUNCTION c_e_datetime(this) result (res)
2685TYPE(datetime),INTENT(in) :: this
2686LOGICAL :: res
2687
2688res = .not. this == datetime_miss
2689
2690end FUNCTION c_e_datetime
2691
2692
2693ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
2694TYPE(datetime),INTENT(IN) :: this, that
2695LOGICAL :: res
2696
2697res = this%iminuti == that%iminuti
2698
2699END FUNCTION datetime_eq
2700
2701
2702ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
2703TYPE(datetime),INTENT(IN) :: this, that
2704LOGICAL :: res
2705
2706res = .NOT.(this == that)
2707
2708END FUNCTION datetime_ne
2709
2710
2711ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
2712TYPE(datetime),INTENT(IN) :: this, that
2713LOGICAL :: res
2714
2715res = this%iminuti > that%iminuti
2716
2717END FUNCTION datetime_gt
2718
2719
2720ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
2721TYPE(datetime),INTENT(IN) :: this, that
2722LOGICAL :: res
2723
2724res = this%iminuti < that%iminuti
2725
2726END FUNCTION datetime_lt
2727
2728
2729ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
2730TYPE(datetime),INTENT(IN) :: this, that
2731LOGICAL :: res
2732
2733IF (this == that) THEN
2734 res = .true.
2735ELSE IF (this > that) THEN
2736 res = .true.
2737ELSE
2738 res = .false.
2739ENDIF
2740
2741END FUNCTION datetime_ge
2742
2743
2744ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
2745TYPE(datetime),INTENT(IN) :: this, that
2746LOGICAL :: res
2747
2748IF (this == that) THEN
2749 res = .true.
2750ELSE IF (this < that) THEN
2751 res = .true.
2752ELSE
2753 res = .false.
2754ENDIF
2755
2756END FUNCTION datetime_le
2757
2758
2759FUNCTION datetime_add(this, that) RESULT(res)
2760TYPE(datetime),INTENT(IN) :: this
2761TYPE(timedelta),INTENT(IN) :: that
2762TYPE(datetime) :: res
2763
2764INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2765
2766IF (this == datetime_miss .OR. that == timedelta_miss) THEN
2767 res = datetime_miss
2768ELSE
2769 res%iminuti = this%iminuti + that%iminuti
2770 IF (that%month /= 0) THEN
2772 minute=lminute, msec=lmsec)
2774 hour=lhour, minute=lminute, msec=lmsec)
2775 ENDIF
2776ENDIF
2777
2778END FUNCTION datetime_add
2779
2780
2781ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
2782TYPE(datetime),INTENT(IN) :: this, that
2783TYPE(timedelta) :: res
2784
2785IF (this == datetime_miss .OR. that == datetime_miss) THEN
2786 res = timedelta_miss
2787ELSE
2788 res%iminuti = this%iminuti - that%iminuti
2789 res%month = 0
2790ENDIF
2791
2792END FUNCTION datetime_subdt
2793
2794
2795FUNCTION datetime_subtd(this, that) RESULT(res)
2796TYPE(datetime),INTENT(IN) :: this
2797TYPE(timedelta),INTENT(IN) :: that
2798TYPE(datetime) :: res
2799
2800INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2801
2802IF (this == datetime_miss .OR. that == timedelta_miss) THEN
2803 res = datetime_miss
2804ELSE
2805 res%iminuti = this%iminuti - that%iminuti
2806 IF (that%month /= 0) THEN
2808 minute=lminute, msec=lmsec)
2810 hour=lhour, minute=lminute, msec=lmsec)
2811 ENDIF
2812ENDIF
2813
2814END FUNCTION datetime_subtd
2815
2816
2821SUBROUTINE datetime_read_unit(this, unit)
2822TYPE(datetime),INTENT(out) :: this
2823INTEGER, INTENT(in) :: unit
2824CALL datetime_vect_read_unit((/this/), unit)
2825
2826END SUBROUTINE datetime_read_unit
2827
2828
2833SUBROUTINE datetime_vect_read_unit(this, unit)
2834TYPE(datetime) :: this(:)
2835INTEGER, INTENT(in) :: unit
2836
2837CHARACTER(len=40) :: form
2838CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
2839INTEGER :: i
2840
2841ALLOCATE(dateiso(SIZE(this)))
2842INQUIRE(unit, form=form)
2843IF (form == 'FORMATTED') THEN
2844 READ(unit,'(A23,1X)')dateiso
2845ELSE
2846 READ(unit)dateiso
2847ENDIF
2848DO i = 1, SIZE(dateiso)
2850ENDDO
2851DEALLOCATE(dateiso)
2852
2853END SUBROUTINE datetime_vect_read_unit
2854
2855
2860SUBROUTINE datetime_write_unit(this, unit)
2861TYPE(datetime),INTENT(in) :: this
2862INTEGER, INTENT(in) :: unit
2863
2864CALL datetime_vect_write_unit((/this/), unit)
2865
2866END SUBROUTINE datetime_write_unit
2867
2868
2873SUBROUTINE datetime_vect_write_unit(this, unit)
2874TYPE(datetime),INTENT(in) :: this(:)
2875INTEGER, INTENT(in) :: unit
2876
2877CHARACTER(len=40) :: form
2878CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
2879INTEGER :: i
2880
2881ALLOCATE(dateiso(SIZE(this)))
2882DO i = 1, SIZE(dateiso)
2884ENDDO
2885INQUIRE(unit, form=form)
2886IF (form == 'FORMATTED') THEN
2887 WRITE(unit,'(A23,1X)')dateiso
2888ELSE
2889 WRITE(unit)dateiso
2890ENDIF
2891DEALLOCATE(dateiso)
2892
2893END SUBROUTINE datetime_vect_write_unit
2894
2895
2896#include "arrayof_post.F90"
2897
2898
2899! ===============
2900! == timedelta ==
2901! ===============
2908FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
2909 isodate, simpledate, oraclesimdate) RESULT (this)
2910INTEGER,INTENT(IN),OPTIONAL :: year
2911INTEGER,INTENT(IN),OPTIONAL :: month
2912INTEGER,INTENT(IN),OPTIONAL :: day
2913INTEGER,INTENT(IN),OPTIONAL :: hour
2914INTEGER,INTENT(IN),OPTIONAL :: minute
2915INTEGER,INTENT(IN),OPTIONAL :: sec
2916INTEGER,INTENT(IN),OPTIONAL :: msec
2917CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2918CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2919CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
2920
2921TYPE(timedelta) :: this
2922
2923CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
2924 isodate, simpledate, oraclesimdate)
2925
2926END FUNCTION timedelta_new
2927
2928
2933SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
2934 isodate, simpledate, oraclesimdate)
2935TYPE(timedelta),INTENT(INOUT) :: this
2936INTEGER,INTENT(IN),OPTIONAL :: year
2937INTEGER,INTENT(IN),OPTIONAL :: month
2938INTEGER,INTENT(IN),OPTIONAL :: day
2939INTEGER,INTENT(IN),OPTIONAL :: hour
2940INTEGER,INTENT(IN),OPTIONAL :: minute
2941INTEGER,INTENT(IN),OPTIONAL :: sec
2942INTEGER,INTENT(IN),OPTIONAL :: msec
2943CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2944CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2945CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
2946
2947INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
2948CHARACTER(len=23) :: datebuf
2949
2950this%month = 0
2951
2952IF (PRESENT(isodate)) THEN
2953 datebuf(1:23) = '0000000000 00:00:00.000'
2954 l = len_trim(isodate)
2955! IF (l > 0) THEN
2957 IF (n > 0) THEN
2958 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
2959 datebuf(12-n:12-n+l-1) = isodate(:l)
2960 ELSE
2961 datebuf(1:l) = isodate(1:l)
2962 ENDIF
2963! ENDIF
2964
2965! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
2966 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
2967 h, m, s, ms
2968 this%month = lmonth + 12*lyear
2969 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
2970 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
2971 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
2972 RETURN
2973
2974200 CONTINUE ! condizione di errore in isodate
2976 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
2977 CALL raise_error()
2978
2979ELSE IF (PRESENT(simpledate)) THEN
2980 datebuf(1:17) = '00000000000000000'
2981 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
2982 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
2983 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
2984 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
2985 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
2986
2987220 CONTINUE ! condizione di errore in simpledate
2989 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
2990 CALL raise_error()
2991 RETURN
2992
2993ELSE IF (PRESENT(oraclesimdate)) THEN
2994 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
2995 'obsoleto, usare piuttosto simpledate')
2996 READ(oraclesimdate, '(I8,2I2)')d, h, m
2997 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
2998 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
2999
3000ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3001 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3002 .and. .not. present(msec) .and. .not. present(isodate) &
3003 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3004
3005 this=timedelta_miss
3006
3007ELSE
3008 this%iminuti = 0
3009 IF (PRESENT(year)) THEN
3011 this%month = this%month + year*12
3012 else
3013 this=timedelta_miss
3014 return
3015 end if
3016 ENDIF
3017 IF (PRESENT(month)) THEN
3019 this%month = this%month + month
3020 else
3021 this=timedelta_miss
3022 return
3023 end if
3024 ENDIF
3025 IF (PRESENT(day)) THEN
3027 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3028 else
3029 this=timedelta_miss
3030 return
3031 end if
3032 ENDIF
3033 IF (PRESENT(hour)) THEN
3035 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3036 else
3037 this=timedelta_miss
3038 return
3039 end if
3040 ENDIF
3041 IF (PRESENT(minute)) THEN
3043 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3044 else
3045 this=timedelta_miss
3046 return
3047 end if
3048 ENDIF
3049 IF (PRESENT(sec)) THEN
3051 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3052 else
3053 this=timedelta_miss
3054 return
3055 end if
3056 ENDIF
3057 IF (PRESENT(msec)) THEN
3059 this%iminuti = this%iminuti + msec
3060 else
3061 this=timedelta_miss
3062 return
3063 end if
3064 ENDIF
3065ENDIF
3066
3067
3068
3069
3070END SUBROUTINE timedelta_init
3071
3072
3073SUBROUTINE timedelta_delete(this)
3074TYPE(timedelta),INTENT(INOUT) :: this
3075
3076this%iminuti = imiss
3077this%month = 0
3078
3079END SUBROUTINE timedelta_delete
3080
3081
3086PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3087 day, hour, minute, sec, msec, &
3088 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3089TYPE(timedelta),INTENT(IN) :: this
3090INTEGER,INTENT(OUT),OPTIONAL :: year
3091INTEGER,INTENT(OUT),OPTIONAL :: month
3092INTEGER,INTENT(OUT),OPTIONAL :: amonth
3093INTEGER,INTENT(OUT),OPTIONAL :: day
3094INTEGER,INTENT(OUT),OPTIONAL :: hour
3095INTEGER,INTENT(OUT),OPTIONAL :: minute
3096INTEGER,INTENT(OUT),OPTIONAL :: sec
3097INTEGER,INTENT(OUT),OPTIONAL :: msec
3098INTEGER,INTENT(OUT),OPTIONAL :: ahour
3099INTEGER,INTENT(OUT),OPTIONAL :: aminute
3100INTEGER,INTENT(OUT),OPTIONAL :: asec
3101INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
3102CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3103CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3104CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3105
3106CHARACTER(len=23) :: datebuf
3107
3108IF (PRESENT(amsec)) THEN
3109 amsec = this%iminuti
3110ENDIF
3111IF (PRESENT(asec)) THEN
3112 asec = int(this%iminuti/1000_int_ll)
3113ENDIF
3114IF (PRESENT(aminute)) THEN
3115 aminute = int(this%iminuti/60000_int_ll)
3116ENDIF
3117IF (PRESENT(ahour)) THEN
3118 ahour = int(this%iminuti/3600000_int_ll)
3119ENDIF
3120IF (PRESENT(msec)) THEN
3121 msec = int(mod(this%iminuti, 1000_int_ll))
3122ENDIF
3123IF (PRESENT(sec)) THEN
3124 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3125ENDIF
3126IF (PRESENT(minute)) THEN
3127 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3128ENDIF
3129IF (PRESENT(hour)) THEN
3130 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3131ENDIF
3132IF (PRESENT(day)) THEN
3133 day = int(this%iminuti/86400000_int_ll)
3134ENDIF
3135IF (PRESENT(amonth)) THEN
3136 amonth = this%month
3137ENDIF
3138IF (PRESENT(month)) THEN
3139 month = mod(this%month-1,12)+1
3140ENDIF
3141IF (PRESENT(year)) THEN
3142 year = this%month/12
3143ENDIF
3144IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3145 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3149 isodate = datebuf(1:min(len(isodate),23))
3150
3151ENDIF
3152IF (PRESENT(simpledate)) THEN
3153 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3154 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3156 mod(this%iminuti, 1000_int_ll)
3157 simpledate = datebuf(1:min(len(simpledate),17))
3158ENDIF
3159IF (PRESENT(oraclesimdate)) THEN
3160!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3161!!$ 'obsoleto, usare piuttosto simpledate')
3162 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3164ENDIF
3165
3166END SUBROUTINE timedelta_getval
3167
3168
3171elemental FUNCTION timedelta_to_char(this) RESULT(char)
3172TYPE(timedelta),INTENT(IN) :: this
3173
3174CHARACTER(len=23) :: char
3175
3177
3178END FUNCTION timedelta_to_char
3179
3180
3181FUNCTION trim_timedelta_to_char(in) RESULT(char)
3182TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3183
3184CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3185
3186char=timedelta_to_char(in)
3187
3188END FUNCTION trim_timedelta_to_char
3189
3190
3192elemental FUNCTION timedelta_getamsec(this)
3193TYPE(timedelta),INTENT(IN) :: this
3194INTEGER(kind=int_ll) :: timedelta_getamsec
3195
3196timedelta_getamsec = this%iminuti
3197
3198END FUNCTION timedelta_getamsec
3199
3200
3206FUNCTION timedelta_depop(this)
3207TYPE(timedelta),INTENT(IN) :: this
3208TYPE(timedelta) :: timedelta_depop
3209
3210TYPE(datetime) :: tmpdt
3211
3212IF (this%month == 0) THEN
3213 timedelta_depop = this
3214ELSE
3215 tmpdt = datetime_new(1970, 1, 1)
3216 timedelta_depop = (tmpdt + this) - tmpdt
3217ENDIF
3218
3219END FUNCTION timedelta_depop
3220
3221
3222elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3223TYPE(timedelta),INTENT(IN) :: this, that
3224LOGICAL :: res
3225
3226res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3227
3228END FUNCTION timedelta_eq
3229
3230
3231ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3232TYPE(timedelta),INTENT(IN) :: this, that
3233LOGICAL :: res
3234
3235res = .NOT.(this == that)
3236
3237END FUNCTION timedelta_ne
3238
3239
3240ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
3241TYPE(timedelta),INTENT(IN) :: this, that
3242LOGICAL :: res
3243
3244res = this%iminuti > that%iminuti
3245
3246END FUNCTION timedelta_gt
3247
3248
3249ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
3250TYPE(timedelta),INTENT(IN) :: this, that
3251LOGICAL :: res
3252
3253res = this%iminuti < that%iminuti
3254
3255END FUNCTION timedelta_lt
3256
3257
3258ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
3259TYPE(timedelta),INTENT(IN) :: this, that
3260LOGICAL :: res
3261
3262IF (this == that) THEN
3263 res = .true.
3264ELSE IF (this > that) THEN
3265 res = .true.
3266ELSE
3267 res = .false.
3268ENDIF
3269
3270END FUNCTION timedelta_ge
3271
3272
3273elemental FUNCTION timedelta_le(this, that) RESULT(res)
3274TYPE(timedelta),INTENT(IN) :: this, that
3275LOGICAL :: res
3276
3277IF (this == that) THEN
3278 res = .true.
3279ELSE IF (this < that) THEN
3280 res = .true.
3281ELSE
3282 res = .false.
3283ENDIF
3284
3285END FUNCTION timedelta_le
3286
3287
3288ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
3289TYPE(timedelta),INTENT(IN) :: this, that
3290TYPE(timedelta) :: res
3291
3292res%iminuti = this%iminuti + that%iminuti
3293res%month = this%month + that%month
3294
3295END FUNCTION timedelta_add
3296
3297
3298ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
3299TYPE(timedelta),INTENT(IN) :: this, that
3300TYPE(timedelta) :: res
3301
3302res%iminuti = this%iminuti - that%iminuti
3303res%month = this%month - that%month
3304
3305END FUNCTION timedelta_sub
3306
3307
3308ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
3309TYPE(timedelta),INTENT(IN) :: this
3310INTEGER,INTENT(IN) :: n
3311TYPE(timedelta) :: res
3312
3313res%iminuti = this%iminuti*n
3314res%month = this%month*n
3315
3316END FUNCTION timedelta_mult
3317
3318
3319ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
3320INTEGER,INTENT(IN) :: n
3321TYPE(timedelta),INTENT(IN) :: this
3322TYPE(timedelta) :: res
3323
3324res%iminuti = this%iminuti*n
3325res%month = this%month*n
3326
3327END FUNCTION timedelta_tlum
3328
3329
3330ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
3331TYPE(timedelta),INTENT(IN) :: this
3332INTEGER,INTENT(IN) :: n
3333TYPE(timedelta) :: res
3334
3335res%iminuti = this%iminuti/n
3336res%month = this%month/n
3337
3338END FUNCTION timedelta_divint
3339
3340
3341ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
3342TYPE(timedelta),INTENT(IN) :: this, that
3343INTEGER :: res
3344
3345res = int(this%iminuti/that%iminuti)
3346
3347END FUNCTION timedelta_divtd
3348
3349
3350elemental FUNCTION timedelta_mod(this, that) RESULT(res)
3351TYPE(timedelta),INTENT(IN) :: this, that
3352TYPE(timedelta) :: res
3353
3354res%iminuti = mod(this%iminuti, that%iminuti)
3355res%month = 0
3356
3357END FUNCTION timedelta_mod
3358
3359
3360ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
3361TYPE(datetime),INTENT(IN) :: this
3362TYPE(timedelta),INTENT(IN) :: that
3363TYPE(timedelta) :: res
3364
3365IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
3366 res = timedelta_0
3367ELSE
3368 res%iminuti = mod(this%iminuti, that%iminuti)
3369 res%month = 0
3370ENDIF
3371
3372END FUNCTION datetime_timedelta_mod
3373
3374
3375ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
3376TYPE(timedelta),INTENT(IN) :: this
3377TYPE(timedelta) :: res
3378
3379res%iminuti = abs(this%iminuti)
3380res%month = abs(this%month)
3381
3382END FUNCTION timedelta_abs
3383
3384
3389SUBROUTINE timedelta_read_unit(this, unit)
3390TYPE(timedelta),INTENT(out) :: this
3391INTEGER, INTENT(in) :: unit
3392
3393CALL timedelta_vect_read_unit((/this/), unit)
3394
3395END SUBROUTINE timedelta_read_unit
3396
3397
3402SUBROUTINE timedelta_vect_read_unit(this, unit)
3403TYPE(timedelta) :: this(:)
3404INTEGER, INTENT(in) :: unit
3405
3406CHARACTER(len=40) :: form
3407CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3408INTEGER :: i
3409
3410ALLOCATE(dateiso(SIZE(this)))
3411INQUIRE(unit, form=form)
3412IF (form == 'FORMATTED') THEN
3413 READ(unit,'(3(A23,1X))')dateiso
3414ELSE
3415 READ(unit)dateiso
3416ENDIF
3417DO i = 1, SIZE(dateiso)
3419ENDDO
3420DEALLOCATE(dateiso)
3421
3422END SUBROUTINE timedelta_vect_read_unit
3423
3424
3429SUBROUTINE timedelta_write_unit(this, unit)
3430TYPE(timedelta),INTENT(in) :: this
3431INTEGER, INTENT(in) :: unit
3432
3433CALL timedelta_vect_write_unit((/this/), unit)
3434
3435END SUBROUTINE timedelta_write_unit
3436
3437
3442SUBROUTINE timedelta_vect_write_unit(this, unit)
3443TYPE(timedelta),INTENT(in) :: this(:)
3444INTEGER, INTENT(in) :: unit
3445
3446CHARACTER(len=40) :: form
3447CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3448INTEGER :: i
3449
3450ALLOCATE(dateiso(SIZE(this)))
3451DO i = 1, SIZE(dateiso)
3453ENDDO
3454INQUIRE(unit, form=form)
3455IF (form == 'FORMATTED') THEN
3456 WRITE(unit,'(3(A23,1X))')dateiso
3457ELSE
3458 WRITE(unit)dateiso
3459ENDIF
3460DEALLOCATE(dateiso)
3461
3462END SUBROUTINE timedelta_vect_write_unit
3463
3464
3465ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
3466TYPE(timedelta),INTENT(in) :: this
3467LOGICAL :: res
3468
3469res = .not. this == timedelta_miss
3470
3471end FUNCTION c_e_timedelta
3472
3473
3474elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
3475
3476!!omstart JELADATA5
3477! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3478! 1 IMINUTI)
3479!
3480! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
3481!
3482! variabili integer*4
3483! IN:
3484! IDAY,IMONTH,IYEAR, I*4
3485! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3486!
3487! OUT:
3488! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3489!!OMEND
3490
3491INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
3492INTEGER,intent(out) :: iminuti
3493
3494iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
3495
3496END SUBROUTINE jeladata5
3497
3498
3499elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
3500INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
3501INTEGER(KIND=int_ll),intent(out) :: imillisec
3502
3503imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
3504 + imsec
3505
3506END SUBROUTINE jeladata5_1
3507
3508
3509
3510elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
3511
3512!!omstart JELADATA6
3513! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3514! 1 IMINUTI)
3515!
3516! Calcola la data e l'ora corrispondente a IMINUTI dopo il
3517! 1/1/1
3518!
3519! variabili integer*4
3520! IN:
3521! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3522!
3523! OUT:
3524! IDAY,IMONTH,IYEAR, I*4
3525! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3526!!OMEND
3527
3528
3529INTEGER,intent(in) :: iminuti
3530INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
3531
3532INTEGER ::igiorno
3533
3534imin = mod(iminuti,60)
3535ihour = mod(iminuti,1440)/60
3536igiorno = iminuti/1440
3538CALL ndyin(igiorno,iday,imonth,iyear)
3539
3540END SUBROUTINE jeladata6
3541
3542
3543elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
3544INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
3545INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
3546
3547INTEGER :: igiorno
3548
3550!imin = MOD(imillisec/60000_int_ll, 60)
3551!ihour = MOD(imillisec/3600000_int_ll, 24)
3552imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
3553ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
3554igiorno = int(imillisec/86400000_int_ll)
3555!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
3556CALL ndyin(igiorno,iday,imonth,iyear)
3557
3558END SUBROUTINE jeladata6_1
3559
3560
3561elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
3562
3563!!OMSTART NDYIN
3564! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
3565! restituisce la data fornendo in input il numero di
3566! giorni dal 1/1/1
3567!
3568!!omend
3569
3570INTEGER,intent(in) :: ndays
3571INTEGER,intent(out) :: igg, imm, iaa
3572integer :: n,lndays
3573
3574lndays=ndays
3575
3576n = lndays/d400
3577lndays = lndays - n*d400
3578iaa = year0 + n*400
3579n = min(lndays/d100, 3)
3580lndays = lndays - n*d100
3581iaa = iaa + n*100
3582n = lndays/d4
3583lndays = lndays - n*d4
3584iaa = iaa + n*4
3585n = min(lndays/d1, 3)
3586lndays = lndays - n*d1
3587iaa = iaa + n
3588n = bisextilis(iaa)
3589DO imm = 1, 12
3590 IF (lndays < ianno(imm+1,n)) EXIT
3591ENDDO
3592igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
3593
3594END SUBROUTINE ndyin
3595
3596
3597integer elemental FUNCTION ndays(igg,imm,iaa)
3598
3599!!OMSTART NDAYS
3600! FUNCTION NDAYS(IGG,IMM,IAA)
3601! restituisce il numero di giorni dal 1/1/1
3602! fornendo in input la data
3603!
3604!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3605! nota bene E' SICURO !!!
3606! un anno e' bisestile se divisibile per 4
3607! un anno rimane bisestile se divisibile per 400
3608! un anno NON e' bisestile se divisibile per 100
3609!
3610!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3611!
3612!!omend
3613
3614INTEGER, intent(in) :: igg, imm, iaa
3615
3616INTEGER :: lmonth, lyear
3617
3618! Limito il mese a [1-12] e correggo l'anno coerentemente
3619lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
3620lyear = iaa + (imm - lmonth)/12
3621ndays = igg+ianno(lmonth, bisextilis(lyear))
3622ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
3623 (lyear-year0)/400
3624
3625END FUNCTION ndays
3626
3627
3628elemental FUNCTION bisextilis(annum)
3629INTEGER,INTENT(in) :: annum
3630INTEGER :: bisextilis
3631
3633 bisextilis = 2
3634ELSE
3635 bisextilis = 1
3636ENDIF
3637END FUNCTION bisextilis
3638
3639
3640ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
3641TYPE(cyclicdatetime),INTENT(IN) :: this, that
3642LOGICAL :: res
3643
3644res = .true.
3645if (this%minute /= that%minute) res=.false.
3646if (this%hour /= that%hour) res=.false.
3647if (this%day /= that%day) res=.false.
3648if (this%month /= that%month) res=.false.
3649if (this%tendaysp /= that%tendaysp) res=.false.
3650
3651END FUNCTION cyclicdatetime_eq
3652
3653
3654ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
3655TYPE(cyclicdatetime),INTENT(IN) :: this
3656TYPE(datetime),INTENT(IN) :: that
3657LOGICAL :: res
3658
3659integer :: minute,hour,day,month
3660
3662
3663res = .true.
3669 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
3670end if
3671
3672END FUNCTION cyclicdatetime_datetime_eq
3673
3674
3675ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
3676TYPE(datetime),INTENT(IN) :: this
3677TYPE(cyclicdatetime),INTENT(IN) :: that
3678LOGICAL :: res
3679
3680integer :: minute,hour,day,month
3681
3683
3684res = .true.
3689
3691 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
3692end if
3693
3694
3695END FUNCTION datetime_cyclicdatetime_eq
3696
3697ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
3698TYPE(cyclicdatetime),INTENT(in) :: this
3699LOGICAL :: res
3700
3701res = .not. this == cyclicdatetime_miss
3702
3703end FUNCTION c_e_cyclicdatetime
3704
3705
3708FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
3709INTEGER,INTENT(IN),OPTIONAL :: tendaysp
3710INTEGER,INTENT(IN),OPTIONAL :: month
3711INTEGER,INTENT(IN),OPTIONAL :: day
3712INTEGER,INTENT(IN),OPTIONAL :: hour
3713INTEGER,INTENT(IN),OPTIONAL :: minute
3714CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
3715
3716integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
3717
3718
3719TYPE(cyclicdatetime) :: this
3720
3721if (present(chardate)) then
3722
3723 ltendaysp=imiss
3724 lmonth=imiss
3725 lday=imiss
3726 lhour=imiss
3727 lminute=imiss
3728
3730 ! TMMGGhhmm
3731 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
3732 !print*,chardate(1:1),ios,ltendaysp
3733 if (ios /= 0)ltendaysp=imiss
3734
3735 read(chardate(2:3),'(i2)',iostat=ios)lmonth
3736 !print*,chardate(2:3),ios,lmonth
3737 if (ios /= 0)lmonth=imiss
3738
3739 read(chardate(4:5),'(i2)',iostat=ios)lday
3740 !print*,chardate(4:5),ios,lday
3741 if (ios /= 0)lday=imiss
3742
3743 read(chardate(6:7),'(i2)',iostat=ios)lhour
3744 !print*,chardate(6:7),ios,lhour
3745 if (ios /= 0)lhour=imiss
3746
3747 read(chardate(8:9),'(i2)',iostat=ios)lminute
3748 !print*,chardate(8:9),ios,lminute
3749 if (ios /= 0)lminute=imiss
3750 end if
3751
3752 this%tendaysp=ltendaysp
3753 this%month=lmonth
3754 this%day=lday
3755 this%hour=lhour
3756 this%minute=lminute
3757else
3758 this%tendaysp=optio_l(tendaysp)
3759 this%month=optio_l(month)
3760 this%day=optio_l(day)
3761 this%hour=optio_l(hour)
3762 this%minute=optio_l(minute)
3763end if
3764
3765END FUNCTION cyclicdatetime_new
3766
3769elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
3770TYPE(cyclicdatetime),INTENT(IN) :: this
3771
3772CHARACTER(len=80) :: char
3773
3776
3777END FUNCTION cyclicdatetime_to_char
3778
3779
3792FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
3793TYPE(cyclicdatetime),INTENT(IN) :: this
3794
3795TYPE(datetime) :: dtc
3796
3797integer :: year,month,day,hour
3798
3799dtc = datetime_miss
3800
3801! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
3803 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
3804 return
3805end if
3806
3807! minute present -> not good for conventional datetime
3809! day, month and tendaysp present -> no good
3811
3813 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
3815 day=(this%tendaysp-1)*10+1
3816 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
3818 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
3820 ! only day present -> no good
3821 return
3822end if
3823
3826 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
3827end if
3828
3829
3830END FUNCTION cyclicdatetime_to_conventional
3831
3832
3833
3834FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
3835TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3836
3837CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
3838
3839char=cyclicdatetime_to_char(in)
3840
3841END FUNCTION trim_cyclicdatetime_to_char
3842
3843
3844
3845SUBROUTINE display_cyclicdatetime(this)
3846TYPE(cyclicdatetime),INTENT(in) :: this
3847
3849
3850end subroutine display_cyclicdatetime
3851
3852
3853#include "array_utilities_inc.F90"
3854
3856
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 |