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