libsim Versione 7.1.11
|
◆ timedelta_vect_write_unit()
This method writes on a Fortran file unit the contents of the object this. The record can successively be read by the ::read_unit method. The method works both on formatted and unformatted files.
Definizione alla linea 2058 del file datetime_class.F90. 2059! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2060! authors:
2061! Davide Cesari <dcesari@arpa.emr.it>
2062! Paolo Patruno <ppatruno@arpa.emr.it>
2063
2064! This program is free software; you can redistribute it and/or
2065! modify it under the terms of the GNU General Public License as
2066! published by the Free Software Foundation; either version 2 of
2067! the License, or (at your option) any later version.
2068
2069! This program is distributed in the hope that it will be useful,
2070! but WITHOUT ANY WARRANTY; without even the implied warranty of
2071! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2072! GNU General Public License for more details.
2073
2074! You should have received a copy of the GNU General Public License
2075! along with this program. If not, see <http://www.gnu.org/licenses/>.
2076#include "config.h"
2077
2098IMPLICIT NONE
2099
2100INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2101
2104 PRIVATE
2105 INTEGER(KIND=int_ll) :: iminuti
2107
2116 PRIVATE
2117 INTEGER(KIND=int_ll) :: iminuti
2118 INTEGER :: month
2120
2121
2126 PRIVATE
2127 INTEGER :: minute
2128 INTEGER :: hour
2129 INTEGER :: day
2130 INTEGER :: tendaysp
2131 INTEGER :: month
2133
2134
2142INTEGER, PARAMETER :: datetime_utc=1
2144INTEGER, PARAMETER :: datetime_local=2
2154TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2155
2156
2157INTEGER(kind=dateint), PARAMETER :: &
2158 sec_in_day=86400, &
2159 sec_in_hour=3600, &
2160 sec_in_min=60, &
2161 min_in_day=1440, &
2162 min_in_hour=60, &
2163 hour_in_day=24
2164
2165INTEGER,PARAMETER :: &
2166 year0=1, & ! anno di origine per iminuti
2167 d1=365, & ! giorni/1 anno nel calendario gregoriano
2168 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2169 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2170 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2171 ianno(13,2)=reshape((/ &
2172 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2173 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2174
2175INTEGER(KIND=int_ll),PARAMETER :: &
2176 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2177
2182 MODULE PROCEDURE datetime_init, timedelta_init
2183END INTERFACE
2184
2188 MODULE PROCEDURE datetime_delete, timedelta_delete
2189END INTERFACE
2190
2193 MODULE PROCEDURE datetime_getval, timedelta_getval
2194END INTERFACE
2195
2198 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2199END INTERFACE
2200
2201
2220 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2221END INTERFACE
2222
2228INTERFACE OPERATOR (==)
2229 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2230 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2231END INTERFACE
2232
2238INTERFACE OPERATOR (/=)
2239 MODULE PROCEDURE datetime_ne, timedelta_ne
2240END INTERFACE
2241
2249INTERFACE OPERATOR (>)
2250 MODULE PROCEDURE datetime_gt, timedelta_gt
2251END INTERFACE
2252
2260INTERFACE OPERATOR (<)
2261 MODULE PROCEDURE datetime_lt, timedelta_lt
2262END INTERFACE
2263
2271INTERFACE OPERATOR (>=)
2272 MODULE PROCEDURE datetime_ge, timedelta_ge
2273END INTERFACE
2274
2282INTERFACE OPERATOR (<=)
2283 MODULE PROCEDURE datetime_le, timedelta_le
2284END INTERFACE
2285
2292INTERFACE OPERATOR (+)
2293 MODULE PROCEDURE datetime_add, timedelta_add
2294END INTERFACE
2295
2303INTERFACE OPERATOR (-)
2304 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
2305END INTERFACE
2306
2312INTERFACE OPERATOR (*)
2313 MODULE PROCEDURE timedelta_mult, timedelta_tlum
2314END INTERFACE
2315
2322INTERFACE OPERATOR (/)
2323 MODULE PROCEDURE timedelta_divint, timedelta_divtd
2324END INTERFACE
2325
2337 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2338END INTERFACE
2339
2343 MODULE PROCEDURE timedelta_abs
2344END INTERFACE
2345
2349 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2350 timedelta_read_unit, timedelta_vect_read_unit
2351END INTERFACE
2352
2356 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2357 timedelta_write_unit, timedelta_vect_write_unit
2358END INTERFACE
2359
2362 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2363END INTERFACE
2364
2367 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
2368END INTERFACE
2369
2370#undef VOL7D_POLY_TYPE
2371#undef VOL7D_POLY_TYPES
2372#undef ENABLE_SORT
2373#define VOL7D_POLY_TYPE TYPE(datetime)
2374#define VOL7D_POLY_TYPES _datetime
2375#define ENABLE_SORT
2376#include "array_utilities_pre.F90"
2377
2378
2379#define ARRAYOF_ORIGTYPE TYPE(datetime)
2380#define ARRAYOF_TYPE arrayof_datetime
2381#define ARRAYOF_ORIGEQ 1
2382#include "arrayof_pre.F90"
2383! from arrayof
2384
2385PRIVATE
2386
2388 datetime_min, datetime_max, &
2391 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2392 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2394 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2395 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2397 count_distinct, pack_distinct, &
2398 count_distinct_sorted, pack_distinct_sorted, &
2399 count_and_pack_distinct, &
2401 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
2403PUBLIC insert_unique, append_unique
2404PUBLIC cyclicdatetime_to_conventional
2405
2406CONTAINS
2407
2408
2409! ==============
2410! == datetime ==
2411! ==============
2412
2419ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
2420 unixtime, isodate, simpledate) RESULT(this)
2421INTEGER,INTENT(IN),OPTIONAL :: year
2422INTEGER,INTENT(IN),OPTIONAL :: month
2423INTEGER,INTENT(IN),OPTIONAL :: day
2424INTEGER,INTENT(IN),OPTIONAL :: hour
2425INTEGER,INTENT(IN),OPTIONAL :: minute
2426INTEGER,INTENT(IN),OPTIONAL :: msec
2427INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2428CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2429CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2430
2431TYPE(datetime) :: this
2432INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2433CHARACTER(len=23) :: datebuf
2434
2435IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
2436 lyear = year
2437 IF (PRESENT(month)) THEN
2438 lmonth = month
2439 ELSE
2440 lmonth = 1
2441 ENDIF
2442 IF (PRESENT(day)) THEN
2443 lday = day
2444 ELSE
2445 lday = 1
2446 ENDIF
2447 IF (PRESENT(hour)) THEN
2448 lhour = hour
2449 ELSE
2450 lhour = 0
2451 ENDIF
2452 IF (PRESENT(minute)) THEN
2453 lminute = minute
2454 ELSE
2455 lminute = 0
2456 ENDIF
2457 IF (PRESENT(msec)) THEN
2458 lmsec = msec
2459 ELSE
2460 lmsec = 0
2461 ENDIF
2462
2465 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2466 else
2467 this=datetime_miss
2468 end if
2469
2470ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
2472 this%iminuti = (unixtime + unsec)*1000
2473 else
2474 this=datetime_miss
2475 end if
2476
2477ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
2478
2480 datebuf(1:23) = '0001-01-01 00:00:00.000'
2481 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
2482 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
2483 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2484 lmsec = lmsec + lsec*1000
2485 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2486 RETURN
2487
2488100 CONTINUE ! condizione di errore in isodate
2490 RETURN
2491 ELSE
2492 this = datetime_miss
2493 ENDIF
2494
2495ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
2497 datebuf(1:17) = '00010101000000000'
2498 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
2499 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
2500 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2501 lmsec = lmsec + lsec*1000
2502 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2503 RETURN
2504
2505120 CONTINUE ! condizione di errore in simpledate
2507 RETURN
2508 ELSE
2509 this = datetime_miss
2510 ENDIF
2511
2512ELSE
2513 this = datetime_miss
2514ENDIF
2515
2516END FUNCTION datetime_new
2517
2518
2520FUNCTION datetime_new_now(now) RESULT(this)
2521INTEGER,INTENT(IN) :: now
2522TYPE(datetime) :: this
2523
2524INTEGER :: dt(8)
2525
2527 CALL date_and_time(values=dt)
2528 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
2530 msec=dt(7)*1000+dt(8))
2531ELSE
2532 this = datetime_miss
2533ENDIF
2534
2535END FUNCTION datetime_new_now
2536
2537
2544SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
2545 unixtime, isodate, simpledate, now)
2546TYPE(datetime),INTENT(INOUT) :: this
2547INTEGER,INTENT(IN),OPTIONAL :: year
2548INTEGER,INTENT(IN),OPTIONAL :: month
2549INTEGER,INTENT(IN),OPTIONAL :: day
2550INTEGER,INTENT(IN),OPTIONAL :: hour
2551INTEGER,INTENT(IN),OPTIONAL :: minute
2552INTEGER,INTENT(IN),OPTIONAL :: msec
2553INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2554CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2555CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2556INTEGER,INTENT(IN),OPTIONAL :: now
2557
2558IF (PRESENT(now)) THEN
2559 this = datetime_new_now(now)
2560ELSE
2561 this = datetime_new(year, month, day, hour, minute, msec, &
2562 unixtime, isodate, simpledate)
2563ENDIF
2564
2565END SUBROUTINE datetime_init
2566
2567
2568ELEMENTAL SUBROUTINE datetime_delete(this)
2569TYPE(datetime),INTENT(INOUT) :: this
2570
2571this%iminuti = illmiss
2572
2573END SUBROUTINE datetime_delete
2574
2575
2580PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
2581 unixtime, isodate, simpledate, oraclesimdate)
2582TYPE(datetime),INTENT(IN) :: this
2583INTEGER,INTENT(OUT),OPTIONAL :: year
2584INTEGER,INTENT(OUT),OPTIONAL :: month
2585INTEGER,INTENT(OUT),OPTIONAL :: day
2586INTEGER,INTENT(OUT),OPTIONAL :: hour
2587INTEGER,INTENT(OUT),OPTIONAL :: minute
2588INTEGER,INTENT(OUT),OPTIONAL :: msec
2589INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
2590CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
2591CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
2592CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
2593
2594INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2595CHARACTER(len=23) :: datebuf
2596
2597IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
2598 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
2599 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
2600
2601 IF (this == datetime_miss) THEN
2602
2603 IF (PRESENT(msec)) THEN
2604 msec = imiss
2605 ENDIF
2606 IF (PRESENT(minute)) THEN
2607 minute = imiss
2608 ENDIF
2609 IF (PRESENT(hour)) THEN
2610 hour = imiss
2611 ENDIF
2612 IF (PRESENT(day)) THEN
2613 day = imiss
2614 ENDIF
2615 IF (PRESENT(month)) THEN
2616 month = imiss
2617 ENDIF
2618 IF (PRESENT(year)) THEN
2619 year = imiss
2620 ENDIF
2621 IF (PRESENT(isodate)) THEN
2622 isodate = cmiss
2623 ENDIF
2624 IF (PRESENT(simpledate)) THEN
2625 simpledate = cmiss
2626 ENDIF
2627 IF (PRESENT(oraclesimdate)) THEN
2628!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2629!!$ 'obsoleto, usare piuttosto simpledate')
2630 oraclesimdate=cmiss
2631 ENDIF
2632 IF (PRESENT(unixtime)) THEN
2633 unixtime = illmiss
2634 ENDIF
2635
2636 ELSE
2637
2638 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2639 IF (PRESENT(msec)) THEN
2640 msec = lmsec
2641 ENDIF
2642 IF (PRESENT(minute)) THEN
2643 minute = lminute
2644 ENDIF
2645 IF (PRESENT(hour)) THEN
2646 hour = lhour
2647 ENDIF
2648 IF (PRESENT(day)) THEN
2649 day = lday
2650 ENDIF
2651 IF (PRESENT(month)) THEN
2652 month = lmonth
2653 ENDIF
2654 IF (PRESENT(year)) THEN
2655 year = lyear
2656 ENDIF
2657 IF (PRESENT(isodate)) THEN
2658 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
2659 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
2661 isodate = datebuf(1:min(len(isodate),23))
2662 ENDIF
2663 IF (PRESENT(simpledate)) THEN
2664 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
2665 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
2666 simpledate = datebuf(1:min(len(simpledate),17))
2667 ENDIF
2668 IF (PRESENT(oraclesimdate)) THEN
2669!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2670!!$ 'obsoleto, usare piuttosto simpledate')
2671 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
2672 ENDIF
2673 IF (PRESENT(unixtime)) THEN
2674 unixtime = this%iminuti/1000_int_ll-unsec
2675 ENDIF
2676
2677 ENDIF
2678ENDIF
2679
2680END SUBROUTINE datetime_getval
2681
2682
2685elemental FUNCTION datetime_to_char(this) RESULT(char)
2686TYPE(datetime),INTENT(IN) :: this
2687
2688CHARACTER(len=23) :: char
2689
2691
2692END FUNCTION datetime_to_char
2693
2694
2695FUNCTION trim_datetime_to_char(in) RESULT(char)
2696TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
2697
2698CHARACTER(len=len_trim(datetime_to_char(in))) :: char
2699
2700char=datetime_to_char(in)
2701
2702END FUNCTION trim_datetime_to_char
2703
2704
2705
2706SUBROUTINE display_datetime(this)
2707TYPE(datetime),INTENT(in) :: this
2708
2710
2711end subroutine display_datetime
2712
2713
2714
2715SUBROUTINE display_timedelta(this)
2716TYPE(timedelta),INTENT(in) :: this
2717
2719
2720end subroutine display_timedelta
2721
2722
2723
2724ELEMENTAL FUNCTION c_e_datetime(this) result (res)
2725TYPE(datetime),INTENT(in) :: this
2726LOGICAL :: res
2727
2728res = .not. this == datetime_miss
2729
2730end FUNCTION c_e_datetime
2731
2732
2733ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
2734TYPE(datetime),INTENT(IN) :: this, that
2735LOGICAL :: res
2736
2737res = this%iminuti == that%iminuti
2738
2739END FUNCTION datetime_eq
2740
2741
2742ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
2743TYPE(datetime),INTENT(IN) :: this, that
2744LOGICAL :: res
2745
2746res = .NOT.(this == that)
2747
2748END FUNCTION datetime_ne
2749
2750
2751ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
2752TYPE(datetime),INTENT(IN) :: this, that
2753LOGICAL :: res
2754
2755res = this%iminuti > that%iminuti
2756
2757END FUNCTION datetime_gt
2758
2759
2760ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
2761TYPE(datetime),INTENT(IN) :: this, that
2762LOGICAL :: res
2763
2764res = this%iminuti < that%iminuti
2765
2766END FUNCTION datetime_lt
2767
2768
2769ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
2770TYPE(datetime),INTENT(IN) :: this, that
2771LOGICAL :: res
2772
2773IF (this == that) THEN
2774 res = .true.
2775ELSE IF (this > that) THEN
2776 res = .true.
2777ELSE
2778 res = .false.
2779ENDIF
2780
2781END FUNCTION datetime_ge
2782
2783
2784ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
2785TYPE(datetime),INTENT(IN) :: this, that
2786LOGICAL :: res
2787
2788IF (this == that) THEN
2789 res = .true.
2790ELSE IF (this < that) THEN
2791 res = .true.
2792ELSE
2793 res = .false.
2794ENDIF
2795
2796END FUNCTION datetime_le
2797
2798
2799FUNCTION datetime_add(this, that) RESULT(res)
2800TYPE(datetime),INTENT(IN) :: this
2801TYPE(timedelta),INTENT(IN) :: that
2802TYPE(datetime) :: res
2803
2804INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2805
2806IF (this == datetime_miss .OR. that == timedelta_miss) THEN
2807 res = datetime_miss
2808ELSE
2809 res%iminuti = this%iminuti + that%iminuti
2810 IF (that%month /= 0) THEN
2812 minute=lminute, msec=lmsec)
2814 hour=lhour, minute=lminute, msec=lmsec)
2815 ENDIF
2816ENDIF
2817
2818END FUNCTION datetime_add
2819
2820
2821ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
2822TYPE(datetime),INTENT(IN) :: this, that
2823TYPE(timedelta) :: res
2824
2825IF (this == datetime_miss .OR. that == datetime_miss) THEN
2826 res = timedelta_miss
2827ELSE
2828 res%iminuti = this%iminuti - that%iminuti
2829 res%month = 0
2830ENDIF
2831
2832END FUNCTION datetime_subdt
2833
2834
2835FUNCTION datetime_subtd(this, that) RESULT(res)
2836TYPE(datetime),INTENT(IN) :: this
2837TYPE(timedelta),INTENT(IN) :: that
2838TYPE(datetime) :: res
2839
2840INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2841
2842IF (this == datetime_miss .OR. that == timedelta_miss) THEN
2843 res = datetime_miss
2844ELSE
2845 res%iminuti = this%iminuti - that%iminuti
2846 IF (that%month /= 0) THEN
2848 minute=lminute, msec=lmsec)
2850 hour=lhour, minute=lminute, msec=lmsec)
2851 ENDIF
2852ENDIF
2853
2854END FUNCTION datetime_subtd
2855
2856
2861SUBROUTINE datetime_read_unit(this, unit)
2862TYPE(datetime),INTENT(out) :: this
2863INTEGER, INTENT(in) :: unit
2864CALL datetime_vect_read_unit((/this/), unit)
2865
2866END SUBROUTINE datetime_read_unit
2867
2868
2873SUBROUTINE datetime_vect_read_unit(this, unit)
2874TYPE(datetime) :: this(:)
2875INTEGER, INTENT(in) :: unit
2876
2877CHARACTER(len=40) :: form
2878CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
2879INTEGER :: i
2880
2881ALLOCATE(dateiso(SIZE(this)))
2882INQUIRE(unit, form=form)
2883IF (form == 'FORMATTED') THEN
2884 READ(unit,'(A23,1X)')dateiso
2885ELSE
2886 READ(unit)dateiso
2887ENDIF
2888DO i = 1, SIZE(dateiso)
2890ENDDO
2891DEALLOCATE(dateiso)
2892
2893END SUBROUTINE datetime_vect_read_unit
2894
2895
2900SUBROUTINE datetime_write_unit(this, unit)
2901TYPE(datetime),INTENT(in) :: this
2902INTEGER, INTENT(in) :: unit
2903
2904CALL datetime_vect_write_unit((/this/), unit)
2905
2906END SUBROUTINE datetime_write_unit
2907
2908
2913SUBROUTINE datetime_vect_write_unit(this, unit)
2914TYPE(datetime),INTENT(in) :: this(:)
2915INTEGER, INTENT(in) :: unit
2916
2917CHARACTER(len=40) :: form
2918CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
2919INTEGER :: i
2920
2921ALLOCATE(dateiso(SIZE(this)))
2922DO i = 1, SIZE(dateiso)
2924ENDDO
2925INQUIRE(unit, form=form)
2926IF (form == 'FORMATTED') THEN
2927 WRITE(unit,'(A23,1X)')dateiso
2928ELSE
2929 WRITE(unit)dateiso
2930ENDIF
2931DEALLOCATE(dateiso)
2932
2933END SUBROUTINE datetime_vect_write_unit
2934
2935
2936#include "arrayof_post.F90"
2937
2938
2939! ===============
2940! == timedelta ==
2941! ===============
2948FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
2949 isodate, simpledate, oraclesimdate) RESULT (this)
2950INTEGER,INTENT(IN),OPTIONAL :: year
2951INTEGER,INTENT(IN),OPTIONAL :: month
2952INTEGER,INTENT(IN),OPTIONAL :: day
2953INTEGER,INTENT(IN),OPTIONAL :: hour
2954INTEGER,INTENT(IN),OPTIONAL :: minute
2955INTEGER,INTENT(IN),OPTIONAL :: sec
2956INTEGER,INTENT(IN),OPTIONAL :: msec
2957CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2958CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2959CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
2960
2961TYPE(timedelta) :: this
2962
2963CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
2964 isodate, simpledate, oraclesimdate)
2965
2966END FUNCTION timedelta_new
2967
2968
2973SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
2974 isodate, simpledate, oraclesimdate)
2975TYPE(timedelta),INTENT(INOUT) :: this
2976INTEGER,INTENT(IN),OPTIONAL :: year
2977INTEGER,INTENT(IN),OPTIONAL :: month
2978INTEGER,INTENT(IN),OPTIONAL :: day
2979INTEGER,INTENT(IN),OPTIONAL :: hour
2980INTEGER,INTENT(IN),OPTIONAL :: minute
2981INTEGER,INTENT(IN),OPTIONAL :: sec
2982INTEGER,INTENT(IN),OPTIONAL :: msec
2983CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2984CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2985CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
2986
2987INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
2988CHARACTER(len=23) :: datebuf
2989
2990this%month = 0
2991
2992IF (PRESENT(isodate)) THEN
2993 datebuf(1:23) = '0000000000 00:00:00.000'
2994 l = len_trim(isodate)
2995! IF (l > 0) THEN
2997 IF (n > 0) THEN
2998 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
2999 datebuf(12-n:12-n+l-1) = isodate(:l)
3000 ELSE
3001 datebuf(1:l) = isodate(1:l)
3002 ENDIF
3003! ENDIF
3004
3005! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3006 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3007 h, m, s, ms
3008 this%month = lmonth + 12*lyear
3009 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3010 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3011 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3012 RETURN
3013
3014200 CONTINUE ! condizione di errore in isodate
3016 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3017 CALL raise_error()
3018
3019ELSE IF (PRESENT(simpledate)) THEN
3020 datebuf(1:17) = '00000000000000000'
3021 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3022 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3023 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3024 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3025 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3026
3027220 CONTINUE ! condizione di errore in simpledate
3029 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3030 CALL raise_error()
3031 RETURN
3032
3033ELSE IF (PRESENT(oraclesimdate)) THEN
3034 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3035 'obsoleto, usare piuttosto simpledate')
3036 READ(oraclesimdate, '(I8,2I2)')d, h, m
3037 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3038 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3039
3040ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3041 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3042 .and. .not. present(msec) .and. .not. present(isodate) &
3043 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3044
3045 this=timedelta_miss
3046
3047ELSE
3048 this%iminuti = 0
3049 IF (PRESENT(year)) THEN
3051 this%month = this%month + year*12
3052 else
3053 this=timedelta_miss
3054 return
3055 end if
3056 ENDIF
3057 IF (PRESENT(month)) THEN
3059 this%month = this%month + month
3060 else
3061 this=timedelta_miss
3062 return
3063 end if
3064 ENDIF
3065 IF (PRESENT(day)) THEN
3067 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3068 else
3069 this=timedelta_miss
3070 return
3071 end if
3072 ENDIF
3073 IF (PRESENT(hour)) THEN
3075 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3076 else
3077 this=timedelta_miss
3078 return
3079 end if
3080 ENDIF
3081 IF (PRESENT(minute)) THEN
3083 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3084 else
3085 this=timedelta_miss
3086 return
3087 end if
3088 ENDIF
3089 IF (PRESENT(sec)) THEN
3091 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3092 else
3093 this=timedelta_miss
3094 return
3095 end if
3096 ENDIF
3097 IF (PRESENT(msec)) THEN
3099 this%iminuti = this%iminuti + msec
3100 else
3101 this=timedelta_miss
3102 return
3103 end if
3104 ENDIF
3105ENDIF
3106
3107
3108
3109
3110END SUBROUTINE timedelta_init
3111
3112
3113SUBROUTINE timedelta_delete(this)
3114TYPE(timedelta),INTENT(INOUT) :: this
3115
3116this%iminuti = imiss
3117this%month = 0
3118
3119END SUBROUTINE timedelta_delete
3120
3121
3126PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3127 day, hour, minute, sec, msec, &
3128 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3129TYPE(timedelta),INTENT(IN) :: this
3130INTEGER,INTENT(OUT),OPTIONAL :: year
3131INTEGER,INTENT(OUT),OPTIONAL :: month
3132INTEGER,INTENT(OUT),OPTIONAL :: amonth
3133INTEGER,INTENT(OUT),OPTIONAL :: day
3134INTEGER,INTENT(OUT),OPTIONAL :: hour
3135INTEGER,INTENT(OUT),OPTIONAL :: minute
3136INTEGER,INTENT(OUT),OPTIONAL :: sec
3137INTEGER,INTENT(OUT),OPTIONAL :: msec
3138INTEGER,INTENT(OUT),OPTIONAL :: ahour
3139INTEGER,INTENT(OUT),OPTIONAL :: aminute
3140INTEGER,INTENT(OUT),OPTIONAL :: asec
3141INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
3142CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3143CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3144CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3145
3146CHARACTER(len=23) :: datebuf
3147
3148IF (PRESENT(amsec)) THEN
3149 amsec = this%iminuti
3150ENDIF
3151IF (PRESENT(asec)) THEN
3152 asec = int(this%iminuti/1000_int_ll)
3153ENDIF
3154IF (PRESENT(aminute)) THEN
3155 aminute = int(this%iminuti/60000_int_ll)
3156ENDIF
3157IF (PRESENT(ahour)) THEN
3158 ahour = int(this%iminuti/3600000_int_ll)
3159ENDIF
3160IF (PRESENT(msec)) THEN
3161 msec = int(mod(this%iminuti, 1000_int_ll))
3162ENDIF
3163IF (PRESENT(sec)) THEN
3164 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3165ENDIF
3166IF (PRESENT(minute)) THEN
3167 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3168ENDIF
3169IF (PRESENT(hour)) THEN
3170 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3171ENDIF
3172IF (PRESENT(day)) THEN
3173 day = int(this%iminuti/86400000_int_ll)
3174ENDIF
3175IF (PRESENT(amonth)) THEN
3176 amonth = this%month
3177ENDIF
3178IF (PRESENT(month)) THEN
3179 month = mod(this%month-1,12)+1
3180ENDIF
3181IF (PRESENT(year)) THEN
3182 year = this%month/12
3183ENDIF
3184IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3185 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3189 isodate = datebuf(1:min(len(isodate),23))
3190
3191ENDIF
3192IF (PRESENT(simpledate)) THEN
3193 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3194 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3196 mod(this%iminuti, 1000_int_ll)
3197 simpledate = datebuf(1:min(len(simpledate),17))
3198ENDIF
3199IF (PRESENT(oraclesimdate)) THEN
3200!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3201!!$ 'obsoleto, usare piuttosto simpledate')
3202 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3204ENDIF
3205
3206END SUBROUTINE timedelta_getval
3207
3208
3211elemental FUNCTION timedelta_to_char(this) RESULT(char)
3212TYPE(timedelta),INTENT(IN) :: this
3213
3214CHARACTER(len=23) :: char
3215
3217
3218END FUNCTION timedelta_to_char
3219
3220
3221FUNCTION trim_timedelta_to_char(in) RESULT(char)
3222TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3223
3224CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3225
3226char=timedelta_to_char(in)
3227
3228END FUNCTION trim_timedelta_to_char
3229
3230
3232elemental FUNCTION timedelta_getamsec(this)
3233TYPE(timedelta),INTENT(IN) :: this
3234INTEGER(kind=int_ll) :: timedelta_getamsec
3235
3236timedelta_getamsec = this%iminuti
3237
3238END FUNCTION timedelta_getamsec
3239
3240
3246FUNCTION timedelta_depop(this)
3247TYPE(timedelta),INTENT(IN) :: this
3248TYPE(timedelta) :: timedelta_depop
3249
3250TYPE(datetime) :: tmpdt
3251
3252IF (this%month == 0) THEN
3253 timedelta_depop = this
3254ELSE
3255 tmpdt = datetime_new(1970, 1, 1)
3256 timedelta_depop = (tmpdt + this) - tmpdt
3257ENDIF
3258
3259END FUNCTION timedelta_depop
3260
3261
3262elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3263TYPE(timedelta),INTENT(IN) :: this, that
3264LOGICAL :: res
3265
3266res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3267
3268END FUNCTION timedelta_eq
3269
3270
3271ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3272TYPE(timedelta),INTENT(IN) :: this, that
3273LOGICAL :: res
3274
3275res = .NOT.(this == that)
3276
3277END FUNCTION timedelta_ne
3278
3279
3280ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
3281TYPE(timedelta),INTENT(IN) :: this, that
3282LOGICAL :: res
3283
3284res = this%iminuti > that%iminuti
3285
3286END FUNCTION timedelta_gt
3287
3288
3289ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
3290TYPE(timedelta),INTENT(IN) :: this, that
3291LOGICAL :: res
3292
3293res = this%iminuti < that%iminuti
3294
3295END FUNCTION timedelta_lt
3296
3297
3298ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
3299TYPE(timedelta),INTENT(IN) :: this, that
3300LOGICAL :: res
3301
3302IF (this == that) THEN
3303 res = .true.
3304ELSE IF (this > that) THEN
3305 res = .true.
3306ELSE
3307 res = .false.
3308ENDIF
3309
3310END FUNCTION timedelta_ge
3311
3312
3313elemental FUNCTION timedelta_le(this, that) RESULT(res)
3314TYPE(timedelta),INTENT(IN) :: this, that
3315LOGICAL :: res
3316
3317IF (this == that) THEN
3318 res = .true.
3319ELSE IF (this < that) THEN
3320 res = .true.
3321ELSE
3322 res = .false.
3323ENDIF
3324
3325END FUNCTION timedelta_le
3326
3327
3328ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
3329TYPE(timedelta),INTENT(IN) :: this, that
3330TYPE(timedelta) :: res
3331
3332res%iminuti = this%iminuti + that%iminuti
3333res%month = this%month + that%month
3334
3335END FUNCTION timedelta_add
3336
3337
3338ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
3339TYPE(timedelta),INTENT(IN) :: this, that
3340TYPE(timedelta) :: res
3341
3342res%iminuti = this%iminuti - that%iminuti
3343res%month = this%month - that%month
3344
3345END FUNCTION timedelta_sub
3346
3347
3348ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
3349TYPE(timedelta),INTENT(IN) :: this
3350INTEGER,INTENT(IN) :: n
3351TYPE(timedelta) :: res
3352
3353res%iminuti = this%iminuti*n
3354res%month = this%month*n
3355
3356END FUNCTION timedelta_mult
3357
3358
3359ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
3360INTEGER,INTENT(IN) :: n
3361TYPE(timedelta),INTENT(IN) :: this
3362TYPE(timedelta) :: res
3363
3364res%iminuti = this%iminuti*n
3365res%month = this%month*n
3366
3367END FUNCTION timedelta_tlum
3368
3369
3370ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
3371TYPE(timedelta),INTENT(IN) :: this
3372INTEGER,INTENT(IN) :: n
3373TYPE(timedelta) :: res
3374
3375res%iminuti = this%iminuti/n
3376res%month = this%month/n
3377
3378END FUNCTION timedelta_divint
3379
3380
3381ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
3382TYPE(timedelta),INTENT(IN) :: this, that
3383INTEGER :: res
3384
3385res = int(this%iminuti/that%iminuti)
3386
3387END FUNCTION timedelta_divtd
3388
3389
3390elemental FUNCTION timedelta_mod(this, that) RESULT(res)
3391TYPE(timedelta),INTENT(IN) :: this, that
3392TYPE(timedelta) :: res
3393
3394res%iminuti = mod(this%iminuti, that%iminuti)
3395res%month = 0
3396
3397END FUNCTION timedelta_mod
3398
3399
3400ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
3401TYPE(datetime),INTENT(IN) :: this
3402TYPE(timedelta),INTENT(IN) :: that
3403TYPE(timedelta) :: res
3404
3405IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
3406 res = timedelta_0
3407ELSE
3408 res%iminuti = mod(this%iminuti, that%iminuti)
3409 res%month = 0
3410ENDIF
3411
3412END FUNCTION datetime_timedelta_mod
3413
3414
3415ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
3416TYPE(timedelta),INTENT(IN) :: this
3417TYPE(timedelta) :: res
3418
3419res%iminuti = abs(this%iminuti)
3420res%month = abs(this%month)
3421
3422END FUNCTION timedelta_abs
3423
3424
3429SUBROUTINE timedelta_read_unit(this, unit)
3430TYPE(timedelta),INTENT(out) :: this
3431INTEGER, INTENT(in) :: unit
3432
3433CALL timedelta_vect_read_unit((/this/), unit)
3434
3435END SUBROUTINE timedelta_read_unit
3436
3437
3442SUBROUTINE timedelta_vect_read_unit(this, unit)
3443TYPE(timedelta) :: this(:)
3444INTEGER, INTENT(in) :: unit
3445
3446CHARACTER(len=40) :: form
3447CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3448INTEGER :: i
3449
3450ALLOCATE(dateiso(SIZE(this)))
3451INQUIRE(unit, form=form)
3452IF (form == 'FORMATTED') THEN
3453 READ(unit,'(3(A23,1X))')dateiso
3454ELSE
3455 READ(unit)dateiso
3456ENDIF
3457DO i = 1, SIZE(dateiso)
3459ENDDO
3460DEALLOCATE(dateiso)
3461
3462END SUBROUTINE timedelta_vect_read_unit
3463
3464
3469SUBROUTINE timedelta_write_unit(this, unit)
3470TYPE(timedelta),INTENT(in) :: this
3471INTEGER, INTENT(in) :: unit
3472
3473CALL timedelta_vect_write_unit((/this/), unit)
3474
3475END SUBROUTINE timedelta_write_unit
3476
3477
3482SUBROUTINE timedelta_vect_write_unit(this, unit)
3483TYPE(timedelta),INTENT(in) :: this(:)
3484INTEGER, INTENT(in) :: unit
3485
3486CHARACTER(len=40) :: form
3487CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3488INTEGER :: i
3489
3490ALLOCATE(dateiso(SIZE(this)))
3491DO i = 1, SIZE(dateiso)
3493ENDDO
3494INQUIRE(unit, form=form)
3495IF (form == 'FORMATTED') THEN
3496 WRITE(unit,'(3(A23,1X))')dateiso
3497ELSE
3498 WRITE(unit)dateiso
3499ENDIF
3500DEALLOCATE(dateiso)
3501
3502END SUBROUTINE timedelta_vect_write_unit
3503
3504
3505ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
3506TYPE(timedelta),INTENT(in) :: this
3507LOGICAL :: res
3508
3509res = .not. this == timedelta_miss
3510
3511end FUNCTION c_e_timedelta
3512
3513
3514elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
3515
3516!!omstart JELADATA5
3517! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3518! 1 IMINUTI)
3519!
3520! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
3521!
3522! variabili integer*4
3523! IN:
3524! IDAY,IMONTH,IYEAR, I*4
3525! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3526!
3527! OUT:
3528! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3529!!OMEND
3530
3531INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
3532INTEGER,intent(out) :: iminuti
3533
3534iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
3535
3536END SUBROUTINE jeladata5
3537
3538
3539elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
3540INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
3541INTEGER(KIND=int_ll),intent(out) :: imillisec
3542
3543imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
3544 + imsec
3545
3546END SUBROUTINE jeladata5_1
3547
3548
3549
3550elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
3551
3552!!omstart JELADATA6
3553! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3554! 1 IMINUTI)
3555!
3556! Calcola la data e l'ora corrispondente a IMINUTI dopo il
3557! 1/1/1
3558!
3559! variabili integer*4
3560! IN:
3561! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3562!
3563! OUT:
3564! IDAY,IMONTH,IYEAR, I*4
3565! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3566!!OMEND
3567
3568
3569INTEGER,intent(in) :: iminuti
3570INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
3571
3572INTEGER ::igiorno
3573
3574imin = mod(iminuti,60)
3575ihour = mod(iminuti,1440)/60
3576igiorno = iminuti/1440
3578CALL ndyin(igiorno,iday,imonth,iyear)
3579
3580END SUBROUTINE jeladata6
3581
3582
3583elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
3584INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
3585INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
3586
3587INTEGER :: igiorno
3588
3590!imin = MOD(imillisec/60000_int_ll, 60)
3591!ihour = MOD(imillisec/3600000_int_ll, 24)
3592imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
3593ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
3594igiorno = int(imillisec/86400000_int_ll)
3595!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
3596CALL ndyin(igiorno,iday,imonth,iyear)
3597
3598END SUBROUTINE jeladata6_1
3599
3600
3601elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
3602
3603!!OMSTART NDYIN
3604! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
3605! restituisce la data fornendo in input il numero di
3606! giorni dal 1/1/1
3607!
3608!!omend
3609
3610INTEGER,intent(in) :: ndays
3611INTEGER,intent(out) :: igg, imm, iaa
3612integer :: n,lndays
3613
3614lndays=ndays
3615
3616n = lndays/d400
3617lndays = lndays - n*d400
3618iaa = year0 + n*400
3619n = min(lndays/d100, 3)
3620lndays = lndays - n*d100
3621iaa = iaa + n*100
3622n = lndays/d4
3623lndays = lndays - n*d4
3624iaa = iaa + n*4
3625n = min(lndays/d1, 3)
3626lndays = lndays - n*d1
3627iaa = iaa + n
3628n = bisextilis(iaa)
3629DO imm = 1, 12
3630 IF (lndays < ianno(imm+1,n)) EXIT
3631ENDDO
3632igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
3633
3634END SUBROUTINE ndyin
3635
3636
3637integer elemental FUNCTION ndays(igg,imm,iaa)
3638
3639!!OMSTART NDAYS
3640! FUNCTION NDAYS(IGG,IMM,IAA)
3641! restituisce il numero di giorni dal 1/1/1
3642! fornendo in input la data
3643!
3644!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3645! nota bene E' SICURO !!!
3646! un anno e' bisestile se divisibile per 4
3647! un anno rimane bisestile se divisibile per 400
3648! un anno NON e' bisestile se divisibile per 100
3649!
3650!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3651!
3652!!omend
3653
3654INTEGER, intent(in) :: igg, imm, iaa
3655
3656INTEGER :: lmonth, lyear
3657
3658! Limito il mese a [1-12] e correggo l'anno coerentemente
3659lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
3660lyear = iaa + (imm - lmonth)/12
3661ndays = igg+ianno(lmonth, bisextilis(lyear))
3662ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
3663 (lyear-year0)/400
3664
3665END FUNCTION ndays
3666
3667
3668elemental FUNCTION bisextilis(annum)
3669INTEGER,INTENT(in) :: annum
3670INTEGER :: bisextilis
3671
3673 bisextilis = 2
3674ELSE
3675 bisextilis = 1
3676ENDIF
3677END FUNCTION bisextilis
3678
3679
3680ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
3681TYPE(cyclicdatetime),INTENT(IN) :: this, that
3682LOGICAL :: res
3683
3684res = .true.
3685if (this%minute /= that%minute) res=.false.
3686if (this%hour /= that%hour) res=.false.
3687if (this%day /= that%day) res=.false.
3688if (this%month /= that%month) res=.false.
3689if (this%tendaysp /= that%tendaysp) res=.false.
3690
3691END FUNCTION cyclicdatetime_eq
3692
3693
3694ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
3695TYPE(cyclicdatetime),INTENT(IN) :: this
3696TYPE(datetime),INTENT(IN) :: that
3697LOGICAL :: res
3698
3699integer :: minute,hour,day,month
3700
3702
3703res = .true.
3709 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
3710end if
3711
3712END FUNCTION cyclicdatetime_datetime_eq
3713
3714
3715ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
3716TYPE(datetime),INTENT(IN) :: this
3717TYPE(cyclicdatetime),INTENT(IN) :: that
3718LOGICAL :: res
3719
3720integer :: minute,hour,day,month
3721
3723
3724res = .true.
3729
3731 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
3732end if
3733
3734
3735END FUNCTION datetime_cyclicdatetime_eq
3736
3737ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
3738TYPE(cyclicdatetime),INTENT(in) :: this
3739LOGICAL :: res
3740
3741res = .not. this == cyclicdatetime_miss
3742
3743end FUNCTION c_e_cyclicdatetime
3744
3745
3748FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
3749INTEGER,INTENT(IN),OPTIONAL :: tendaysp
3750INTEGER,INTENT(IN),OPTIONAL :: month
3751INTEGER,INTENT(IN),OPTIONAL :: day
3752INTEGER,INTENT(IN),OPTIONAL :: hour
3753INTEGER,INTENT(IN),OPTIONAL :: minute
3754CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
3755
3756integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
3757
3758
3759TYPE(cyclicdatetime) :: this
3760
3761if (present(chardate)) then
3762
3763 ltendaysp=imiss
3764 lmonth=imiss
3765 lday=imiss
3766 lhour=imiss
3767 lminute=imiss
3768
3770 ! TMMGGhhmm
3771 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
3772 !print*,chardate(1:1),ios,ltendaysp
3773 if (ios /= 0)ltendaysp=imiss
3774
3775 read(chardate(2:3),'(i2)',iostat=ios)lmonth
3776 !print*,chardate(2:3),ios,lmonth
3777 if (ios /= 0)lmonth=imiss
3778
3779 read(chardate(4:5),'(i2)',iostat=ios)lday
3780 !print*,chardate(4:5),ios,lday
3781 if (ios /= 0)lday=imiss
3782
3783 read(chardate(6:7),'(i2)',iostat=ios)lhour
3784 !print*,chardate(6:7),ios,lhour
3785 if (ios /= 0)lhour=imiss
3786
3787 read(chardate(8:9),'(i2)',iostat=ios)lminute
3788 !print*,chardate(8:9),ios,lminute
3789 if (ios /= 0)lminute=imiss
3790 end if
3791
3792 this%tendaysp=ltendaysp
3793 this%month=lmonth
3794 this%day=lday
3795 this%hour=lhour
3796 this%minute=lminute
3797else
3798 this%tendaysp=optio_l(tendaysp)
3799 this%month=optio_l(month)
3800 this%day=optio_l(day)
3801 this%hour=optio_l(hour)
3802 this%minute=optio_l(minute)
3803end if
3804
3805END FUNCTION cyclicdatetime_new
3806
3809elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
3810TYPE(cyclicdatetime),INTENT(IN) :: this
3811
3812CHARACTER(len=80) :: char
3813
3816
3817END FUNCTION cyclicdatetime_to_char
3818
3819
3832FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
3833TYPE(cyclicdatetime),INTENT(IN) :: this
3834
3835TYPE(datetime) :: dtc
3836
3837integer :: year,month,day,hour
3838
3839dtc = datetime_miss
3840
3841! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
3843 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
3844 return
3845end if
3846
3847! minute present -> not good for conventional datetime
3849! day, month and tendaysp present -> no good
3851
3853 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
3855 day=(this%tendaysp-1)*10+1
3856 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
3858 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
3860 ! only day present -> no good
3861 return
3862end if
3863
3866 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
3867end if
3868
3869
3870END FUNCTION cyclicdatetime_to_conventional
3871
3872
3873
3874FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
3875TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3876
3877CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
3878
3879char=cyclicdatetime_to_char(in)
3880
3881END FUNCTION trim_cyclicdatetime_to_char
3882
3883
3884
3885SUBROUTINE display_cyclicdatetime(this)
3886TYPE(cyclicdatetime),INTENT(in) :: this
3887
3889
3890end subroutine display_cyclicdatetime
3891
3892
3893#include "array_utilities_inc.F90"
3894
3896
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 |