libsim Versione 7.2.4
|
◆ timedelta_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 2039 del file datetime_class.F90. 2040! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2041! authors:
2042! Davide Cesari <dcesari@arpa.emr.it>
2043! Paolo Patruno <ppatruno@arpa.emr.it>
2044
2045! This program is free software; you can redistribute it and/or
2046! modify it under the terms of the GNU General Public License as
2047! published by the Free Software Foundation; either version 2 of
2048! the License, or (at your option) any later version.
2049
2050! This program is distributed in the hope that it will be useful,
2051! but WITHOUT ANY WARRANTY; without even the implied warranty of
2052! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2053! GNU General Public License for more details.
2054
2055! You should have received a copy of the GNU General Public License
2056! along with this program. If not, see <http://www.gnu.org/licenses/>.
2057#include "config.h"
2058
2079IMPLICIT NONE
2080
2081INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2082
2085 PRIVATE
2086 INTEGER(KIND=int_ll) :: iminuti
2088
2097 PRIVATE
2098 INTEGER(KIND=int_ll) :: iminuti
2099 INTEGER :: month
2101
2102
2107 PRIVATE
2108 INTEGER :: minute
2109 INTEGER :: hour
2110 INTEGER :: day
2111 INTEGER :: tendaysp
2112 INTEGER :: month
2114
2115
2123INTEGER, PARAMETER :: datetime_utc=1
2125INTEGER, PARAMETER :: datetime_local=2
2135TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2136
2137
2138INTEGER(kind=dateint), PARAMETER :: &
2139 sec_in_day=86400, &
2140 sec_in_hour=3600, &
2141 sec_in_min=60, &
2142 min_in_day=1440, &
2143 min_in_hour=60, &
2144 hour_in_day=24
2145
2146INTEGER,PARAMETER :: &
2147 year0=1, & ! anno di origine per iminuti
2148 d1=365, & ! giorni/1 anno nel calendario gregoriano
2149 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2150 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2151 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2152 ianno(13,2)=reshape((/ &
2153 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2154 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2155
2156INTEGER(KIND=int_ll),PARAMETER :: &
2157 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2158
2163 MODULE PROCEDURE datetime_init, timedelta_init
2164END INTERFACE
2165
2169 MODULE PROCEDURE datetime_delete, timedelta_delete
2170END INTERFACE
2171
2174 MODULE PROCEDURE datetime_getval, timedelta_getval
2175END INTERFACE
2176
2179 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2180END INTERFACE
2181
2182
2201 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2202END INTERFACE
2203
2209INTERFACE OPERATOR (==)
2210 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2211 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2212END INTERFACE
2213
2219INTERFACE OPERATOR (/=)
2220 MODULE PROCEDURE datetime_ne, timedelta_ne
2221END INTERFACE
2222
2230INTERFACE OPERATOR (>)
2231 MODULE PROCEDURE datetime_gt, timedelta_gt
2232END INTERFACE
2233
2241INTERFACE OPERATOR (<)
2242 MODULE PROCEDURE datetime_lt, timedelta_lt
2243END INTERFACE
2244
2252INTERFACE OPERATOR (>=)
2253 MODULE PROCEDURE datetime_ge, timedelta_ge
2254END INTERFACE
2255
2263INTERFACE OPERATOR (<=)
2264 MODULE PROCEDURE datetime_le, timedelta_le
2265END INTERFACE
2266
2273INTERFACE OPERATOR (+)
2274 MODULE PROCEDURE datetime_add, timedelta_add
2275END INTERFACE
2276
2284INTERFACE OPERATOR (-)
2285 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
2286END INTERFACE
2287
2293INTERFACE OPERATOR (*)
2294 MODULE PROCEDURE timedelta_mult, timedelta_tlum
2295END INTERFACE
2296
2303INTERFACE OPERATOR (/)
2304 MODULE PROCEDURE timedelta_divint, timedelta_divtd
2305END INTERFACE
2306
2318 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2319END INTERFACE
2320
2324 MODULE PROCEDURE timedelta_abs
2325END INTERFACE
2326
2330 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2331 timedelta_read_unit, timedelta_vect_read_unit
2332END INTERFACE
2333
2337 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2338 timedelta_write_unit, timedelta_vect_write_unit
2339END INTERFACE
2340
2343 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2344END INTERFACE
2345
2348 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
2349END INTERFACE
2350
2351#undef VOL7D_POLY_TYPE
2352#undef VOL7D_POLY_TYPES
2353#undef ENABLE_SORT
2354#define VOL7D_POLY_TYPE TYPE(datetime)
2355#define VOL7D_POLY_TYPES _datetime
2356#define ENABLE_SORT
2357#include "array_utilities_pre.F90"
2358
2359
2360#define ARRAYOF_ORIGTYPE TYPE(datetime)
2361#define ARRAYOF_TYPE arrayof_datetime
2362#define ARRAYOF_ORIGEQ 1
2363#include "arrayof_pre.F90"
2364! from arrayof
2365
2366PRIVATE
2367
2369 datetime_min, datetime_max, &
2372 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2373 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2375 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2376 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2378 count_distinct, pack_distinct, &
2379 count_distinct_sorted, pack_distinct_sorted, &
2380 count_and_pack_distinct, &
2382 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
2384PUBLIC insert_unique, append_unique
2385PUBLIC cyclicdatetime_to_conventional
2386
2387CONTAINS
2388
2389
2390! ==============
2391! == datetime ==
2392! ==============
2393
2400ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
2401 unixtime, isodate, simpledate) RESULT(this)
2402INTEGER,INTENT(IN),OPTIONAL :: year
2403INTEGER,INTENT(IN),OPTIONAL :: month
2404INTEGER,INTENT(IN),OPTIONAL :: day
2405INTEGER,INTENT(IN),OPTIONAL :: hour
2406INTEGER,INTENT(IN),OPTIONAL :: minute
2407INTEGER,INTENT(IN),OPTIONAL :: msec
2408INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2409CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2410CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2411
2412TYPE(datetime) :: this
2413INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2414CHARACTER(len=23) :: datebuf
2415
2416IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
2417 lyear = year
2418 IF (PRESENT(month)) THEN
2419 lmonth = month
2420 ELSE
2421 lmonth = 1
2422 ENDIF
2423 IF (PRESENT(day)) THEN
2424 lday = day
2425 ELSE
2426 lday = 1
2427 ENDIF
2428 IF (PRESENT(hour)) THEN
2429 lhour = hour
2430 ELSE
2431 lhour = 0
2432 ENDIF
2433 IF (PRESENT(minute)) THEN
2434 lminute = minute
2435 ELSE
2436 lminute = 0
2437 ENDIF
2438 IF (PRESENT(msec)) THEN
2439 lmsec = msec
2440 ELSE
2441 lmsec = 0
2442 ENDIF
2443
2446 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2447 else
2448 this=datetime_miss
2449 end if
2450
2451ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
2453 this%iminuti = (unixtime + unsec)*1000
2454 else
2455 this=datetime_miss
2456 end if
2457
2458ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
2459
2461 datebuf(1:23) = '0001-01-01 00:00:00.000'
2462 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
2463 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
2464 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2465 lmsec = lmsec + lsec*1000
2466 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2467 RETURN
2468
2469100 CONTINUE ! condizione di errore in isodate
2471 RETURN
2472 ELSE
2473 this = datetime_miss
2474 ENDIF
2475
2476ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
2478 datebuf(1:17) = '00010101000000000'
2479 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
2480 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
2481 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2482 lmsec = lmsec + lsec*1000
2483 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2484 RETURN
2485
2486120 CONTINUE ! condizione di errore in simpledate
2488 RETURN
2489 ELSE
2490 this = datetime_miss
2491 ENDIF
2492
2493ELSE
2494 this = datetime_miss
2495ENDIF
2496
2497END FUNCTION datetime_new
2498
2499
2501FUNCTION datetime_new_now(now) RESULT(this)
2502INTEGER,INTENT(IN) :: now
2503TYPE(datetime) :: this
2504
2505INTEGER :: dt(8)
2506
2508 CALL date_and_time(values=dt)
2509 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
2511 msec=dt(7)*1000+dt(8))
2512ELSE
2513 this = datetime_miss
2514ENDIF
2515
2516END FUNCTION datetime_new_now
2517
2518
2525SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
2526 unixtime, isodate, simpledate, now)
2527TYPE(datetime),INTENT(INOUT) :: this
2528INTEGER,INTENT(IN),OPTIONAL :: year
2529INTEGER,INTENT(IN),OPTIONAL :: month
2530INTEGER,INTENT(IN),OPTIONAL :: day
2531INTEGER,INTENT(IN),OPTIONAL :: hour
2532INTEGER,INTENT(IN),OPTIONAL :: minute
2533INTEGER,INTENT(IN),OPTIONAL :: msec
2534INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
2535CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2536CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2537INTEGER,INTENT(IN),OPTIONAL :: now
2538
2539IF (PRESENT(now)) THEN
2540 this = datetime_new_now(now)
2541ELSE
2542 this = datetime_new(year, month, day, hour, minute, msec, &
2543 unixtime, isodate, simpledate)
2544ENDIF
2545
2546END SUBROUTINE datetime_init
2547
2548
2549ELEMENTAL SUBROUTINE datetime_delete(this)
2550TYPE(datetime),INTENT(INOUT) :: this
2551
2552this%iminuti = illmiss
2553
2554END SUBROUTINE datetime_delete
2555
2556
2561PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
2562 unixtime, isodate, simpledate, oraclesimdate)
2563TYPE(datetime),INTENT(IN) :: this
2564INTEGER,INTENT(OUT),OPTIONAL :: year
2565INTEGER,INTENT(OUT),OPTIONAL :: month
2566INTEGER,INTENT(OUT),OPTIONAL :: day
2567INTEGER,INTENT(OUT),OPTIONAL :: hour
2568INTEGER,INTENT(OUT),OPTIONAL :: minute
2569INTEGER,INTENT(OUT),OPTIONAL :: msec
2570INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
2571CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
2572CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
2573CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
2574
2575INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2576CHARACTER(len=23) :: datebuf
2577
2578IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
2579 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
2580 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
2581
2582 IF (this == datetime_miss) THEN
2583
2584 IF (PRESENT(msec)) THEN
2585 msec = imiss
2586 ENDIF
2587 IF (PRESENT(minute)) THEN
2588 minute = imiss
2589 ENDIF
2590 IF (PRESENT(hour)) THEN
2591 hour = imiss
2592 ENDIF
2593 IF (PRESENT(day)) THEN
2594 day = imiss
2595 ENDIF
2596 IF (PRESENT(month)) THEN
2597 month = imiss
2598 ENDIF
2599 IF (PRESENT(year)) THEN
2600 year = imiss
2601 ENDIF
2602 IF (PRESENT(isodate)) THEN
2603 isodate = cmiss
2604 ENDIF
2605 IF (PRESENT(simpledate)) THEN
2606 simpledate = cmiss
2607 ENDIF
2608 IF (PRESENT(oraclesimdate)) THEN
2609!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2610!!$ 'obsoleto, usare piuttosto simpledate')
2611 oraclesimdate=cmiss
2612 ENDIF
2613 IF (PRESENT(unixtime)) THEN
2614 unixtime = illmiss
2615 ENDIF
2616
2617 ELSE
2618
2619 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2620 IF (PRESENT(msec)) THEN
2621 msec = lmsec
2622 ENDIF
2623 IF (PRESENT(minute)) THEN
2624 minute = lminute
2625 ENDIF
2626 IF (PRESENT(hour)) THEN
2627 hour = lhour
2628 ENDIF
2629 IF (PRESENT(day)) THEN
2630 day = lday
2631 ENDIF
2632 IF (PRESENT(month)) THEN
2633 month = lmonth
2634 ENDIF
2635 IF (PRESENT(year)) THEN
2636 year = lyear
2637 ENDIF
2638 IF (PRESENT(isodate)) THEN
2639 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
2640 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
2642 isodate = datebuf(1:min(len(isodate),23))
2643 ENDIF
2644 IF (PRESENT(simpledate)) THEN
2645 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
2646 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
2647 simpledate = datebuf(1:min(len(simpledate),17))
2648 ENDIF
2649 IF (PRESENT(oraclesimdate)) THEN
2650!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2651!!$ 'obsoleto, usare piuttosto simpledate')
2652 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
2653 ENDIF
2654 IF (PRESENT(unixtime)) THEN
2655 unixtime = this%iminuti/1000_int_ll-unsec
2656 ENDIF
2657
2658 ENDIF
2659ENDIF
2660
2661END SUBROUTINE datetime_getval
2662
2663
2666elemental FUNCTION datetime_to_char(this) RESULT(char)
2667TYPE(datetime),INTENT(IN) :: this
2668
2669CHARACTER(len=23) :: char
2670
2672
2673END FUNCTION datetime_to_char
2674
2675
2676FUNCTION trim_datetime_to_char(in) RESULT(char)
2677TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
2678
2679CHARACTER(len=len_trim(datetime_to_char(in))) :: char
2680
2681char=datetime_to_char(in)
2682
2683END FUNCTION trim_datetime_to_char
2684
2685
2686
2687SUBROUTINE display_datetime(this)
2688TYPE(datetime),INTENT(in) :: this
2689
2691
2692end subroutine display_datetime
2693
2694
2695
2696SUBROUTINE display_timedelta(this)
2697TYPE(timedelta),INTENT(in) :: this
2698
2700
2701end subroutine display_timedelta
2702
2703
2704
2705ELEMENTAL FUNCTION c_e_datetime(this) result (res)
2706TYPE(datetime),INTENT(in) :: this
2707LOGICAL :: res
2708
2709res = .not. this == datetime_miss
2710
2711end FUNCTION c_e_datetime
2712
2713
2714ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
2715TYPE(datetime),INTENT(IN) :: this, that
2716LOGICAL :: res
2717
2718res = this%iminuti == that%iminuti
2719
2720END FUNCTION datetime_eq
2721
2722
2723ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
2724TYPE(datetime),INTENT(IN) :: this, that
2725LOGICAL :: res
2726
2727res = .NOT.(this == that)
2728
2729END FUNCTION datetime_ne
2730
2731
2732ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
2733TYPE(datetime),INTENT(IN) :: this, that
2734LOGICAL :: res
2735
2736res = this%iminuti > that%iminuti
2737
2738END FUNCTION datetime_gt
2739
2740
2741ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
2742TYPE(datetime),INTENT(IN) :: this, that
2743LOGICAL :: res
2744
2745res = this%iminuti < that%iminuti
2746
2747END FUNCTION datetime_lt
2748
2749
2750ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
2751TYPE(datetime),INTENT(IN) :: this, that
2752LOGICAL :: res
2753
2754IF (this == that) THEN
2755 res = .true.
2756ELSE IF (this > that) THEN
2757 res = .true.
2758ELSE
2759 res = .false.
2760ENDIF
2761
2762END FUNCTION datetime_ge
2763
2764
2765ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
2766TYPE(datetime),INTENT(IN) :: this, that
2767LOGICAL :: res
2768
2769IF (this == that) THEN
2770 res = .true.
2771ELSE IF (this < that) THEN
2772 res = .true.
2773ELSE
2774 res = .false.
2775ENDIF
2776
2777END FUNCTION datetime_le
2778
2779
2780FUNCTION datetime_add(this, that) RESULT(res)
2781TYPE(datetime),INTENT(IN) :: this
2782TYPE(timedelta),INTENT(IN) :: that
2783TYPE(datetime) :: res
2784
2785INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2786
2787IF (this == datetime_miss .OR. that == timedelta_miss) THEN
2788 res = datetime_miss
2789ELSE
2790 res%iminuti = this%iminuti + that%iminuti
2791 IF (that%month /= 0) THEN
2793 minute=lminute, msec=lmsec)
2795 hour=lhour, minute=lminute, msec=lmsec)
2796 ENDIF
2797ENDIF
2798
2799END FUNCTION datetime_add
2800
2801
2802ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
2803TYPE(datetime),INTENT(IN) :: this, that
2804TYPE(timedelta) :: res
2805
2806IF (this == datetime_miss .OR. that == datetime_miss) THEN
2807 res = timedelta_miss
2808ELSE
2809 res%iminuti = this%iminuti - that%iminuti
2810 res%month = 0
2811ENDIF
2812
2813END FUNCTION datetime_subdt
2814
2815
2816FUNCTION datetime_subtd(this, that) RESULT(res)
2817TYPE(datetime),INTENT(IN) :: this
2818TYPE(timedelta),INTENT(IN) :: that
2819TYPE(datetime) :: res
2820
2821INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2822
2823IF (this == datetime_miss .OR. that == timedelta_miss) THEN
2824 res = datetime_miss
2825ELSE
2826 res%iminuti = this%iminuti - that%iminuti
2827 IF (that%month /= 0) THEN
2829 minute=lminute, msec=lmsec)
2831 hour=lhour, minute=lminute, msec=lmsec)
2832 ENDIF
2833ENDIF
2834
2835END FUNCTION datetime_subtd
2836
2837
2842SUBROUTINE datetime_read_unit(this, unit)
2843TYPE(datetime),INTENT(out) :: this
2844INTEGER, INTENT(in) :: unit
2845CALL datetime_vect_read_unit((/this/), unit)
2846
2847END SUBROUTINE datetime_read_unit
2848
2849
2854SUBROUTINE datetime_vect_read_unit(this, unit)
2855TYPE(datetime) :: this(:)
2856INTEGER, INTENT(in) :: unit
2857
2858CHARACTER(len=40) :: form
2859CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
2860INTEGER :: i
2861
2862ALLOCATE(dateiso(SIZE(this)))
2863INQUIRE(unit, form=form)
2864IF (form == 'FORMATTED') THEN
2865 READ(unit,'(A23,1X)')dateiso
2866ELSE
2867 READ(unit)dateiso
2868ENDIF
2869DO i = 1, SIZE(dateiso)
2871ENDDO
2872DEALLOCATE(dateiso)
2873
2874END SUBROUTINE datetime_vect_read_unit
2875
2876
2881SUBROUTINE datetime_write_unit(this, unit)
2882TYPE(datetime),INTENT(in) :: this
2883INTEGER, INTENT(in) :: unit
2884
2885CALL datetime_vect_write_unit((/this/), unit)
2886
2887END SUBROUTINE datetime_write_unit
2888
2889
2894SUBROUTINE datetime_vect_write_unit(this, unit)
2895TYPE(datetime),INTENT(in) :: this(:)
2896INTEGER, INTENT(in) :: unit
2897
2898CHARACTER(len=40) :: form
2899CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
2900INTEGER :: i
2901
2902ALLOCATE(dateiso(SIZE(this)))
2903DO i = 1, SIZE(dateiso)
2905ENDDO
2906INQUIRE(unit, form=form)
2907IF (form == 'FORMATTED') THEN
2908 WRITE(unit,'(A23,1X)')dateiso
2909ELSE
2910 WRITE(unit)dateiso
2911ENDIF
2912DEALLOCATE(dateiso)
2913
2914END SUBROUTINE datetime_vect_write_unit
2915
2916
2917#include "arrayof_post.F90"
2918
2919
2920! ===============
2921! == timedelta ==
2922! ===============
2929FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
2930 isodate, simpledate, oraclesimdate) RESULT (this)
2931INTEGER,INTENT(IN),OPTIONAL :: year
2932INTEGER,INTENT(IN),OPTIONAL :: month
2933INTEGER,INTENT(IN),OPTIONAL :: day
2934INTEGER,INTENT(IN),OPTIONAL :: hour
2935INTEGER,INTENT(IN),OPTIONAL :: minute
2936INTEGER,INTENT(IN),OPTIONAL :: sec
2937INTEGER,INTENT(IN),OPTIONAL :: msec
2938CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2939CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2940CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
2941
2942TYPE(timedelta) :: this
2943
2944CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
2945 isodate, simpledate, oraclesimdate)
2946
2947END FUNCTION timedelta_new
2948
2949
2954SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
2955 isodate, simpledate, oraclesimdate)
2956TYPE(timedelta),INTENT(INOUT) :: this
2957INTEGER,INTENT(IN),OPTIONAL :: year
2958INTEGER,INTENT(IN),OPTIONAL :: month
2959INTEGER,INTENT(IN),OPTIONAL :: day
2960INTEGER,INTENT(IN),OPTIONAL :: hour
2961INTEGER,INTENT(IN),OPTIONAL :: minute
2962INTEGER,INTENT(IN),OPTIONAL :: sec
2963INTEGER,INTENT(IN),OPTIONAL :: msec
2964CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
2965CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
2966CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
2967
2968INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
2969CHARACTER(len=23) :: datebuf
2970
2971this%month = 0
2972
2973IF (PRESENT(isodate)) THEN
2974 datebuf(1:23) = '0000000000 00:00:00.000'
2975 l = len_trim(isodate)
2976! IF (l > 0) THEN
2978 IF (n > 0) THEN
2979 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
2980 datebuf(12-n:12-n+l-1) = isodate(:l)
2981 ELSE
2982 datebuf(1:l) = isodate(1:l)
2983 ENDIF
2984! ENDIF
2985
2986! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
2987 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
2988 h, m, s, ms
2989 this%month = lmonth + 12*lyear
2990 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
2991 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
2992 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
2993 RETURN
2994
2995200 CONTINUE ! condizione di errore in isodate
2997 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
2998 CALL raise_error()
2999
3000ELSE IF (PRESENT(simpledate)) THEN
3001 datebuf(1:17) = '00000000000000000'
3002 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3003 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3004 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3005 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3006 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3007
3008220 CONTINUE ! condizione di errore in simpledate
3010 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3011 CALL raise_error()
3012 RETURN
3013
3014ELSE IF (PRESENT(oraclesimdate)) THEN
3015 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3016 'obsoleto, usare piuttosto simpledate')
3017 READ(oraclesimdate, '(I8,2I2)')d, h, m
3018 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3019 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3020
3021ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3022 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3023 .and. .not. present(msec) .and. .not. present(isodate) &
3024 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3025
3026 this=timedelta_miss
3027
3028ELSE
3029 this%iminuti = 0
3030 IF (PRESENT(year)) THEN
3032 this%month = this%month + year*12
3033 else
3034 this=timedelta_miss
3035 return
3036 end if
3037 ENDIF
3038 IF (PRESENT(month)) THEN
3040 this%month = this%month + month
3041 else
3042 this=timedelta_miss
3043 return
3044 end if
3045 ENDIF
3046 IF (PRESENT(day)) THEN
3048 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3049 else
3050 this=timedelta_miss
3051 return
3052 end if
3053 ENDIF
3054 IF (PRESENT(hour)) THEN
3056 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3057 else
3058 this=timedelta_miss
3059 return
3060 end if
3061 ENDIF
3062 IF (PRESENT(minute)) THEN
3064 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3065 else
3066 this=timedelta_miss
3067 return
3068 end if
3069 ENDIF
3070 IF (PRESENT(sec)) THEN
3072 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3073 else
3074 this=timedelta_miss
3075 return
3076 end if
3077 ENDIF
3078 IF (PRESENT(msec)) THEN
3080 this%iminuti = this%iminuti + msec
3081 else
3082 this=timedelta_miss
3083 return
3084 end if
3085 ENDIF
3086ENDIF
3087
3088
3089
3090
3091END SUBROUTINE timedelta_init
3092
3093
3094SUBROUTINE timedelta_delete(this)
3095TYPE(timedelta),INTENT(INOUT) :: this
3096
3097this%iminuti = imiss
3098this%month = 0
3099
3100END SUBROUTINE timedelta_delete
3101
3102
3107PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3108 day, hour, minute, sec, msec, &
3109 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3110TYPE(timedelta),INTENT(IN) :: this
3111INTEGER,INTENT(OUT),OPTIONAL :: year
3112INTEGER,INTENT(OUT),OPTIONAL :: month
3113INTEGER,INTENT(OUT),OPTIONAL :: amonth
3114INTEGER,INTENT(OUT),OPTIONAL :: day
3115INTEGER,INTENT(OUT),OPTIONAL :: hour
3116INTEGER,INTENT(OUT),OPTIONAL :: minute
3117INTEGER,INTENT(OUT),OPTIONAL :: sec
3118INTEGER,INTENT(OUT),OPTIONAL :: msec
3119INTEGER,INTENT(OUT),OPTIONAL :: ahour
3120INTEGER,INTENT(OUT),OPTIONAL :: aminute
3121INTEGER,INTENT(OUT),OPTIONAL :: asec
3122INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
3123CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3124CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3125CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3126
3127CHARACTER(len=23) :: datebuf
3128
3129IF (PRESENT(amsec)) THEN
3130 amsec = this%iminuti
3131ENDIF
3132IF (PRESENT(asec)) THEN
3133 asec = int(this%iminuti/1000_int_ll)
3134ENDIF
3135IF (PRESENT(aminute)) THEN
3136 aminute = int(this%iminuti/60000_int_ll)
3137ENDIF
3138IF (PRESENT(ahour)) THEN
3139 ahour = int(this%iminuti/3600000_int_ll)
3140ENDIF
3141IF (PRESENT(msec)) THEN
3142 msec = int(mod(this%iminuti, 1000_int_ll))
3143ENDIF
3144IF (PRESENT(sec)) THEN
3145 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3146ENDIF
3147IF (PRESENT(minute)) THEN
3148 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3149ENDIF
3150IF (PRESENT(hour)) THEN
3151 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3152ENDIF
3153IF (PRESENT(day)) THEN
3154 day = int(this%iminuti/86400000_int_ll)
3155ENDIF
3156IF (PRESENT(amonth)) THEN
3157 amonth = this%month
3158ENDIF
3159IF (PRESENT(month)) THEN
3160 month = mod(this%month-1,12)+1
3161ENDIF
3162IF (PRESENT(year)) THEN
3163 year = this%month/12
3164ENDIF
3165IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3166 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3170 isodate = datebuf(1:min(len(isodate),23))
3171
3172ENDIF
3173IF (PRESENT(simpledate)) THEN
3174 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3175 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3177 mod(this%iminuti, 1000_int_ll)
3178 simpledate = datebuf(1:min(len(simpledate),17))
3179ENDIF
3180IF (PRESENT(oraclesimdate)) THEN
3181!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3182!!$ 'obsoleto, usare piuttosto simpledate')
3183 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3185ENDIF
3186
3187END SUBROUTINE timedelta_getval
3188
3189
3192elemental FUNCTION timedelta_to_char(this) RESULT(char)
3193TYPE(timedelta),INTENT(IN) :: this
3194
3195CHARACTER(len=23) :: char
3196
3198
3199END FUNCTION timedelta_to_char
3200
3201
3202FUNCTION trim_timedelta_to_char(in) RESULT(char)
3203TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3204
3205CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3206
3207char=timedelta_to_char(in)
3208
3209END FUNCTION trim_timedelta_to_char
3210
3211
3213elemental FUNCTION timedelta_getamsec(this)
3214TYPE(timedelta),INTENT(IN) :: this
3215INTEGER(kind=int_ll) :: timedelta_getamsec
3216
3217timedelta_getamsec = this%iminuti
3218
3219END FUNCTION timedelta_getamsec
3220
3221
3227FUNCTION timedelta_depop(this)
3228TYPE(timedelta),INTENT(IN) :: this
3229TYPE(timedelta) :: timedelta_depop
3230
3231TYPE(datetime) :: tmpdt
3232
3233IF (this%month == 0) THEN
3234 timedelta_depop = this
3235ELSE
3236 tmpdt = datetime_new(1970, 1, 1)
3237 timedelta_depop = (tmpdt + this) - tmpdt
3238ENDIF
3239
3240END FUNCTION timedelta_depop
3241
3242
3243elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3244TYPE(timedelta),INTENT(IN) :: this, that
3245LOGICAL :: res
3246
3247res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3248
3249END FUNCTION timedelta_eq
3250
3251
3252ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3253TYPE(timedelta),INTENT(IN) :: this, that
3254LOGICAL :: res
3255
3256res = .NOT.(this == that)
3257
3258END FUNCTION timedelta_ne
3259
3260
3261ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
3262TYPE(timedelta),INTENT(IN) :: this, that
3263LOGICAL :: res
3264
3265res = this%iminuti > that%iminuti
3266
3267END FUNCTION timedelta_gt
3268
3269
3270ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
3271TYPE(timedelta),INTENT(IN) :: this, that
3272LOGICAL :: res
3273
3274res = this%iminuti < that%iminuti
3275
3276END FUNCTION timedelta_lt
3277
3278
3279ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
3280TYPE(timedelta),INTENT(IN) :: this, that
3281LOGICAL :: res
3282
3283IF (this == that) THEN
3284 res = .true.
3285ELSE IF (this > that) THEN
3286 res = .true.
3287ELSE
3288 res = .false.
3289ENDIF
3290
3291END FUNCTION timedelta_ge
3292
3293
3294elemental FUNCTION timedelta_le(this, that) RESULT(res)
3295TYPE(timedelta),INTENT(IN) :: this, that
3296LOGICAL :: res
3297
3298IF (this == that) THEN
3299 res = .true.
3300ELSE IF (this < that) THEN
3301 res = .true.
3302ELSE
3303 res = .false.
3304ENDIF
3305
3306END FUNCTION timedelta_le
3307
3308
3309ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
3310TYPE(timedelta),INTENT(IN) :: this, that
3311TYPE(timedelta) :: res
3312
3313res%iminuti = this%iminuti + that%iminuti
3314res%month = this%month + that%month
3315
3316END FUNCTION timedelta_add
3317
3318
3319ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
3320TYPE(timedelta),INTENT(IN) :: this, that
3321TYPE(timedelta) :: res
3322
3323res%iminuti = this%iminuti - that%iminuti
3324res%month = this%month - that%month
3325
3326END FUNCTION timedelta_sub
3327
3328
3329ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
3330TYPE(timedelta),INTENT(IN) :: this
3331INTEGER,INTENT(IN) :: n
3332TYPE(timedelta) :: res
3333
3334res%iminuti = this%iminuti*n
3335res%month = this%month*n
3336
3337END FUNCTION timedelta_mult
3338
3339
3340ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
3341INTEGER,INTENT(IN) :: n
3342TYPE(timedelta),INTENT(IN) :: this
3343TYPE(timedelta) :: res
3344
3345res%iminuti = this%iminuti*n
3346res%month = this%month*n
3347
3348END FUNCTION timedelta_tlum
3349
3350
3351ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
3352TYPE(timedelta),INTENT(IN) :: this
3353INTEGER,INTENT(IN) :: n
3354TYPE(timedelta) :: res
3355
3356res%iminuti = this%iminuti/n
3357res%month = this%month/n
3358
3359END FUNCTION timedelta_divint
3360
3361
3362ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
3363TYPE(timedelta),INTENT(IN) :: this, that
3364INTEGER :: res
3365
3366res = int(this%iminuti/that%iminuti)
3367
3368END FUNCTION timedelta_divtd
3369
3370
3371elemental FUNCTION timedelta_mod(this, that) RESULT(res)
3372TYPE(timedelta),INTENT(IN) :: this, that
3373TYPE(timedelta) :: res
3374
3375res%iminuti = mod(this%iminuti, that%iminuti)
3376res%month = 0
3377
3378END FUNCTION timedelta_mod
3379
3380
3381ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
3382TYPE(datetime),INTENT(IN) :: this
3383TYPE(timedelta),INTENT(IN) :: that
3384TYPE(timedelta) :: res
3385
3386IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
3387 res = timedelta_0
3388ELSE
3389 res%iminuti = mod(this%iminuti, that%iminuti)
3390 res%month = 0
3391ENDIF
3392
3393END FUNCTION datetime_timedelta_mod
3394
3395
3396ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
3397TYPE(timedelta),INTENT(IN) :: this
3398TYPE(timedelta) :: res
3399
3400res%iminuti = abs(this%iminuti)
3401res%month = abs(this%month)
3402
3403END FUNCTION timedelta_abs
3404
3405
3410SUBROUTINE timedelta_read_unit(this, unit)
3411TYPE(timedelta),INTENT(out) :: this
3412INTEGER, INTENT(in) :: unit
3413
3414CALL timedelta_vect_read_unit((/this/), unit)
3415
3416END SUBROUTINE timedelta_read_unit
3417
3418
3423SUBROUTINE timedelta_vect_read_unit(this, unit)
3424TYPE(timedelta) :: this(:)
3425INTEGER, INTENT(in) :: unit
3426
3427CHARACTER(len=40) :: form
3428CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3429INTEGER :: i
3430
3431ALLOCATE(dateiso(SIZE(this)))
3432INQUIRE(unit, form=form)
3433IF (form == 'FORMATTED') THEN
3434 READ(unit,'(3(A23,1X))')dateiso
3435ELSE
3436 READ(unit)dateiso
3437ENDIF
3438DO i = 1, SIZE(dateiso)
3440ENDDO
3441DEALLOCATE(dateiso)
3442
3443END SUBROUTINE timedelta_vect_read_unit
3444
3445
3450SUBROUTINE timedelta_write_unit(this, unit)
3451TYPE(timedelta),INTENT(in) :: this
3452INTEGER, INTENT(in) :: unit
3453
3454CALL timedelta_vect_write_unit((/this/), unit)
3455
3456END SUBROUTINE timedelta_write_unit
3457
3458
3463SUBROUTINE timedelta_vect_write_unit(this, unit)
3464TYPE(timedelta),INTENT(in) :: this(:)
3465INTEGER, INTENT(in) :: unit
3466
3467CHARACTER(len=40) :: form
3468CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3469INTEGER :: i
3470
3471ALLOCATE(dateiso(SIZE(this)))
3472DO i = 1, SIZE(dateiso)
3474ENDDO
3475INQUIRE(unit, form=form)
3476IF (form == 'FORMATTED') THEN
3477 WRITE(unit,'(3(A23,1X))')dateiso
3478ELSE
3479 WRITE(unit)dateiso
3480ENDIF
3481DEALLOCATE(dateiso)
3482
3483END SUBROUTINE timedelta_vect_write_unit
3484
3485
3486ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
3487TYPE(timedelta),INTENT(in) :: this
3488LOGICAL :: res
3489
3490res = .not. this == timedelta_miss
3491
3492end FUNCTION c_e_timedelta
3493
3494
3495elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
3496
3497!!omstart JELADATA5
3498! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3499! 1 IMINUTI)
3500!
3501! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
3502!
3503! variabili integer*4
3504! IN:
3505! IDAY,IMONTH,IYEAR, I*4
3506! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3507!
3508! OUT:
3509! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3510!!OMEND
3511
3512INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
3513INTEGER,intent(out) :: iminuti
3514
3515iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
3516
3517END SUBROUTINE jeladata5
3518
3519
3520elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
3521INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
3522INTEGER(KIND=int_ll),intent(out) :: imillisec
3523
3524imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
3525 + imsec
3526
3527END SUBROUTINE jeladata5_1
3528
3529
3530
3531elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
3532
3533!!omstart JELADATA6
3534! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3535! 1 IMINUTI)
3536!
3537! Calcola la data e l'ora corrispondente a IMINUTI dopo il
3538! 1/1/1
3539!
3540! variabili integer*4
3541! IN:
3542! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3543!
3544! OUT:
3545! IDAY,IMONTH,IYEAR, I*4
3546! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3547!!OMEND
3548
3549
3550INTEGER,intent(in) :: iminuti
3551INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
3552
3553INTEGER ::igiorno
3554
3555imin = mod(iminuti,60)
3556ihour = mod(iminuti,1440)/60
3557igiorno = iminuti/1440
3559CALL ndyin(igiorno,iday,imonth,iyear)
3560
3561END SUBROUTINE jeladata6
3562
3563
3564elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
3565INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
3566INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
3567
3568INTEGER :: igiorno
3569
3571!imin = MOD(imillisec/60000_int_ll, 60)
3572!ihour = MOD(imillisec/3600000_int_ll, 24)
3573imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
3574ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
3575igiorno = int(imillisec/86400000_int_ll)
3576!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
3577CALL ndyin(igiorno,iday,imonth,iyear)
3578
3579END SUBROUTINE jeladata6_1
3580
3581
3582elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
3583
3584!!OMSTART NDYIN
3585! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
3586! restituisce la data fornendo in input il numero di
3587! giorni dal 1/1/1
3588!
3589!!omend
3590
3591INTEGER,intent(in) :: ndays
3592INTEGER,intent(out) :: igg, imm, iaa
3593integer :: n,lndays
3594
3595lndays=ndays
3596
3597n = lndays/d400
3598lndays = lndays - n*d400
3599iaa = year0 + n*400
3600n = min(lndays/d100, 3)
3601lndays = lndays - n*d100
3602iaa = iaa + n*100
3603n = lndays/d4
3604lndays = lndays - n*d4
3605iaa = iaa + n*4
3606n = min(lndays/d1, 3)
3607lndays = lndays - n*d1
3608iaa = iaa + n
3609n = bisextilis(iaa)
3610DO imm = 1, 12
3611 IF (lndays < ianno(imm+1,n)) EXIT
3612ENDDO
3613igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
3614
3615END SUBROUTINE ndyin
3616
3617
3618integer elemental FUNCTION ndays(igg,imm,iaa)
3619
3620!!OMSTART NDAYS
3621! FUNCTION NDAYS(IGG,IMM,IAA)
3622! restituisce il numero di giorni dal 1/1/1
3623! fornendo in input la data
3624!
3625!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3626! nota bene E' SICURO !!!
3627! un anno e' bisestile se divisibile per 4
3628! un anno rimane bisestile se divisibile per 400
3629! un anno NON e' bisestile se divisibile per 100
3630!
3631!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3632!
3633!!omend
3634
3635INTEGER, intent(in) :: igg, imm, iaa
3636
3637INTEGER :: lmonth, lyear
3638
3639! Limito il mese a [1-12] e correggo l'anno coerentemente
3640lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
3641lyear = iaa + (imm - lmonth)/12
3642ndays = igg+ianno(lmonth, bisextilis(lyear))
3643ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
3644 (lyear-year0)/400
3645
3646END FUNCTION ndays
3647
3648
3649elemental FUNCTION bisextilis(annum)
3650INTEGER,INTENT(in) :: annum
3651INTEGER :: bisextilis
3652
3654 bisextilis = 2
3655ELSE
3656 bisextilis = 1
3657ENDIF
3658END FUNCTION bisextilis
3659
3660
3661ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
3662TYPE(cyclicdatetime),INTENT(IN) :: this, that
3663LOGICAL :: res
3664
3665res = .true.
3666if (this%minute /= that%minute) res=.false.
3667if (this%hour /= that%hour) res=.false.
3668if (this%day /= that%day) res=.false.
3669if (this%month /= that%month) res=.false.
3670if (this%tendaysp /= that%tendaysp) res=.false.
3671
3672END FUNCTION cyclicdatetime_eq
3673
3674
3675ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
3676TYPE(cyclicdatetime),INTENT(IN) :: this
3677TYPE(datetime),INTENT(IN) :: that
3678LOGICAL :: res
3679
3680integer :: minute,hour,day,month
3681
3683
3684res = .true.
3690 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
3691end if
3692
3693END FUNCTION cyclicdatetime_datetime_eq
3694
3695
3696ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
3697TYPE(datetime),INTENT(IN) :: this
3698TYPE(cyclicdatetime),INTENT(IN) :: that
3699LOGICAL :: res
3700
3701integer :: minute,hour,day,month
3702
3704
3705res = .true.
3710
3712 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
3713end if
3714
3715
3716END FUNCTION datetime_cyclicdatetime_eq
3717
3718ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
3719TYPE(cyclicdatetime),INTENT(in) :: this
3720LOGICAL :: res
3721
3722res = .not. this == cyclicdatetime_miss
3723
3724end FUNCTION c_e_cyclicdatetime
3725
3726
3729FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
3730INTEGER,INTENT(IN),OPTIONAL :: tendaysp
3731INTEGER,INTENT(IN),OPTIONAL :: month
3732INTEGER,INTENT(IN),OPTIONAL :: day
3733INTEGER,INTENT(IN),OPTIONAL :: hour
3734INTEGER,INTENT(IN),OPTIONAL :: minute
3735CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
3736
3737integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
3738
3739
3740TYPE(cyclicdatetime) :: this
3741
3742if (present(chardate)) then
3743
3744 ltendaysp=imiss
3745 lmonth=imiss
3746 lday=imiss
3747 lhour=imiss
3748 lminute=imiss
3749
3751 ! TMMGGhhmm
3752 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
3753 !print*,chardate(1:1),ios,ltendaysp
3754 if (ios /= 0)ltendaysp=imiss
3755
3756 read(chardate(2:3),'(i2)',iostat=ios)lmonth
3757 !print*,chardate(2:3),ios,lmonth
3758 if (ios /= 0)lmonth=imiss
3759
3760 read(chardate(4:5),'(i2)',iostat=ios)lday
3761 !print*,chardate(4:5),ios,lday
3762 if (ios /= 0)lday=imiss
3763
3764 read(chardate(6:7),'(i2)',iostat=ios)lhour
3765 !print*,chardate(6:7),ios,lhour
3766 if (ios /= 0)lhour=imiss
3767
3768 read(chardate(8:9),'(i2)',iostat=ios)lminute
3769 !print*,chardate(8:9),ios,lminute
3770 if (ios /= 0)lminute=imiss
3771 end if
3772
3773 this%tendaysp=ltendaysp
3774 this%month=lmonth
3775 this%day=lday
3776 this%hour=lhour
3777 this%minute=lminute
3778else
3779 this%tendaysp=optio_l(tendaysp)
3780 this%month=optio_l(month)
3781 this%day=optio_l(day)
3782 this%hour=optio_l(hour)
3783 this%minute=optio_l(minute)
3784end if
3785
3786END FUNCTION cyclicdatetime_new
3787
3790elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
3791TYPE(cyclicdatetime),INTENT(IN) :: this
3792
3793CHARACTER(len=80) :: char
3794
3797
3798END FUNCTION cyclicdatetime_to_char
3799
3800
3813FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
3814TYPE(cyclicdatetime),INTENT(IN) :: this
3815
3816TYPE(datetime) :: dtc
3817
3818integer :: year,month,day,hour
3819
3820dtc = datetime_miss
3821
3822! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
3824 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
3825 return
3826end if
3827
3828! minute present -> not good for conventional datetime
3830! day, month and tendaysp present -> no good
3832
3834 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
3836 day=(this%tendaysp-1)*10+1
3837 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
3839 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
3841 ! only day present -> no good
3842 return
3843end if
3844
3847 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
3848end if
3849
3850
3851END FUNCTION cyclicdatetime_to_conventional
3852
3853
3854
3855FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
3856TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3857
3858CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
3859
3860char=cyclicdatetime_to_char(in)
3861
3862END FUNCTION trim_cyclicdatetime_to_char
3863
3864
3865
3866SUBROUTINE display_cyclicdatetime(this)
3867TYPE(cyclicdatetime),INTENT(in) :: this
3868
3870
3871end subroutine display_cyclicdatetime
3872
3873
3874#include "array_utilities_inc.F90"
3875
3877
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 |