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