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