libsim Versione 7.2.1
|
◆ 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 1999 del file datetime_class.F90. 2000! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2001! authors:
2002! Davide Cesari <dcesari@arpa.emr.it>
2003! Paolo Patruno <ppatruno@arpa.emr.it>
2004
2005! This program is free software; you can redistribute it and/or
2006! modify it under the terms of the GNU General Public License as
2007! published by the Free Software Foundation; either version 2 of
2008! the License, or (at your option) any later version.
2009
2010! This program is distributed in the hope that it will be useful,
2011! but WITHOUT ANY WARRANTY; without even the implied warranty of
2012! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2013! GNU General Public License for more details.
2014
2015! You should have received a copy of the GNU General Public License
2016! along with this program. If not, see <http://www.gnu.org/licenses/>.
2017#include "config.h"
2018
2039IMPLICIT NONE
2040
2041INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2042
2045 PRIVATE
2046 INTEGER(KIND=int_ll) :: iminuti
2048
2057 PRIVATE
2058 INTEGER(KIND=int_ll) :: iminuti
2059 INTEGER :: month
2061
2062
2067 PRIVATE
2068 INTEGER :: minute
2069 INTEGER :: hour
2070 INTEGER :: day
2071 INTEGER :: tendaysp
2072 INTEGER :: month
2074
2075
2083INTEGER, PARAMETER :: datetime_utc=1
2085INTEGER, PARAMETER :: datetime_local=2
2095TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2096
2097
2098INTEGER(kind=dateint), PARAMETER :: &
2099 sec_in_day=86400, &
2100 sec_in_hour=3600, &
2101 sec_in_min=60, &
2102 min_in_day=1440, &
2103 min_in_hour=60, &
2104 hour_in_day=24
2105
2106INTEGER,PARAMETER :: &
2107 year0=1, & ! anno di origine per iminuti
2108 d1=365, & ! giorni/1 anno nel calendario gregoriano
2109 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2110 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2111 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2112 ianno(13,2)=reshape((/ &
2113 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2114 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2115
2116INTEGER(KIND=int_ll),PARAMETER :: &
2117 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2118
2123 MODULE PROCEDURE datetime_init, timedelta_init
2124END INTERFACE
2125
2129 MODULE PROCEDURE datetime_delete, timedelta_delete
2130END INTERFACE
2131
2134 MODULE PROCEDURE datetime_getval, timedelta_getval
2135END INTERFACE
2136
2139 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2140END INTERFACE
2141
2142
2161 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2162END INTERFACE
2163
2169INTERFACE OPERATOR (==)
2170 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2171 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2172END INTERFACE
2173
2179INTERFACE OPERATOR (/=)
2180 MODULE PROCEDURE datetime_ne, timedelta_ne
2181END INTERFACE
2182
2190INTERFACE OPERATOR (>)
2191 MODULE PROCEDURE datetime_gt, timedelta_gt
2192END INTERFACE
2193
2201INTERFACE OPERATOR (<)
2202 MODULE PROCEDURE datetime_lt, timedelta_lt
2203END INTERFACE
2204
2212INTERFACE OPERATOR (>=)
2213 MODULE PROCEDURE datetime_ge, timedelta_ge
2214END INTERFACE
2215
2223INTERFACE OPERATOR (<=)
2224 MODULE PROCEDURE datetime_le, timedelta_le
2225END INTERFACE
2226
2233INTERFACE OPERATOR (+)
2234 MODULE PROCEDURE datetime_add, timedelta_add
2235END INTERFACE
2236
2244INTERFACE OPERATOR (-)
2245 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
2246END INTERFACE
2247
2253INTERFACE OPERATOR (*)
2254 MODULE PROCEDURE timedelta_mult, timedelta_tlum
2255END INTERFACE
2256
2263INTERFACE OPERATOR (/)
2264 MODULE PROCEDURE timedelta_divint, timedelta_divtd
2265END INTERFACE
2266
2278 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2279END INTERFACE
2280
2284 MODULE PROCEDURE timedelta_abs
2285END INTERFACE
2286
2290 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2291 timedelta_read_unit, timedelta_vect_read_unit
2292END INTERFACE
2293
2297 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2298 timedelta_write_unit, timedelta_vect_write_unit
2299END INTERFACE
2300
2303 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2304END INTERFACE
2305
2308 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
2309END INTERFACE
2310
2311#undef VOL7D_POLY_TYPE
2312#undef VOL7D_POLY_TYPES
2313#undef ENABLE_SORT
2314#define VOL7D_POLY_TYPE TYPE(datetime)
2315#define VOL7D_POLY_TYPES _datetime
2316#define ENABLE_SORT
2317#include "array_utilities_pre.F90"
2318
2319
2320#define ARRAYOF_ORIGTYPE TYPE(datetime)
2321#define ARRAYOF_TYPE arrayof_datetime
2322#define ARRAYOF_ORIGEQ 1
2323#include "arrayof_pre.F90"
2324! from arrayof
2325
2326PRIVATE
2327
2329 datetime_min, datetime_max, &
2332 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2333 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2335 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2336 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2338 count_distinct, pack_distinct, &
2339 count_distinct_sorted, pack_distinct_sorted, &
2340 count_and_pack_distinct, &
2342 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
2344PUBLIC insert_unique, append_unique
2345PUBLIC cyclicdatetime_to_conventional
2346
2347CONTAINS
2348
2349
2350! ==============
2351! == datetime ==
2352! ==============
2353
2360ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
2361 unixtime, isodate, simpledate) RESULT(this)
2362INTEGER,INTENT(IN),OPTIONAL :: year
2363INTEGER,INTENT(IN),OPTIONAL :: month
2364INTEGER,INTENT(IN),OPTIONAL :: day
2365INTEGER,INTENT(IN),OPTIONAL :: hour
2366INTEGER,INTENT(IN),OPTIONAL :: minute
2367INTEGER,INTENT(IN),OPTIONAL :: msec
2368INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2369CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2370CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2371
2372TYPE(datetime) :: this
2373INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2374CHARACTER(len=23) :: datebuf
2375
2376IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
2377 lyear = year
2378 IF (PRESENT(month)) THEN
2379 lmonth = month
2380 ELSE
2381 lmonth = 1
2382 ENDIF
2383 IF (PRESENT(day)) THEN
2384 lday = day
2385 ELSE
2386 lday = 1
2387 ENDIF
2388 IF (PRESENT(hour)) THEN
2389 lhour = hour
2390 ELSE
2391 lhour = 0
2392 ENDIF
2393 IF (PRESENT(minute)) THEN
2394 lminute = minute
2395 ELSE
2396 lminute = 0
2397 ENDIF
2398 IF (PRESENT(msec)) THEN
2399 lmsec = msec
2400 ELSE
2401 lmsec = 0
2402 ENDIF
2403
2406 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2407 else
2408 this=datetime_miss
2409 end if
2410
2411ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
2413 this%iminuti = (unixtime + unsec)*1000
2414 else
2415 this=datetime_miss
2416 end if
2417
2418ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
2419
2421 datebuf(1:23) = '0001-01-01 00:00:00.000'
2422 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
2423 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
2424 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2425 lmsec = lmsec + lsec*1000
2426 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2427 RETURN
2428
2429100 CONTINUE ! condizione di errore in isodate
2431 RETURN
2432 ELSE
2433 this = datetime_miss
2434 ENDIF
2435
2436ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
2438 datebuf(1:17) = '00010101000000000'
2439 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
2440 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
2441 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2442 lmsec = lmsec + lsec*1000
2443 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2444 RETURN
2445
2446120 CONTINUE ! condizione di errore in simpledate
2448 RETURN
2449 ELSE
2450 this = datetime_miss
2451 ENDIF
2452
2453ELSE
2454 this = datetime_miss
2455ENDIF
2456
2457END FUNCTION datetime_new
2458
2459
2461FUNCTION datetime_new_now(now) RESULT(this)
2462INTEGER,INTENT(IN) :: now
2463TYPE(datetime) :: this
2464
2465INTEGER :: dt(8)
2466
2468 CALL date_and_time(values=dt)
2469 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
2471 msec=dt(7)*1000+dt(8))
2472ELSE
2473 this = datetime_miss
2474ENDIF
2475
2476END FUNCTION datetime_new_now
2477
2478
2485SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
2486 unixtime, isodate, simpledate, now)
2487TYPE(datetime),INTENT(INOUT) :: this
2488INTEGER,INTENT(IN),OPTIONAL :: year
2489INTEGER,INTENT(IN),OPTIONAL :: month
2490INTEGER,INTENT(IN),OPTIONAL :: day
2491INTEGER,INTENT(IN),OPTIONAL :: hour
2492INTEGER,INTENT(IN),OPTIONAL :: minute
2493INTEGER,INTENT(IN),OPTIONAL :: msec
2494INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2495CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2496CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2497INTEGER,INTENT(IN),OPTIONAL :: now
2498
2499IF (PRESENT(now)) THEN
2500 this = datetime_new_now(now)
2501ELSE
2502 this = datetime_new(year, month, day, hour, minute, msec, &
2503 unixtime, isodate, simpledate)
2504ENDIF
2505
2506END SUBROUTINE datetime_init
2507
2508
2509ELEMENTAL SUBROUTINE datetime_delete(this)
2510TYPE(datetime),INTENT(INOUT) :: this
2511
2512this%iminuti = illmiss
2513
2514END SUBROUTINE datetime_delete
2515
2516
2521PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
2522 unixtime, isodate, simpledate, oraclesimdate)
2523TYPE(datetime),INTENT(IN) :: this
2524INTEGER,INTENT(OUT),OPTIONAL :: year
2525INTEGER,INTENT(OUT),OPTIONAL :: month
2526INTEGER,INTENT(OUT),OPTIONAL :: day
2527INTEGER,INTENT(OUT),OPTIONAL :: hour
2528INTEGER,INTENT(OUT),OPTIONAL :: minute
2529INTEGER,INTENT(OUT),OPTIONAL :: msec
2530INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
2531CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
2532CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
2533CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
2534
2535INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2536CHARACTER(len=23) :: datebuf
2537
2538IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
2539 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
2540 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
2541
2542 IF (this == datetime_miss) THEN
2543
2544 IF (PRESENT(msec)) THEN
2545 msec = imiss
2546 ENDIF
2547 IF (PRESENT(minute)) THEN
2548 minute = imiss
2549 ENDIF
2550 IF (PRESENT(hour)) THEN
2551 hour = imiss
2552 ENDIF
2553 IF (PRESENT(day)) THEN
2554 day = imiss
2555 ENDIF
2556 IF (PRESENT(month)) THEN
2557 month = imiss
2558 ENDIF
2559 IF (PRESENT(year)) THEN
2560 year = imiss
2561 ENDIF
2562 IF (PRESENT(isodate)) THEN
2563 isodate = cmiss
2564 ENDIF
2565 IF (PRESENT(simpledate)) THEN
2566 simpledate = cmiss
2567 ENDIF
2568 IF (PRESENT(oraclesimdate)) THEN
2569!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2570!!$ 'obsoleto, usare piuttosto simpledate')
2571 oraclesimdate=cmiss
2572 ENDIF
2573 IF (PRESENT(unixtime)) THEN
2574 unixtime = illmiss
2575 ENDIF
2576
2577 ELSE
2578
2579 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2580 IF (PRESENT(msec)) THEN
2581 msec = lmsec
2582 ENDIF
2583 IF (PRESENT(minute)) THEN
2584 minute = lminute
2585 ENDIF
2586 IF (PRESENT(hour)) THEN
2587 hour = lhour
2588 ENDIF
2589 IF (PRESENT(day)) THEN
2590 day = lday
2591 ENDIF
2592 IF (PRESENT(month)) THEN
2593 month = lmonth
2594 ENDIF
2595 IF (PRESENT(year)) THEN
2596 year = lyear
2597 ENDIF
2598 IF (PRESENT(isodate)) THEN
2599 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
2600 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
2602 isodate = datebuf(1:min(len(isodate),23))
2603 ENDIF
2604 IF (PRESENT(simpledate)) THEN
2605 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
2606 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
2607 simpledate = datebuf(1:min(len(simpledate),17))
2608 ENDIF
2609 IF (PRESENT(oraclesimdate)) THEN
2610!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2611!!$ 'obsoleto, usare piuttosto simpledate')
2612 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
2613 ENDIF
2614 IF (PRESENT(unixtime)) THEN
2615 unixtime = this%iminuti/1000_int_ll-unsec
2616 ENDIF
2617
2618 ENDIF
2619ENDIF
2620
2621END SUBROUTINE datetime_getval
2622
2623
2626elemental FUNCTION datetime_to_char(this) RESULT(char)
2627TYPE(datetime),INTENT(IN) :: this
2628
2629CHARACTER(len=23) :: char
2630
2632
2633END FUNCTION datetime_to_char
2634
2635
2636FUNCTION trim_datetime_to_char(in) RESULT(char)
2637TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
2638
2639CHARACTER(len=len_trim(datetime_to_char(in))) :: char
2640
2641char=datetime_to_char(in)
2642
2643END FUNCTION trim_datetime_to_char
2644
2645
2646
2647SUBROUTINE display_datetime(this)
2648TYPE(datetime),INTENT(in) :: this
2649
2651
2652end subroutine display_datetime
2653
2654
2655
2656SUBROUTINE display_timedelta(this)
2657TYPE(timedelta),INTENT(in) :: this
2658
2660
2661end subroutine display_timedelta
2662
2663
2664
2665ELEMENTAL FUNCTION c_e_datetime(this) result (res)
2666TYPE(datetime),INTENT(in) :: this
2667LOGICAL :: res
2668
2669res = .not. this == datetime_miss
2670
2671end FUNCTION c_e_datetime
2672
2673
2674ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
2675TYPE(datetime),INTENT(IN) :: this, that
2676LOGICAL :: res
2677
2678res = this%iminuti == that%iminuti
2679
2680END FUNCTION datetime_eq
2681
2682
2683ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
2684TYPE(datetime),INTENT(IN) :: this, that
2685LOGICAL :: res
2686
2687res = .NOT.(this == that)
2688
2689END FUNCTION datetime_ne
2690
2691
2692ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
2693TYPE(datetime),INTENT(IN) :: this, that
2694LOGICAL :: res
2695
2696res = this%iminuti > that%iminuti
2697
2698END FUNCTION datetime_gt
2699
2700
2701ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
2702TYPE(datetime),INTENT(IN) :: this, that
2703LOGICAL :: res
2704
2705res = this%iminuti < that%iminuti
2706
2707END FUNCTION datetime_lt
2708
2709
2710ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
2711TYPE(datetime),INTENT(IN) :: this, that
2712LOGICAL :: res
2713
2714IF (this == that) THEN
2715 res = .true.
2716ELSE IF (this > that) THEN
2717 res = .true.
2718ELSE
2719 res = .false.
2720ENDIF
2721
2722END FUNCTION datetime_ge
2723
2724
2725ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
2726TYPE(datetime),INTENT(IN) :: this, that
2727LOGICAL :: res
2728
2729IF (this == that) THEN
2730 res = .true.
2731ELSE IF (this < that) THEN
2732 res = .true.
2733ELSE
2734 res = .false.
2735ENDIF
2736
2737END FUNCTION datetime_le
2738
2739
2740FUNCTION datetime_add(this, that) RESULT(res)
2741TYPE(datetime),INTENT(IN) :: this
2742TYPE(timedelta),INTENT(IN) :: that
2743TYPE(datetime) :: res
2744
2745INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2746
2747IF (this == datetime_miss .OR. that == timedelta_miss) THEN
2748 res = datetime_miss
2749ELSE
2750 res%iminuti = this%iminuti + that%iminuti
2751 IF (that%month /= 0) THEN
2753 minute=lminute, msec=lmsec)
2755 hour=lhour, minute=lminute, msec=lmsec)
2756 ENDIF
2757ENDIF
2758
2759END FUNCTION datetime_add
2760
2761
2762ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
2763TYPE(datetime),INTENT(IN) :: this, that
2764TYPE(timedelta) :: res
2765
2766IF (this == datetime_miss .OR. that == datetime_miss) THEN
2767 res = timedelta_miss
2768ELSE
2769 res%iminuti = this%iminuti - that%iminuti
2770 res%month = 0
2771ENDIF
2772
2773END FUNCTION datetime_subdt
2774
2775
2776FUNCTION datetime_subtd(this, that) RESULT(res)
2777TYPE(datetime),INTENT(IN) :: this
2778TYPE(timedelta),INTENT(IN) :: that
2779TYPE(datetime) :: res
2780
2781INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2782
2783IF (this == datetime_miss .OR. that == timedelta_miss) THEN
2784 res = datetime_miss
2785ELSE
2786 res%iminuti = this%iminuti - that%iminuti
2787 IF (that%month /= 0) THEN
2789 minute=lminute, msec=lmsec)
2791 hour=lhour, minute=lminute, msec=lmsec)
2792 ENDIF
2793ENDIF
2794
2795END FUNCTION datetime_subtd
2796
2797
2802SUBROUTINE datetime_read_unit(this, unit)
2803TYPE(datetime),INTENT(out) :: this
2804INTEGER, INTENT(in) :: unit
2805CALL datetime_vect_read_unit((/this/), unit)
2806
2807END SUBROUTINE datetime_read_unit
2808
2809
2814SUBROUTINE datetime_vect_read_unit(this, unit)
2815TYPE(datetime) :: this(:)
2816INTEGER, INTENT(in) :: unit
2817
2818CHARACTER(len=40) :: form
2819CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
2820INTEGER :: i
2821
2822ALLOCATE(dateiso(SIZE(this)))
2823INQUIRE(unit, form=form)
2824IF (form == 'FORMATTED') THEN
2825 READ(unit,'(A23,1X)')dateiso
2826ELSE
2827 READ(unit)dateiso
2828ENDIF
2829DO i = 1, SIZE(dateiso)
2831ENDDO
2832DEALLOCATE(dateiso)
2833
2834END SUBROUTINE datetime_vect_read_unit
2835
2836
2841SUBROUTINE datetime_write_unit(this, unit)
2842TYPE(datetime),INTENT(in) :: this
2843INTEGER, INTENT(in) :: unit
2844
2845CALL datetime_vect_write_unit((/this/), unit)
2846
2847END SUBROUTINE datetime_write_unit
2848
2849
2854SUBROUTINE datetime_vect_write_unit(this, unit)
2855TYPE(datetime),INTENT(in) :: this(:)
2856INTEGER, INTENT(in) :: unit
2857
2858CHARACTER(len=40) :: form
2859CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
2860INTEGER :: i
2861
2862ALLOCATE(dateiso(SIZE(this)))
2863DO i = 1, SIZE(dateiso)
2865ENDDO
2866INQUIRE(unit, form=form)
2867IF (form == 'FORMATTED') THEN
2868 WRITE(unit,'(A23,1X)')dateiso
2869ELSE
2870 WRITE(unit)dateiso
2871ENDIF
2872DEALLOCATE(dateiso)
2873
2874END SUBROUTINE datetime_vect_write_unit
2875
2876
2877#include "arrayof_post.F90"
2878
2879
2880! ===============
2881! == timedelta ==
2882! ===============
2889FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
2890 isodate, simpledate, oraclesimdate) RESULT (this)
2891INTEGER,INTENT(IN),OPTIONAL :: year
2892INTEGER,INTENT(IN),OPTIONAL :: month
2893INTEGER,INTENT(IN),OPTIONAL :: day
2894INTEGER,INTENT(IN),OPTIONAL :: hour
2895INTEGER,INTENT(IN),OPTIONAL :: minute
2896INTEGER,INTENT(IN),OPTIONAL :: sec
2897INTEGER,INTENT(IN),OPTIONAL :: msec
2898CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2899CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2900CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
2901
2902TYPE(timedelta) :: this
2903
2904CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
2905 isodate, simpledate, oraclesimdate)
2906
2907END FUNCTION timedelta_new
2908
2909
2914SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
2915 isodate, simpledate, oraclesimdate)
2916TYPE(timedelta),INTENT(INOUT) :: this
2917INTEGER,INTENT(IN),OPTIONAL :: year
2918INTEGER,INTENT(IN),OPTIONAL :: month
2919INTEGER,INTENT(IN),OPTIONAL :: day
2920INTEGER,INTENT(IN),OPTIONAL :: hour
2921INTEGER,INTENT(IN),OPTIONAL :: minute
2922INTEGER,INTENT(IN),OPTIONAL :: sec
2923INTEGER,INTENT(IN),OPTIONAL :: msec
2924CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2925CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2926CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
2927
2928INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
2929CHARACTER(len=23) :: datebuf
2930
2931this%month = 0
2932
2933IF (PRESENT(isodate)) THEN
2934 datebuf(1:23) = '0000000000 00:00:00.000'
2935 l = len_trim(isodate)
2936! IF (l > 0) THEN
2938 IF (n > 0) THEN
2939 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
2940 datebuf(12-n:12-n+l-1) = isodate(:l)
2941 ELSE
2942 datebuf(1:l) = isodate(1:l)
2943 ENDIF
2944! ENDIF
2945
2946! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
2947 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
2948 h, m, s, ms
2949 this%month = lmonth + 12*lyear
2950 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
2951 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
2952 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
2953 RETURN
2954
2955200 CONTINUE ! condizione di errore in isodate
2957 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
2958 CALL raise_error()
2959
2960ELSE IF (PRESENT(simpledate)) THEN
2961 datebuf(1:17) = '00000000000000000'
2962 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
2963 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
2964 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
2965 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
2966 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
2967
2968220 CONTINUE ! condizione di errore in simpledate
2970 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
2971 CALL raise_error()
2972 RETURN
2973
2974ELSE IF (PRESENT(oraclesimdate)) THEN
2975 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
2976 'obsoleto, usare piuttosto simpledate')
2977 READ(oraclesimdate, '(I8,2I2)')d, h, m
2978 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
2979 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
2980
2981ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
2982 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
2983 .and. .not. present(msec) .and. .not. present(isodate) &
2984 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
2985
2986 this=timedelta_miss
2987
2988ELSE
2989 this%iminuti = 0
2990 IF (PRESENT(year)) THEN
2992 this%month = this%month + year*12
2993 else
2994 this=timedelta_miss
2995 return
2996 end if
2997 ENDIF
2998 IF (PRESENT(month)) THEN
3000 this%month = this%month + month
3001 else
3002 this=timedelta_miss
3003 return
3004 end if
3005 ENDIF
3006 IF (PRESENT(day)) THEN
3008 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3009 else
3010 this=timedelta_miss
3011 return
3012 end if
3013 ENDIF
3014 IF (PRESENT(hour)) THEN
3016 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3017 else
3018 this=timedelta_miss
3019 return
3020 end if
3021 ENDIF
3022 IF (PRESENT(minute)) THEN
3024 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3025 else
3026 this=timedelta_miss
3027 return
3028 end if
3029 ENDIF
3030 IF (PRESENT(sec)) THEN
3032 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3033 else
3034 this=timedelta_miss
3035 return
3036 end if
3037 ENDIF
3038 IF (PRESENT(msec)) THEN
3040 this%iminuti = this%iminuti + msec
3041 else
3042 this=timedelta_miss
3043 return
3044 end if
3045 ENDIF
3046ENDIF
3047
3048
3049
3050
3051END SUBROUTINE timedelta_init
3052
3053
3054SUBROUTINE timedelta_delete(this)
3055TYPE(timedelta),INTENT(INOUT) :: this
3056
3057this%iminuti = imiss
3058this%month = 0
3059
3060END SUBROUTINE timedelta_delete
3061
3062
3067PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3068 day, hour, minute, sec, msec, &
3069 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3070TYPE(timedelta),INTENT(IN) :: this
3071INTEGER,INTENT(OUT),OPTIONAL :: year
3072INTEGER,INTENT(OUT),OPTIONAL :: month
3073INTEGER,INTENT(OUT),OPTIONAL :: amonth
3074INTEGER,INTENT(OUT),OPTIONAL :: day
3075INTEGER,INTENT(OUT),OPTIONAL :: hour
3076INTEGER,INTENT(OUT),OPTIONAL :: minute
3077INTEGER,INTENT(OUT),OPTIONAL :: sec
3078INTEGER,INTENT(OUT),OPTIONAL :: msec
3079INTEGER,INTENT(OUT),OPTIONAL :: ahour
3080INTEGER,INTENT(OUT),OPTIONAL :: aminute
3081INTEGER,INTENT(OUT),OPTIONAL :: asec
3082INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
3083CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3084CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3085CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3086
3087CHARACTER(len=23) :: datebuf
3088
3089IF (PRESENT(amsec)) THEN
3090 amsec = this%iminuti
3091ENDIF
3092IF (PRESENT(asec)) THEN
3093 asec = int(this%iminuti/1000_int_ll)
3094ENDIF
3095IF (PRESENT(aminute)) THEN
3096 aminute = int(this%iminuti/60000_int_ll)
3097ENDIF
3098IF (PRESENT(ahour)) THEN
3099 ahour = int(this%iminuti/3600000_int_ll)
3100ENDIF
3101IF (PRESENT(msec)) THEN
3102 msec = int(mod(this%iminuti, 1000_int_ll))
3103ENDIF
3104IF (PRESENT(sec)) THEN
3105 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3106ENDIF
3107IF (PRESENT(minute)) THEN
3108 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3109ENDIF
3110IF (PRESENT(hour)) THEN
3111 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3112ENDIF
3113IF (PRESENT(day)) THEN
3114 day = int(this%iminuti/86400000_int_ll)
3115ENDIF
3116IF (PRESENT(amonth)) THEN
3117 amonth = this%month
3118ENDIF
3119IF (PRESENT(month)) THEN
3120 month = mod(this%month-1,12)+1
3121ENDIF
3122IF (PRESENT(year)) THEN
3123 year = this%month/12
3124ENDIF
3125IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3126 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3130 isodate = datebuf(1:min(len(isodate),23))
3131
3132ENDIF
3133IF (PRESENT(simpledate)) THEN
3134 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3135 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3137 mod(this%iminuti, 1000_int_ll)
3138 simpledate = datebuf(1:min(len(simpledate),17))
3139ENDIF
3140IF (PRESENT(oraclesimdate)) THEN
3141!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3142!!$ 'obsoleto, usare piuttosto simpledate')
3143 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3145ENDIF
3146
3147END SUBROUTINE timedelta_getval
3148
3149
3152elemental FUNCTION timedelta_to_char(this) RESULT(char)
3153TYPE(timedelta),INTENT(IN) :: this
3154
3155CHARACTER(len=23) :: char
3156
3158
3159END FUNCTION timedelta_to_char
3160
3161
3162FUNCTION trim_timedelta_to_char(in) RESULT(char)
3163TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3164
3165CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3166
3167char=timedelta_to_char(in)
3168
3169END FUNCTION trim_timedelta_to_char
3170
3171
3173elemental FUNCTION timedelta_getamsec(this)
3174TYPE(timedelta),INTENT(IN) :: this
3175INTEGER(kind=int_ll) :: timedelta_getamsec
3176
3177timedelta_getamsec = this%iminuti
3178
3179END FUNCTION timedelta_getamsec
3180
3181
3187FUNCTION timedelta_depop(this)
3188TYPE(timedelta),INTENT(IN) :: this
3189TYPE(timedelta) :: timedelta_depop
3190
3191TYPE(datetime) :: tmpdt
3192
3193IF (this%month == 0) THEN
3194 timedelta_depop = this
3195ELSE
3196 tmpdt = datetime_new(1970, 1, 1)
3197 timedelta_depop = (tmpdt + this) - tmpdt
3198ENDIF
3199
3200END FUNCTION timedelta_depop
3201
3202
3203elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3204TYPE(timedelta),INTENT(IN) :: this, that
3205LOGICAL :: res
3206
3207res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3208
3209END FUNCTION timedelta_eq
3210
3211
3212ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3213TYPE(timedelta),INTENT(IN) :: this, that
3214LOGICAL :: res
3215
3216res = .NOT.(this == that)
3217
3218END FUNCTION timedelta_ne
3219
3220
3221ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
3222TYPE(timedelta),INTENT(IN) :: this, that
3223LOGICAL :: res
3224
3225res = this%iminuti > that%iminuti
3226
3227END FUNCTION timedelta_gt
3228
3229
3230ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
3231TYPE(timedelta),INTENT(IN) :: this, that
3232LOGICAL :: res
3233
3234res = this%iminuti < that%iminuti
3235
3236END FUNCTION timedelta_lt
3237
3238
3239ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
3240TYPE(timedelta),INTENT(IN) :: this, that
3241LOGICAL :: res
3242
3243IF (this == that) THEN
3244 res = .true.
3245ELSE IF (this > that) THEN
3246 res = .true.
3247ELSE
3248 res = .false.
3249ENDIF
3250
3251END FUNCTION timedelta_ge
3252
3253
3254elemental FUNCTION timedelta_le(this, that) RESULT(res)
3255TYPE(timedelta),INTENT(IN) :: this, that
3256LOGICAL :: res
3257
3258IF (this == that) THEN
3259 res = .true.
3260ELSE IF (this < that) THEN
3261 res = .true.
3262ELSE
3263 res = .false.
3264ENDIF
3265
3266END FUNCTION timedelta_le
3267
3268
3269ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
3270TYPE(timedelta),INTENT(IN) :: this, that
3271TYPE(timedelta) :: res
3272
3273res%iminuti = this%iminuti + that%iminuti
3274res%month = this%month + that%month
3275
3276END FUNCTION timedelta_add
3277
3278
3279ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
3280TYPE(timedelta),INTENT(IN) :: this, that
3281TYPE(timedelta) :: res
3282
3283res%iminuti = this%iminuti - that%iminuti
3284res%month = this%month - that%month
3285
3286END FUNCTION timedelta_sub
3287
3288
3289ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
3290TYPE(timedelta),INTENT(IN) :: this
3291INTEGER,INTENT(IN) :: n
3292TYPE(timedelta) :: res
3293
3294res%iminuti = this%iminuti*n
3295res%month = this%month*n
3296
3297END FUNCTION timedelta_mult
3298
3299
3300ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
3301INTEGER,INTENT(IN) :: n
3302TYPE(timedelta),INTENT(IN) :: this
3303TYPE(timedelta) :: res
3304
3305res%iminuti = this%iminuti*n
3306res%month = this%month*n
3307
3308END FUNCTION timedelta_tlum
3309
3310
3311ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
3312TYPE(timedelta),INTENT(IN) :: this
3313INTEGER,INTENT(IN) :: n
3314TYPE(timedelta) :: res
3315
3316res%iminuti = this%iminuti/n
3317res%month = this%month/n
3318
3319END FUNCTION timedelta_divint
3320
3321
3322ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
3323TYPE(timedelta),INTENT(IN) :: this, that
3324INTEGER :: res
3325
3326res = int(this%iminuti/that%iminuti)
3327
3328END FUNCTION timedelta_divtd
3329
3330
3331elemental FUNCTION timedelta_mod(this, that) RESULT(res)
3332TYPE(timedelta),INTENT(IN) :: this, that
3333TYPE(timedelta) :: res
3334
3335res%iminuti = mod(this%iminuti, that%iminuti)
3336res%month = 0
3337
3338END FUNCTION timedelta_mod
3339
3340
3341ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
3342TYPE(datetime),INTENT(IN) :: this
3343TYPE(timedelta),INTENT(IN) :: that
3344TYPE(timedelta) :: res
3345
3346IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
3347 res = timedelta_0
3348ELSE
3349 res%iminuti = mod(this%iminuti, that%iminuti)
3350 res%month = 0
3351ENDIF
3352
3353END FUNCTION datetime_timedelta_mod
3354
3355
3356ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
3357TYPE(timedelta),INTENT(IN) :: this
3358TYPE(timedelta) :: res
3359
3360res%iminuti = abs(this%iminuti)
3361res%month = abs(this%month)
3362
3363END FUNCTION timedelta_abs
3364
3365
3370SUBROUTINE timedelta_read_unit(this, unit)
3371TYPE(timedelta),INTENT(out) :: this
3372INTEGER, INTENT(in) :: unit
3373
3374CALL timedelta_vect_read_unit((/this/), unit)
3375
3376END SUBROUTINE timedelta_read_unit
3377
3378
3383SUBROUTINE timedelta_vect_read_unit(this, unit)
3384TYPE(timedelta) :: this(:)
3385INTEGER, INTENT(in) :: unit
3386
3387CHARACTER(len=40) :: form
3388CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3389INTEGER :: i
3390
3391ALLOCATE(dateiso(SIZE(this)))
3392INQUIRE(unit, form=form)
3393IF (form == 'FORMATTED') THEN
3394 READ(unit,'(3(A23,1X))')dateiso
3395ELSE
3396 READ(unit)dateiso
3397ENDIF
3398DO i = 1, SIZE(dateiso)
3400ENDDO
3401DEALLOCATE(dateiso)
3402
3403END SUBROUTINE timedelta_vect_read_unit
3404
3405
3410SUBROUTINE timedelta_write_unit(this, unit)
3411TYPE(timedelta),INTENT(in) :: this
3412INTEGER, INTENT(in) :: unit
3413
3414CALL timedelta_vect_write_unit((/this/), unit)
3415
3416END SUBROUTINE timedelta_write_unit
3417
3418
3423SUBROUTINE timedelta_vect_write_unit(this, unit)
3424TYPE(timedelta),INTENT(in) :: this(:)
3425INTEGER, INTENT(in) :: unit
3426
3427CHARACTER(len=40) :: form
3428CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3429INTEGER :: i
3430
3431ALLOCATE(dateiso(SIZE(this)))
3432DO i = 1, SIZE(dateiso)
3434ENDDO
3435INQUIRE(unit, form=form)
3436IF (form == 'FORMATTED') THEN
3437 WRITE(unit,'(3(A23,1X))')dateiso
3438ELSE
3439 WRITE(unit)dateiso
3440ENDIF
3441DEALLOCATE(dateiso)
3442
3443END SUBROUTINE timedelta_vect_write_unit
3444
3445
3446ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
3447TYPE(timedelta),INTENT(in) :: this
3448LOGICAL :: res
3449
3450res = .not. this == timedelta_miss
3451
3452end FUNCTION c_e_timedelta
3453
3454
3455elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
3456
3457!!omstart JELADATA5
3458! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3459! 1 IMINUTI)
3460!
3461! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
3462!
3463! variabili integer*4
3464! IN:
3465! IDAY,IMONTH,IYEAR, I*4
3466! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3467!
3468! OUT:
3469! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3470!!OMEND
3471
3472INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
3473INTEGER,intent(out) :: iminuti
3474
3475iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
3476
3477END SUBROUTINE jeladata5
3478
3479
3480elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
3481INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
3482INTEGER(KIND=int_ll),intent(out) :: imillisec
3483
3484imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
3485 + imsec
3486
3487END SUBROUTINE jeladata5_1
3488
3489
3490
3491elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
3492
3493!!omstart JELADATA6
3494! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3495! 1 IMINUTI)
3496!
3497! Calcola la data e l'ora corrispondente a IMINUTI dopo il
3498! 1/1/1
3499!
3500! variabili integer*4
3501! IN:
3502! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3503!
3504! OUT:
3505! IDAY,IMONTH,IYEAR, I*4
3506! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3507!!OMEND
3508
3509
3510INTEGER,intent(in) :: iminuti
3511INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
3512
3513INTEGER ::igiorno
3514
3515imin = mod(iminuti,60)
3516ihour = mod(iminuti,1440)/60
3517igiorno = iminuti/1440
3519CALL ndyin(igiorno,iday,imonth,iyear)
3520
3521END SUBROUTINE jeladata6
3522
3523
3524elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
3525INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
3526INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
3527
3528INTEGER :: igiorno
3529
3531!imin = MOD(imillisec/60000_int_ll, 60)
3532!ihour = MOD(imillisec/3600000_int_ll, 24)
3533imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
3534ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
3535igiorno = int(imillisec/86400000_int_ll)
3536!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
3537CALL ndyin(igiorno,iday,imonth,iyear)
3538
3539END SUBROUTINE jeladata6_1
3540
3541
3542elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
3543
3544!!OMSTART NDYIN
3545! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
3546! restituisce la data fornendo in input il numero di
3547! giorni dal 1/1/1
3548!
3549!!omend
3550
3551INTEGER,intent(in) :: ndays
3552INTEGER,intent(out) :: igg, imm, iaa
3553integer :: n,lndays
3554
3555lndays=ndays
3556
3557n = lndays/d400
3558lndays = lndays - n*d400
3559iaa = year0 + n*400
3560n = min(lndays/d100, 3)
3561lndays = lndays - n*d100
3562iaa = iaa + n*100
3563n = lndays/d4
3564lndays = lndays - n*d4
3565iaa = iaa + n*4
3566n = min(lndays/d1, 3)
3567lndays = lndays - n*d1
3568iaa = iaa + n
3569n = bisextilis(iaa)
3570DO imm = 1, 12
3571 IF (lndays < ianno(imm+1,n)) EXIT
3572ENDDO
3573igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
3574
3575END SUBROUTINE ndyin
3576
3577
3578integer elemental FUNCTION ndays(igg,imm,iaa)
3579
3580!!OMSTART NDAYS
3581! FUNCTION NDAYS(IGG,IMM,IAA)
3582! restituisce il numero di giorni dal 1/1/1
3583! fornendo in input la data
3584!
3585!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3586! nota bene E' SICURO !!!
3587! un anno e' bisestile se divisibile per 4
3588! un anno rimane bisestile se divisibile per 400
3589! un anno NON e' bisestile se divisibile per 100
3590!
3591!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3592!
3593!!omend
3594
3595INTEGER, intent(in) :: igg, imm, iaa
3596
3597INTEGER :: lmonth, lyear
3598
3599! Limito il mese a [1-12] e correggo l'anno coerentemente
3600lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
3601lyear = iaa + (imm - lmonth)/12
3602ndays = igg+ianno(lmonth, bisextilis(lyear))
3603ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
3604 (lyear-year0)/400
3605
3606END FUNCTION ndays
3607
3608
3609elemental FUNCTION bisextilis(annum)
3610INTEGER,INTENT(in) :: annum
3611INTEGER :: bisextilis
3612
3614 bisextilis = 2
3615ELSE
3616 bisextilis = 1
3617ENDIF
3618END FUNCTION bisextilis
3619
3620
3621ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
3622TYPE(cyclicdatetime),INTENT(IN) :: this, that
3623LOGICAL :: res
3624
3625res = .true.
3626if (this%minute /= that%minute) res=.false.
3627if (this%hour /= that%hour) res=.false.
3628if (this%day /= that%day) res=.false.
3629if (this%month /= that%month) res=.false.
3630if (this%tendaysp /= that%tendaysp) res=.false.
3631
3632END FUNCTION cyclicdatetime_eq
3633
3634
3635ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
3636TYPE(cyclicdatetime),INTENT(IN) :: this
3637TYPE(datetime),INTENT(IN) :: that
3638LOGICAL :: res
3639
3640integer :: minute,hour,day,month
3641
3643
3644res = .true.
3650 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
3651end if
3652
3653END FUNCTION cyclicdatetime_datetime_eq
3654
3655
3656ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
3657TYPE(datetime),INTENT(IN) :: this
3658TYPE(cyclicdatetime),INTENT(IN) :: that
3659LOGICAL :: res
3660
3661integer :: minute,hour,day,month
3662
3664
3665res = .true.
3670
3672 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
3673end if
3674
3675
3676END FUNCTION datetime_cyclicdatetime_eq
3677
3678ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
3679TYPE(cyclicdatetime),INTENT(in) :: this
3680LOGICAL :: res
3681
3682res = .not. this == cyclicdatetime_miss
3683
3684end FUNCTION c_e_cyclicdatetime
3685
3686
3689FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
3690INTEGER,INTENT(IN),OPTIONAL :: tendaysp
3691INTEGER,INTENT(IN),OPTIONAL :: month
3692INTEGER,INTENT(IN),OPTIONAL :: day
3693INTEGER,INTENT(IN),OPTIONAL :: hour
3694INTEGER,INTENT(IN),OPTIONAL :: minute
3695CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
3696
3697integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
3698
3699
3700TYPE(cyclicdatetime) :: this
3701
3702if (present(chardate)) then
3703
3704 ltendaysp=imiss
3705 lmonth=imiss
3706 lday=imiss
3707 lhour=imiss
3708 lminute=imiss
3709
3711 ! TMMGGhhmm
3712 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
3713 !print*,chardate(1:1),ios,ltendaysp
3714 if (ios /= 0)ltendaysp=imiss
3715
3716 read(chardate(2:3),'(i2)',iostat=ios)lmonth
3717 !print*,chardate(2:3),ios,lmonth
3718 if (ios /= 0)lmonth=imiss
3719
3720 read(chardate(4:5),'(i2)',iostat=ios)lday
3721 !print*,chardate(4:5),ios,lday
3722 if (ios /= 0)lday=imiss
3723
3724 read(chardate(6:7),'(i2)',iostat=ios)lhour
3725 !print*,chardate(6:7),ios,lhour
3726 if (ios /= 0)lhour=imiss
3727
3728 read(chardate(8:9),'(i2)',iostat=ios)lminute
3729 !print*,chardate(8:9),ios,lminute
3730 if (ios /= 0)lminute=imiss
3731 end if
3732
3733 this%tendaysp=ltendaysp
3734 this%month=lmonth
3735 this%day=lday
3736 this%hour=lhour
3737 this%minute=lminute
3738else
3739 this%tendaysp=optio_l(tendaysp)
3740 this%month=optio_l(month)
3741 this%day=optio_l(day)
3742 this%hour=optio_l(hour)
3743 this%minute=optio_l(minute)
3744end if
3745
3746END FUNCTION cyclicdatetime_new
3747
3750elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
3751TYPE(cyclicdatetime),INTENT(IN) :: this
3752
3753CHARACTER(len=80) :: char
3754
3757
3758END FUNCTION cyclicdatetime_to_char
3759
3760
3773FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
3774TYPE(cyclicdatetime),INTENT(IN) :: this
3775
3776TYPE(datetime) :: dtc
3777
3778integer :: year,month,day,hour
3779
3780dtc = datetime_miss
3781
3782! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
3784 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
3785 return
3786end if
3787
3788! minute present -> not good for conventional datetime
3790! day, month and tendaysp present -> no good
3792
3794 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
3796 day=(this%tendaysp-1)*10+1
3797 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
3799 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
3801 ! only day present -> no good
3802 return
3803end if
3804
3807 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
3808end if
3809
3810
3811END FUNCTION cyclicdatetime_to_conventional
3812
3813
3814
3815FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
3816TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3817
3818CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
3819
3820char=cyclicdatetime_to_char(in)
3821
3822END FUNCTION trim_cyclicdatetime_to_char
3823
3824
3825
3826SUBROUTINE display_cyclicdatetime(this)
3827TYPE(cyclicdatetime),INTENT(in) :: this
3828
3830
3831end subroutine display_cyclicdatetime
3832
3833
3834#include "array_utilities_inc.F90"
3835
3837
Quick method to append an element to the array. Definition: datetime_class.F90:616 Restituiscono il valore dell'oggetto nella forma desiderata. Definition: datetime_class.F90:322 Costruttori per le classi datetime e timedelta. Definition: datetime_class.F90:311 Method for inserting elements of the array at a desired position. Definition: datetime_class.F90:607 Method for packing the array object reducing at a minimum the memory occupation, without destroying i... Definition: datetime_class.F90:639 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition: datetime_class.F90:478 Method for removing elements of the array at a desired position. Definition: datetime_class.F90:622 Functions that return a trimmed CHARACTER representation of the input variable. Definition: datetime_class.F90:349 Restituiscono il valore dell'oggetto in forma di stringa stampabile. Definition: datetime_class.F90:327 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition: datetime_class.F90:485 Definition of constants to be used for declaring variables of a desired type. Definition: kinds.F90:245 Definitions of constants and functions for working with missing values. Definition: missing_values.f90:50 Module for quickly interpreting the OPTIONAL parameters passed to a subprogram. Definition: optional_values.f90:28 Class for expressing a cyclic datetime. Definition: datetime_class.F90:255 Class for expressing an absolute time value. Definition: datetime_class.F90:233 Class for expressing a relative time interval. Definition: datetime_class.F90:245 |