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