libsim Versione 7.2.6

◆ cyclicdatetime_to_char()

elemental character(len=80) function cyclicdatetime_to_char ( type(cyclicdatetime), intent(in) this)
private

Restituisce una rappresentazione carattere stampabile di un oggetto cyclicdatetime.

Definizione alla linea 2379 del file datetime_class.F90.

2380! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2381! authors:
2382! Davide Cesari <dcesari@arpa.emr.it>
2383! Paolo Patruno <ppatruno@arpa.emr.it>
2384
2385! This program is free software; you can redistribute it and/or
2386! modify it under the terms of the GNU General Public License as
2387! published by the Free Software Foundation; either version 2 of
2388! the License, or (at your option) any later version.
2389
2390! This program is distributed in the hope that it will be useful,
2391! but WITHOUT ANY WARRANTY; without even the implied warranty of
2392! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2393! GNU General Public License for more details.
2394
2395! You should have received a copy of the GNU General Public License
2396! along with this program. If not, see <http://www.gnu.org/licenses/>.
2397#include "config.h"
2398!> \brief Classi per la gestione delle coordinate temporali.
2399!!
2400!! Questo module definisce un paio di classi per la gestione di
2401!! date assolute e di intervalli temporali.
2402!! Entrambe le classi hanno le componenti di tipo \c PRIVATE, per
2403!! cui non possono essere manipolate direttamente ma solo tramite i
2404!! relativi metodi. Attualmente la precisione massima consentita � di un
2405!! minuto, mentre l'estensione delle date rappresentabili va dall'anno 1
2406!! all'anno 4074 d.C. circa, ipotizzando un calendario gregoriano per
2407!! tutto il periodo. Questo fatto implica che le date precedenti
2408!! all'introduzione del calendario gregoriano avranno discrepanze di uno
2409!! o pi� giorni rispetto alle date storiche "vere", ammesso che
2410!! qualcuno conosca queste ultime.
2411!! \ingroup base
2412MODULE datetime_class
2413USE kinds
2414USE log4fortran
2415USE err_handling
2419IMPLICIT NONE
2420
2421INTEGER, PARAMETER :: dateint=selected_int_kind(13)
2422
2423!> Class for expressing an absolute time value.
2424TYPE datetime
2425 PRIVATE
2426 INTEGER(KIND=int_ll) :: iminuti
2427END TYPE datetime
2428
2429!> Class for expressing a relative time interval.
2430!! It can take also negative values. According to how it is
2431!! initilasied, it can indicate an interval of fixed duration, or a
2432!! "calendar" interval of variable duration in units of months and/or
2433!! years or even a mix of the two, however, in the latter two cases
2434!! the operations that can be made with objects of this class are
2435!! restricted.
2436TYPE timedelta
2437 PRIVATE
2438 INTEGER(KIND=int_ll) :: iminuti
2439 INTEGER :: month
2440END TYPE timedelta
2441
2442
2443!> Class for expressing a cyclic datetime.
2444!! It can be used to specify, for example, every January in all years
2445!! or the same time for all days and so on.
2446TYPE cyclicdatetime
2447 PRIVATE
2448 INTEGER :: minute
2449 INTEGER :: hour
2450 INTEGER :: day
2451 INTEGER :: tendaysp
2452 INTEGER :: month
2453END TYPE cyclicdatetime
2454
2455
2456!> valore mancante per datetime
2457TYPE(datetime), PARAMETER :: datetime_miss=datetime(illmiss)
2458!> valore mancante per timedelta
2459TYPE(timedelta), PARAMETER :: timedelta_miss=timedelta(illmiss, 0)
2460!> intervallo timedelta di durata nulla
2461TYPE(timedelta), PARAMETER :: timedelta_0=timedelta(0, 0)
2462!> inizializza con l'ora UTC
2463INTEGER, PARAMETER :: datetime_utc=1
2464!> inizializza con l'ora locale
2465INTEGER, PARAMETER :: datetime_local=2
2466!> Minimum valid value for datetime
2467TYPE(datetime), PARAMETER :: datetime_min=datetime(-huge(1_int_ll)-1)
2468!> Minimum valid value for datetime
2469TYPE(datetime), PARAMETER :: datetime_max=datetime(huge(1_int_ll)-1)
2470!> Minimum valid value for timedelta
2471TYPE(timedelta), PARAMETER :: timedelta_min=timedelta(-huge(1_int_ll)-1,0)
2472!> Minimum valid value for timedelta
2473TYPE(timedelta), PARAMETER :: timedelta_max=timedelta(huge(1_int_ll)-1,0)
2474!> missing value for cyclicdatetime
2475TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
2476
2477
2478INTEGER(kind=dateint), PARAMETER :: &
2479 sec_in_day=86400, &
2480 sec_in_hour=3600, &
2481 sec_in_min=60, &
2482 min_in_day=1440, &
2483 min_in_hour=60, &
2484 hour_in_day=24
2485
2486INTEGER,PARAMETER :: &
2487 year0=1, & ! anno di origine per iminuti
2488 d1=365, & ! giorni/1 anno nel calendario gregoriano
2489 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
2490 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
2491 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
2492 ianno(13,2)=reshape((/ &
2493 0,31,59,90,120,151,181,212,243,273,304,334,365, &
2494 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
2495
2496INTEGER(KIND=int_ll),PARAMETER :: &
2497 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
2498
2499!> Costruttori per le classi datetime e timedelta. Devono essere richiamati
2500!! per tutti gli oggetti di questo tipo definiti in un programma
2501!! tranne i casi in cui un oggetto viene creato per assegnazione.
2502INTERFACE init
2503 MODULE PROCEDURE datetime_init, timedelta_init
2504END INTERFACE
2505
2506!> Distruttori per le 2 classi. Distruggono gli oggetti in maniera pulita,
2507!! assegnando loro un valore mancante.
2508INTERFACE delete
2509 MODULE PROCEDURE datetime_delete, timedelta_delete
2510END INTERFACE
2511
2512!> Restituiscono il valore dell'oggetto nella forma desiderata.
2513INTERFACE getval
2514 MODULE PROCEDURE datetime_getval, timedelta_getval
2515END INTERFACE
2516
2517!> Restituiscono il valore dell'oggetto in forma di stringa stampabile.
2518INTERFACE to_char
2519 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
2520END INTERFACE
2521
2522
2523!> Functions that return a trimmed CHARACTER representation of the
2524!! input variable. The functions are analogous to \a to_char but they
2525!! return representation of the input in a CHARACTER with a variable
2526!! length, which needs not to be trimmed before use. The optional
2527!! format here is not accepted and these functions are not \a
2528!! ELEMENTAL so they work only on scalar arguments.
2529!!
2530!! \param in (datetime or timedelta) value to be represented as CHARACTER
2531!!
2532!! Example of use:
2533!! \code
2534!! USE datetime_class
2535!! type(datetime) :: t
2536!! ...
2537!! WRITE(*,*)'The value provided is, '//t2c(t)'
2538!! ...
2539!! \endcode
2540INTERFACE t2c
2541 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
2542END INTERFACE
2543
2544!> Operatore logico di uguaglianza tra oggetti della stessa classe.
2545!! Funziona anche per
2546!! confronti di tipo array-array (qualsiasi n. di dimensioni) e di tipo
2547!! scalare-vettore(1-d) (ma non vettore(1-d)-scalare o tra array con pi�
2548!! di 1 dimensione e scalari).
2549INTERFACE OPERATOR (==)
2550 MODULE PROCEDURE datetime_eq, timedelta_eq, &
2551 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
2552END INTERFACE
2553
2554!> Operatore logico di disuguaglianza tra oggetti della stessa classe.
2555!! Funziona anche per
2556!! confronti di tipo array-array (qualsiasi n. di dimensioni) e di tipo
2557!! scalare-vettore(1-d) (ma non vettore(1-d)-scalare o tra array con pi�
2558!! di 1 dimensione e scalari).
2559INTERFACE OPERATOR (/=)
2560 MODULE PROCEDURE datetime_ne, timedelta_ne
2561END INTERFACE
2562
2563!> Operatore logico maggiore tra oggetti della stessa classe.
2564!! Funziona anche per
2565!! confronti di tipo array-array (qualsiasi n. di dimensioni) e di tipo
2566!! scalare-vettore(1-d) (ma non vettore(1-d)-scalare o tra array con pi�
2567!! di 1 dimensione e scalari). Nel caso di valori mancanti il risultato
2568!! non � specificato. Il risultato non � altres� specificato nel caso di oggetti
2569!! \a timedelta "popolari" o misti.
2570INTERFACE OPERATOR (>)
2571 MODULE PROCEDURE datetime_gt, timedelta_gt
2572END INTERFACE
2573
2574!> Operatore logico minore tra oggetti della stessa classe.
2575!! Funziona anche per
2576!! confronti di tipo array-array (qualsiasi n. di dimensioni) e di tipo
2577!! scalare-vettore(1-d) (ma non vettore(1-d)-scalare o tra array con pi�
2578!! di 1 dimensione e scalari). Nel caso di valori mancanti il risultato
2579!! non � specificato. Il risultato non � altres� specificato nel caso di oggetti
2580!! \a timedelta "popolari" o misti.
2581INTERFACE OPERATOR (<)
2582 MODULE PROCEDURE datetime_lt, timedelta_lt
2583END INTERFACE
2584
2585!> Operatore logico maggiore-uguale tra oggetti della stessa classe.
2586!! Funziona anche per
2587!! confronti di tipo array-array (qualsiasi n. di dimensioni) e di tipo
2588!! scalare-vettore(1-d) (ma non vettore(1-d)-scalare o tra array con pi�
2589!! di 1 dimensione e scalari). Nel caso di valori mancanti il risultato
2590!! non � specificato. Il risultato non � altres� specificato nel caso di oggetti
2591!! \a timedelta "popolari" o misti.
2592INTERFACE OPERATOR (>=)
2593 MODULE PROCEDURE datetime_ge, timedelta_ge
2594END INTERFACE
2595
2596!> Operatore logico minore-uguale tra oggetti della stessa classe.
2597!! Funziona anche per
2598!! confronti di tipo array-array (qualsiasi n. di dimensioni) e di tipo
2599!! scalare-vettore(1-d) (ma non vettore(1-d)-scalare o tra array con pi�
2600!! di 1 dimensione e scalari). Nel caso di valori mancanti il risultato
2601!! non � specificato. Il risultato non � altres� specificato nel caso di oggetti
2602!! \a timedelta "popolari" o misti.
2603INTERFACE OPERATOR (<=)
2604 MODULE PROCEDURE datetime_le, timedelta_le
2605END INTERFACE
2606
2607!> Operatore di somma per datetime e timedelta. Solo alcune combinazioni
2608!! sono definite:
2609!! - \a timedelta + \a timedelta = \a timedelta
2610!! - \a datetime + \a timedelta = \a datetime
2611!! .
2612!! Funzionano anche con oggetti \a timedelta "popolari" o misti.
2613INTERFACE OPERATOR (+)
2614 MODULE PROCEDURE datetime_add, timedelta_add
2615END INTERFACE
2616
2617!> Operatore di sottrazione per datetime e timedelta. Solo alcune combinazioni
2618!! sono definite:
2619!! - \a timedelta - \a timedelta = \a timedelta
2620!! - \a datetime - \a timedelta = \a datetime
2621!! - \a datetime - \a datetime = \a timedelta
2622!! .
2623!! Funzionano anche con oggetti \a timedelta "popolari" o misti.
2624INTERFACE OPERATOR (-)
2625 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
2626END INTERFACE
2627
2628!> Operatore di moltiplicazione di timedelta per uno scalare. Sono definite:
2629!! - \a timedelta * \a INTEGER = \a timedelta
2630!! - \a INTEGER * \a timedelta = \a timedelta
2631!! .
2632!! Funzionano anche con oggetti \a timedelta "popolari" o misti.
2633INTERFACE OPERATOR (*)
2634 MODULE PROCEDURE timedelta_mult, timedelta_tlum
2635END INTERFACE
2636
2637!> Operatore di divisione di timedelta. Sono definite:
2638!! - \a timedelta / \a INTEGER = \a timedelta
2639!! - \a timedelta / \a timedelta = \a INTEGER
2640!! .
2641!! La prima combinazione � valida per tutti i tipi di intervallo, mentre la
2642!! seconda � definita solo per intervalli "puri".
2643INTERFACE OPERATOR (/)
2644 MODULE PROCEDURE timedelta_divint, timedelta_divtd
2645END INTERFACE
2646
2647!> Operatore di resto della divisione.
2648!! Sono definite le combinazioni:
2649!! - \a MOD(\a timedelta, \a timedelta) = \a timedelta
2650!! - \a MOD(\a datetime, \a timedelta) = \a timedelta.
2651!!
2652!! Sono definite solo per intervalli "puri"
2653!! La seconda combinazione ha senso principalmente con intervalli di
2654!! 1 minuto, 1 ora o
2655!! 1 giorno, per calcolare di quanto l'oggetto \a datetime indicato dista
2656!! dal minuto, ora o giorno tondo precedente pi� vicino.
2657INTERFACE mod
2658 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
2659END INTERFACE
2660
2661!> Operatore di valore assoluto di un intervallo.
2662!! - \a ABS(\a timedelta) = \a timedelta
2663INTERFACE abs
2664 MODULE PROCEDURE timedelta_abs
2665END INTERFACE
2666
2667!> Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da
2668!! un file \c FORMATTED o \c UNFORMATTED.
2669INTERFACE read_unit
2670 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
2671 timedelta_read_unit, timedelta_vect_read_unit
2672END INTERFACE
2673
2674!> Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su
2675!! un file \c FORMATTED o \c UNFORMATTED.
2676INTERFACE write_unit
2677 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
2678 timedelta_write_unit, timedelta_vect_write_unit
2679END INTERFACE
2680
2681!> Print object
2682INTERFACE display
2683 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
2684END INTERFACE
2685
2686!> Missing check
2687INTERFACE c_e
2688 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
2689END INTERFACE
2690
2691#undef VOL7D_POLY_TYPE
2692#undef VOL7D_POLY_TYPES
2693#undef ENABLE_SORT
2694#define VOL7D_POLY_TYPE TYPE(datetime)
2695#define VOL7D_POLY_TYPES _datetime
2696#define ENABLE_SORT
2697#include "array_utilities_pre.F90"
2698
2699
2700#define ARRAYOF_ORIGTYPE TYPE(datetime)
2701#define ARRAYOF_TYPE arrayof_datetime
2702#define ARRAYOF_ORIGEQ 1
2703#include "arrayof_pre.F90"
2704! from arrayof
2705
2706PRIVATE
2707
2708PUBLIC datetime, datetime_miss, datetime_utc, datetime_local, &
2709 datetime_min, datetime_max, &
2710 datetime_new, datetime_new_now, init, delete, getval, to_char, t2c, &
2712 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
2713 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
2714 OPERATOR(*), OPERATOR(/), mod, abs, &
2715 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
2716 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
2717 display, c_e, &
2718 count_distinct, pack_distinct, &
2719 count_distinct_sorted, pack_distinct_sorted, &
2720 count_and_pack_distinct, &
2721 map_distinct, map_inv_distinct, index, index_sorted, sort, &
2722 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
2723PUBLIC insert, append, remove, packarray
2724PUBLIC insert_unique, append_unique
2725PUBLIC cyclicdatetime_to_conventional
2726
2727CONTAINS
2728
2729
2730! ==============
2731! == datetime ==
2732! ==============
2733
2734!> Initialize a \a datetime object according to the provided arguments
2735!! If no arguments are passed a missing object is created. Notice
2736!! that the optional parameter groups (\a year, \a month, \a hour, \a
2737!! minute, \a msec), (\a unixtime), (\a isodate), (\a simpledate) are
2738!! mutually exclusive, the results are not guaranteed if arguments of
2739!! different groups are present.
2740ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
2741 unixtime, isodate, simpledate) RESULT(this)
2742INTEGER,INTENT(IN),OPTIONAL :: year !< year a.C.; for reasons not yet investigated, only years >0 (a.C.) are allowed
2743INTEGER,INTENT(IN),OPTIONAL :: month !< month, default=1 if \a year is present, it can also be outside the interval 1-12, the function behaves reasonably in that case
2744INTEGER,INTENT(IN),OPTIONAL :: day !< day, default=1 if \a year is present, it can have non canonical values too
2745INTEGER,INTENT(IN),OPTIONAL :: hour !< hours, default=0 if \a year is present, it can have non canonical values too
2746INTEGER,INTENT(IN),OPTIONAL :: minute !< minutes, default=0 if \a year is present, it can have non canonical values too
2747INTEGER,INTENT(IN),OPTIONAL :: msec !< milliseconds, default=0 if \a year is present, it can have non canonical values too
2748INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime !< initialize the object to \a unixtime seconds after 1/1/1970, UNIX convention, notice that this is an 8-byte integer
2749CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate !< initialize the object to a date expressed as a string \c YYYY-MM-DD \c hh:mm:ss.msc, (iso format), the initial part YYYY-MM-DD is compulsory, the remaining part is optional
2750CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate !< initialize the object to a date expressed as a string \c YYYYMMDDhh:mm:ss.msc, (iso format), the initial part YYYYMMDD is compulsory, the remaining part is optional
2751
2752TYPE(datetime) :: this
2753INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2754CHARACTER(len=23) :: datebuf
2755
2756IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
2757 lyear = year
2758 IF (PRESENT(month)) THEN
2759 lmonth = month
2760 ELSE
2761 lmonth = 1
2762 ENDIF
2763 IF (PRESENT(day)) THEN
2764 lday = day
2765 ELSE
2766 lday = 1
2767 ENDIF
2768 IF (PRESENT(hour)) THEN
2769 lhour = hour
2770 ELSE
2771 lhour = 0
2772 ENDIF
2773 IF (PRESENT(minute)) THEN
2774 lminute = minute
2775 ELSE
2776 lminute = 0
2777 ENDIF
2778 IF (PRESENT(msec)) THEN
2779 lmsec = msec
2780 ELSE
2781 lmsec = 0
2782 ENDIF
2783
2784 if (c_e(lday) .and. c_e(lmonth) .and. c_e(lyear) .and. c_e(lhour) &
2785 .and. c_e(lminute) .and. c_e(lmsec)) then
2786 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2787 else
2788 this=datetime_miss
2789 end if
2790
2791ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
2792 if (c_e(unixtime)) then
2793 this%iminuti = (unixtime + unsec)*1000
2794 else
2795 this=datetime_miss
2796 end if
2797
2798ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
2799
2800 IF (c_e(isodate) .AND. len_trim(isodate) > 0) THEN
2801 datebuf(1:23) = '0001-01-01 00:00:00.000'
2802 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
2803 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
2804 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2805 lmsec = lmsec + lsec*1000
2806 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2807 RETURN
2808
2809100 CONTINUE ! condizione di errore in isodate
2810 CALL delete(this)
2811 RETURN
2812 ELSE
2813 this = datetime_miss
2814 ENDIF
2815
2816ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
2817 IF (c_e(simpledate) .AND. len_trim(simpledate) > 0)THEN
2818 datebuf(1:17) = '00010101000000000'
2819 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
2820 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
2821 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
2822 lmsec = lmsec + lsec*1000
2823 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2824 RETURN
2825
2826120 CONTINUE ! condizione di errore in simpledate
2827 CALL delete(this)
2828 RETURN
2829 ELSE
2830 this = datetime_miss
2831 ENDIF
2832
2833ELSE
2834 this = datetime_miss
2835ENDIF
2836
2837END FUNCTION datetime_new
2838
2839
2840!> Initialize a datetime object with the current system time.
2841FUNCTION datetime_new_now(now) RESULT(this)
2842INTEGER,INTENT(IN) :: now !< select the time for initialisation, \a datetime_utc for UTC (preferred) or \a datetime_local for local time
2843TYPE(datetime) :: this
2844
2845INTEGER :: dt(8)
2846
2847IF (c_e(now)) THEN
2848 CALL date_and_time(values=dt)
2849 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
2850 CALL init(this, year=dt(1), month=dt(2), day=dt(3), hour=dt(5), minute=dt(6), &
2851 msec=dt(7)*1000+dt(8))
2852ELSE
2853 this = datetime_miss
2854ENDIF
2855
2856END FUNCTION datetime_new_now
2857
2858
2859!> Costruisce un oggetto \a datetime con i parametri opzionali forniti.
2860!! Se non viene passato nulla lo inizializza a 1/1/1.
2861!! Notare che i gruppi di parametri opzionali (\a year, \a month, \a hour,
2862!! \a minute, \a msec), (\a unixtime), (\a isodate), (\a simpledate),
2863!! (\a oraclesimdate) sono mutualmente escludentesi; \a oraclesimedate �
2864!! obsoleto, usare piuttosto \a simpledate.
2865SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
2866 unixtime, isodate, simpledate, now)
2867TYPE(datetime),INTENT(INOUT) :: this !< oggetto da inizializzare
2868INTEGER,INTENT(IN),OPTIONAL :: year !< anno d.C., se � specificato, tutti gli eventuali parametri tranne \a month, \a day, \a hour e \a minute sono ignorati; per un problema non risolto, sono ammessi solo anni >0 (d.C.)
2869INTEGER,INTENT(IN),OPTIONAL :: month !< mese, default=1 se � specificato \a year; pu� assumere anche valori <1 o >12, l'oggetto finale si aggiusta coerentemente
2870INTEGER,INTENT(IN),OPTIONAL :: day !< mese, default=1 se � specificato \a year; pu� anch'esso assumere valori fuori dai limiti canonici
2871INTEGER,INTENT(IN),OPTIONAL :: hour !< ore, default=0 se � specificato \a year; pu� anch'esso assumere valori fuori dai limiti canonici
2872INTEGER,INTENT(IN),OPTIONAL :: minute !< minuti, default=0 se � specificato \a year; pu� anch'esso assumere valori fuori dai limiti canonici
2873INTEGER,INTENT(IN),OPTIONAL :: msec !< millisecondi, default=0 se � specificato \a year; pu� anch'esso assumere valori fuori dai limiti canonici
2874INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime !< inizializza l'oggetto a \a unixtime secondi dopo il 1/1/1970 (convenzione UNIX, notare che il parametro deve essere un intero a 8 byte)
2875CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate !< inizializza l'oggetto ad una data espressa nel formato \c AAAA-MM-GG \c hh:mm:ss.msc, un sottoinsieme del formato noto come \a ISO, la parte iniziale \c AAAA-MM-GG � obbligatoria, il resto � opzionale
2876CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate !< inizializza l'oggetto ad una data espressa nel formato \c AAAAMMGGhhmmssmsc, la parte iniziale \c AAAAMMGG � obbligatoria, il resto � opzionale, da preferire rispetto a \a oraclesimdate
2877INTEGER,INTENT(IN),OPTIONAL :: now !< inizializza l'oggetto all'istante corrente, se \a � \a datetime_utc inizializza con l'ora UTC (preferibile), se � \a datetime_local usa l'ora locale
2878
2879IF (PRESENT(now)) THEN
2880 this = datetime_new_now(now)
2881ELSE
2882 this = datetime_new(year, month, day, hour, minute, msec, &
2883 unixtime, isodate, simpledate)
2884ENDIF
2885
2886END SUBROUTINE datetime_init
2887
2888
2889ELEMENTAL SUBROUTINE datetime_delete(this)
2890TYPE(datetime),INTENT(INOUT) :: this
2891
2892this%iminuti = illmiss
2893
2894END SUBROUTINE datetime_delete
2895
2896
2897!> Restituisce il valore di un oggetto \a datetime in una o pi�
2898!! modalit� desiderate. Qualsiasi combinazione dei parametri
2899!! opzionali � consentita. \a oraclesimedate �
2900!! obsoleto, usare piuttosto \a simpledate.
2901PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
2902 unixtime, isodate, simpledate, oraclesimdate)
2903TYPE(datetime),INTENT(IN) :: this !< oggetto di cui restituire il valore
2904INTEGER,INTENT(OUT),OPTIONAL :: year !< anno
2905INTEGER,INTENT(OUT),OPTIONAL :: month !< mese
2906INTEGER,INTENT(OUT),OPTIONAL :: day !< giorno
2907INTEGER,INTENT(OUT),OPTIONAL :: hour !< ore
2908INTEGER,INTENT(OUT),OPTIONAL :: minute !< minuti
2909INTEGER,INTENT(OUT),OPTIONAL :: msec !< millisecondi
2910INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime !< secondi a partire dal 1/1/1970
2911CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate !< data completa nel formato \c AAAA-MM-GG \c hh:mm:ss.msc (simil-ISO), la variabile pu� essere pi� corta di 23 caratteri, in tal caso conterr� solo ci� che vi cape
2912CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate !< data completa nel formato \c AAAAMMGGhhmmssmsc , la variabile pu� essere pi� corta di 17 caratteri, in tal caso conterr� solo ci� che vi cape, da preferire rispetto a \a oraclesimdate
2913CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate !< data parziale nel formato \c AAAAMMGGhhmm
2914
2915INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
2916CHARACTER(len=23) :: datebuf
2917
2918IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
2919 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
2920 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
2921
2922 IF (this == datetime_miss) THEN
2923
2924 IF (PRESENT(msec)) THEN
2925 msec = imiss
2926 ENDIF
2927 IF (PRESENT(minute)) THEN
2928 minute = imiss
2929 ENDIF
2930 IF (PRESENT(hour)) THEN
2931 hour = imiss
2932 ENDIF
2933 IF (PRESENT(day)) THEN
2934 day = imiss
2935 ENDIF
2936 IF (PRESENT(month)) THEN
2937 month = imiss
2938 ENDIF
2939 IF (PRESENT(year)) THEN
2940 year = imiss
2941 ENDIF
2942 IF (PRESENT(isodate)) THEN
2943 isodate = cmiss
2944 ENDIF
2945 IF (PRESENT(simpledate)) THEN
2946 simpledate = cmiss
2947 ENDIF
2948 IF (PRESENT(oraclesimdate)) THEN
2949!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2950!!$ 'obsoleto, usare piuttosto simpledate')
2951 oraclesimdate=cmiss
2952 ENDIF
2953 IF (PRESENT(unixtime)) THEN
2954 unixtime = illmiss
2955 ENDIF
2956
2957 ELSE
2958
2959 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
2960 IF (PRESENT(msec)) THEN
2961 msec = lmsec
2962 ENDIF
2963 IF (PRESENT(minute)) THEN
2964 minute = lminute
2965 ENDIF
2966 IF (PRESENT(hour)) THEN
2967 hour = lhour
2968 ENDIF
2969 IF (PRESENT(day)) THEN
2970 day = lday
2971 ENDIF
2972 IF (PRESENT(month)) THEN
2973 month = lmonth
2974 ENDIF
2975 IF (PRESENT(year)) THEN
2976 year = lyear
2977 ENDIF
2978 IF (PRESENT(isodate)) THEN
2979 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
2980 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
2981 '.', mod(lmsec, 1000)
2982 isodate = datebuf(1:min(len(isodate),23))
2983 ENDIF
2984 IF (PRESENT(simpledate)) THEN
2985 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
2986 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
2987 simpledate = datebuf(1:min(len(simpledate),17))
2988 ENDIF
2989 IF (PRESENT(oraclesimdate)) THEN
2990!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
2991!!$ 'obsoleto, usare piuttosto simpledate')
2992 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
2993 ENDIF
2994 IF (PRESENT(unixtime)) THEN
2995 unixtime = this%iminuti/1000_int_ll-unsec
2996 ENDIF
2997
2998 ENDIF
2999ENDIF
3000
3001END SUBROUTINE datetime_getval
3002
3003
3004!> Restituisce una rappresentazione carattere stampabile di un oggetto
3005!! \a datetime.
3006elemental FUNCTION datetime_to_char(this) RESULT(char)
3007TYPE(datetime),INTENT(IN) :: this
3008
3009CHARACTER(len=23) :: char
3010
3011CALL getval(this, isodate=char)
3012
3013END FUNCTION datetime_to_char
3014
3015
3016FUNCTION trim_datetime_to_char(in) RESULT(char)
3017TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3018
3019CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3020
3021char=datetime_to_char(in)
3022
3023END FUNCTION trim_datetime_to_char
3024
3025
3026
3027SUBROUTINE display_datetime(this)
3028TYPE(datetime),INTENT(in) :: this
3029
3030print*,"TIME: ",to_char(this)
3031
3032end subroutine display_datetime
3033
3034
3035
3036SUBROUTINE display_timedelta(this)
3037TYPE(timedelta),INTENT(in) :: this
3038
3039print*,"TIMEDELTA: ",to_char(this)
3040
3041end subroutine display_timedelta
3042
3043
3044
3045ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3046TYPE(datetime),INTENT(in) :: this
3047LOGICAL :: res
3048
3049res = .not. this == datetime_miss
3050
3051end FUNCTION c_e_datetime
3052
3053
3054ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3055TYPE(datetime),INTENT(IN) :: this, that
3056LOGICAL :: res
3057
3058res = this%iminuti == that%iminuti
3059
3060END FUNCTION datetime_eq
3061
3062
3063ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3064TYPE(datetime),INTENT(IN) :: this, that
3065LOGICAL :: res
3066
3067res = .NOT.(this == that)
3068
3069END FUNCTION datetime_ne
3070
3071
3072ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3073TYPE(datetime),INTENT(IN) :: this, that
3074LOGICAL :: res
3075
3076res = this%iminuti > that%iminuti
3077
3078END FUNCTION datetime_gt
3079
3080
3081ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3082TYPE(datetime),INTENT(IN) :: this, that
3083LOGICAL :: res
3084
3085res = this%iminuti < that%iminuti
3086
3087END FUNCTION datetime_lt
3088
3089
3090ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3091TYPE(datetime),INTENT(IN) :: this, that
3092LOGICAL :: res
3093
3094IF (this == that) THEN
3095 res = .true.
3096ELSE IF (this > that) THEN
3097 res = .true.
3098ELSE
3099 res = .false.
3100ENDIF
3101
3102END FUNCTION datetime_ge
3103
3104
3105ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3106TYPE(datetime),INTENT(IN) :: this, that
3107LOGICAL :: res
3108
3109IF (this == that) THEN
3110 res = .true.
3111ELSE IF (this < that) THEN
3112 res = .true.
3113ELSE
3114 res = .false.
3115ENDIF
3116
3117END FUNCTION datetime_le
3118
3119
3120FUNCTION datetime_add(this, that) RESULT(res)
3121TYPE(datetime),INTENT(IN) :: this
3122TYPE(timedelta),INTENT(IN) :: that
3123TYPE(datetime) :: res
3124
3125INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3126
3127IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3128 res = datetime_miss
3129ELSE
3130 res%iminuti = this%iminuti + that%iminuti
3131 IF (that%month /= 0) THEN
3132 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3133 minute=lminute, msec=lmsec)
3134 CALL init(res, year=lyear, month=lmonth+that%month, day=lday, &
3135 hour=lhour, minute=lminute, msec=lmsec)
3136 ENDIF
3137ENDIF
3138
3139END FUNCTION datetime_add
3140
3141
3142ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3143TYPE(datetime),INTENT(IN) :: this, that
3144TYPE(timedelta) :: res
3145
3146IF (this == datetime_miss .OR. that == datetime_miss) THEN
3147 res = timedelta_miss
3148ELSE
3149 res%iminuti = this%iminuti - that%iminuti
3150 res%month = 0
3151ENDIF
3152
3153END FUNCTION datetime_subdt
3154
3155
3156FUNCTION datetime_subtd(this, that) RESULT(res)
3157TYPE(datetime),INTENT(IN) :: this
3158TYPE(timedelta),INTENT(IN) :: that
3159TYPE(datetime) :: res
3160
3161INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3162
3163IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3164 res = datetime_miss
3165ELSE
3166 res%iminuti = this%iminuti - that%iminuti
3167 IF (that%month /= 0) THEN
3168 CALL getval(res, year=lyear, month=lmonth, day=lday, hour=lhour, &
3169 minute=lminute, msec=lmsec)
3170 CALL init(res, year=lyear, month=lmonth-that%month, day=lday, &
3171 hour=lhour, minute=lminute, msec=lmsec)
3172 ENDIF
3173ENDIF
3174
3175END FUNCTION datetime_subtd
3176
3177
3178!> This method reads from a Fortran file unit the contents of the
3179!! object \a this. The record to be read must have been written with
3180!! the ::write_unit method. The method works both on formatted and
3181!! unformatted files.
3182SUBROUTINE datetime_read_unit(this, unit)
3183TYPE(datetime),INTENT(out) :: this !< object to be read
3184INTEGER, INTENT(in) :: unit !< unit from which to read, it must be an opened Fortran file unit
3185CALL datetime_vect_read_unit((/this/), unit)
3186
3187END SUBROUTINE datetime_read_unit
3188
3189
3190!> This method reads from a Fortran file unit the contents of the
3191!! object \a this. The record to be read must have been written with
3192!! the ::write_unit method. The method works both on formatted and
3193!! unformatted files.
3194SUBROUTINE datetime_vect_read_unit(this, unit)
3195TYPE(datetime) :: this(:) !< object to be read
3196INTEGER, INTENT(in) :: unit !< unit from which to read, it must be an opened Fortran file unit
3197
3198CHARACTER(len=40) :: form
3199CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3200INTEGER :: i
3201
3202ALLOCATE(dateiso(SIZE(this)))
3203INQUIRE(unit, form=form)
3204IF (form == 'FORMATTED') THEN
3205 READ(unit,'(A23,1X)')dateiso
3206ELSE
3207 READ(unit)dateiso
3208ENDIF
3209DO i = 1, SIZE(dateiso)
3210 CALL init(this(i), isodate=dateiso(i))
3211ENDDO
3212DEALLOCATE(dateiso)
3213
3214END SUBROUTINE datetime_vect_read_unit
3215
3216
3217!> This method writes on a Fortran file unit the contents of the
3218!! object \a this. The record can successively be read by the
3219!! ::read_unit method. The method works both on formatted and
3220!! unformatted files.
3221SUBROUTINE datetime_write_unit(this, unit)
3222TYPE(datetime),INTENT(in) :: this !< object to be written
3223INTEGER, INTENT(in) :: unit !< unit where to write, it must be an opened Fortran file unit
3224
3225CALL datetime_vect_write_unit((/this/), unit)
3226
3227END SUBROUTINE datetime_write_unit
3228
3229
3230!> This method writes on a Fortran file unit the contents of the
3231!! object \a this. The record can successively be read by the
3232!! ::read_unit method. The method works both on formatted and
3233!! unformatted files.
3234SUBROUTINE datetime_vect_write_unit(this, unit)
3235TYPE(datetime),INTENT(in) :: this(:) !< object to be written
3236INTEGER, INTENT(in) :: unit !< unit where to write, it must be an opened Fortran file unit
3237
3238CHARACTER(len=40) :: form
3239CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3240INTEGER :: i
3241
3242ALLOCATE(dateiso(SIZE(this)))
3243DO i = 1, SIZE(dateiso)
3244 CALL getval(this(i), isodate=dateiso(i))
3245ENDDO
3246INQUIRE(unit, form=form)
3247IF (form == 'FORMATTED') THEN
3248 WRITE(unit,'(A23,1X)')dateiso
3249ELSE
3250 WRITE(unit)dateiso
3251ENDIF
3252DEALLOCATE(dateiso)
3253
3254END SUBROUTINE datetime_vect_write_unit
3255
3256
3257#include "arrayof_post.F90"
3258
3259
3260! ===============
3261! == timedelta ==
3262! ===============
3263!> Costruisce un oggetto \a timedelta con i parametri opzionali forniti.
3264!! Se non viene passato nulla lo inizializza a intervallo di durata nulla.
3265!! L'intervallo ottenuto � pari alla somma dei valori di tutti i parametri
3266!! forniti, ovviamente non fornire un parametro equivale a fornirlo =0.
3267!! Questa � la versione \c FUNCTION, in stile F2003, del costruttore, da preferire
3268!! rispetto alla versione \c SUBROUTINE \c init.
3269FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3270 isodate, simpledate, oraclesimdate) RESULT (this)
3271INTEGER,INTENT(IN),OPTIONAL :: year !< anni, se presente l'oggetto diventa "popolare"
3272INTEGER,INTENT(IN),OPTIONAL :: month !< mesi, se presente l'oggetto diventa "popolare"
3273INTEGER,INTENT(IN),OPTIONAL :: day !< giorni
3274INTEGER,INTENT(IN),OPTIONAL :: hour !< ore
3275INTEGER,INTENT(IN),OPTIONAL :: minute !< minuti
3276INTEGER,INTENT(IN),OPTIONAL :: sec !< secondi
3277INTEGER,INTENT(IN),OPTIONAL :: msec !< millisecondi
3278CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate !< inizializza l'oggetto ad un intervallo nel formato \c GGGGGGGGGG \c hh:mm:ss.msc, ignorando tutti gli altri parametri
3279CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate !< inizializza l'oggetto ad un intervallo nel formato \c GGGGGGGGhhmmmsc, ignorando tutti gli altri parametri, da preferire rispetto a \a oraclesimdate
3280CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate !< inizializza l'oggetto ad un intervallo nel formato \c GGGGGGGGhhmm, ignorando tutti gli altri parametri
3281
3282TYPE(timedelta) :: this !< oggetto da inizializzare
3283
3284CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3285 isodate, simpledate, oraclesimdate)
3286
3287END FUNCTION timedelta_new
3288
3289
3290!> Costruisce un oggetto \a timedelta con i parametri opzionali forniti.
3291!! Se non viene passato nulla lo inizializza a intervallo di durata nulla.
3292!! L'intervallo ottenuto � pari alla somma dei valori di tutti i parametri
3293!! forniti, ovviamente non fornire un parametro equivale a fornirlo =0.
3294SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3295 isodate, simpledate, oraclesimdate)
3296TYPE(timedelta),INTENT(INOUT) :: this !< oggetto da inizializzare
3297INTEGER,INTENT(IN),OPTIONAL :: year !< anni, se presente l'oggetto diventa "popolare"
3298INTEGER,INTENT(IN),OPTIONAL :: month !< mesi, se presente l'oggetto diventa "popolare"
3299INTEGER,INTENT(IN),OPTIONAL :: day !< giorni
3300INTEGER,INTENT(IN),OPTIONAL :: hour !< ore
3301INTEGER,INTENT(IN),OPTIONAL :: minute !< minuti
3302INTEGER,INTENT(IN),OPTIONAL :: sec !< secondi
3303INTEGER,INTENT(IN),OPTIONAL :: msec !< millisecondi
3304CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate !< inizializza l'oggetto ad un intervallo nel formato \c AAAAMMGGGG \c hh:mm:ss.msc, ignorando tutti gli altri parametri, se \c AAAA o \c MM sono diversi da 0 l'oggetto diventa "popolare"
3305CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate !< inizializza l'oggetto ad un intervallo nel formato \c GGGGGGGGhhmmmsc, ignorando tutti gli altri parametri, da preferire rispetto a \a oraclesimdate
3306CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate !< inizializza l'oggetto ad un intervallo nel formato \c GGGGGGGGhhmm, ignorando tutti gli altri parametri
3307
3308INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3309CHARACTER(len=23) :: datebuf
3310
3311this%month = 0
3312
3313IF (PRESENT(isodate)) THEN
3314 datebuf(1:23) = '0000000000 00:00:00.000'
3315 l = len_trim(isodate)
3316! IF (l > 0) THEN
3317 n = index(trim(isodate), ' ') ! align blank space separator
3318 IF (n > 0) THEN
3319 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3320 datebuf(12-n:12-n+l-1) = isodate(:l)
3321 ELSE
3322 datebuf(1:l) = isodate(1:l)
3323 ENDIF
3324! ENDIF
3325
3326! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3327 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3328 h, m, s, ms
3329 this%month = lmonth + 12*lyear
3330 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3331 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3332 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3333 RETURN
3334
3335200 CONTINUE ! condizione di errore in isodate
3336 CALL delete(this)
3337 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3338 CALL raise_error()
3339
3340ELSE IF (PRESENT(simpledate)) THEN
3341 datebuf(1:17) = '00000000000000000'
3342 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3343 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3344 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3345 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3346 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3347
3348220 CONTINUE ! condizione di errore in simpledate
3349 CALL delete(this)
3350 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3351 CALL raise_error()
3352 RETURN
3353
3354ELSE IF (PRESENT(oraclesimdate)) THEN
3355 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3356 'obsoleto, usare piuttosto simpledate')
3357 READ(oraclesimdate, '(I8,2I2)')d, h, m
3358 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3359 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3360
3361ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3362 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3363 .and. .not. present(msec) .and. .not. present(isodate) &
3364 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3365
3366 this=timedelta_miss
3367
3368ELSE
3369 this%iminuti = 0
3370 IF (PRESENT(year)) THEN
3371 if (c_e(year))then
3372 this%month = this%month + year*12
3373 else
3374 this=timedelta_miss
3375 return
3376 end if
3377 ENDIF
3378 IF (PRESENT(month)) THEN
3379 if (c_e(month))then
3380 this%month = this%month + month
3381 else
3382 this=timedelta_miss
3383 return
3384 end if
3385 ENDIF
3386 IF (PRESENT(day)) THEN
3387 if (c_e(day))then
3388 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3389 else
3390 this=timedelta_miss
3391 return
3392 end if
3393 ENDIF
3394 IF (PRESENT(hour)) THEN
3395 if (c_e(hour))then
3396 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3397 else
3398 this=timedelta_miss
3399 return
3400 end if
3401 ENDIF
3402 IF (PRESENT(minute)) THEN
3403 if (c_e(minute))then
3404 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3405 else
3406 this=timedelta_miss
3407 return
3408 end if
3409 ENDIF
3410 IF (PRESENT(sec)) THEN
3411 if (c_e(sec))then
3412 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3413 else
3414 this=timedelta_miss
3415 return
3416 end if
3417 ENDIF
3418 IF (PRESENT(msec)) THEN
3419 if (c_e(msec))then
3420 this%iminuti = this%iminuti + msec
3421 else
3422 this=timedelta_miss
3423 return
3424 end if
3425 ENDIF
3426ENDIF
3427
3428
3429
3430
3431END SUBROUTINE timedelta_init
3432
3433
3434SUBROUTINE timedelta_delete(this)
3435TYPE(timedelta),INTENT(INOUT) :: this
3436
3437this%iminuti = imiss
3438this%month = 0
3439
3440END SUBROUTINE timedelta_delete
3441
3442
3443!> Restituisce il valore di un oggetto \a timedelta in una o pi�
3444!! modalit� desiderate. Qualsiasi combinazione dei parametri
3445!! opzionali � consentita. \a oraclesimedate �
3446!! obsoleto, usare piuttosto \a simpledate.
3447PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
3448 day, hour, minute, sec, msec, &
3449 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
3450TYPE(timedelta),INTENT(IN) :: this !< oggetto di cui restituire il valore
3451INTEGER,INTENT(OUT),OPTIONAL :: year !< anni, /=0 solo per intervalli "popolari"
3452INTEGER,INTENT(OUT),OPTIONAL :: month !< mesi modulo 12, /=0 solo per intervalli "popolari"
3453INTEGER,INTENT(OUT),OPTIONAL :: amonth !< mesi totali, /=0 solo per intervalli "popolari"
3454INTEGER,INTENT(OUT),OPTIONAL :: day !< giorni totali
3455INTEGER,INTENT(OUT),OPTIONAL :: hour !< ore modulo 24
3456INTEGER,INTENT(OUT),OPTIONAL :: minute !< minuti modulo 60
3457INTEGER,INTENT(OUT),OPTIONAL :: sec !< secondi modulo 60
3458INTEGER,INTENT(OUT),OPTIONAL :: msec !< millisecondi modulo 1000
3459INTEGER,INTENT(OUT),OPTIONAL :: ahour !< ore totali
3460INTEGER,INTENT(OUT),OPTIONAL :: aminute !< minuti totali
3461INTEGER,INTENT(OUT),OPTIONAL :: asec !< secondi totali
3462INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec !< millisecondi totali
3463CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate !< intervallo totale nel formato \c GGGGGGGGGG \c hh:mm:ss.msc (simil-ISO), la variabile può essere più corta di 23 caratteri, in tal caso conterr� solo ci� che vi cape
3464CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate !< intervallo totale nel formato \c GGGGGGGGhhmmssmsc , la variabile pu� essere pi� corta di 17 caratteri, in tal caso conterr� solo ci� che vi cape, da preferire rispetto a \a oraclesimdate
3465CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate !< intervallo totale nel formato \c GGGGGGGGhhmm
3466
3467CHARACTER(len=23) :: datebuf
3468
3469IF (PRESENT(amsec)) THEN
3470 amsec = this%iminuti
3471ENDIF
3472IF (PRESENT(asec)) THEN
3473 asec = int(this%iminuti/1000_int_ll)
3474ENDIF
3475IF (PRESENT(aminute)) THEN
3476 aminute = int(this%iminuti/60000_int_ll)
3477ENDIF
3478IF (PRESENT(ahour)) THEN
3479 ahour = int(this%iminuti/3600000_int_ll)
3480ENDIF
3481IF (PRESENT(msec)) THEN
3482 msec = int(mod(this%iminuti, 1000_int_ll))
3483ENDIF
3484IF (PRESENT(sec)) THEN
3485 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
3486ENDIF
3487IF (PRESENT(minute)) THEN
3488 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
3489ENDIF
3490IF (PRESENT(hour)) THEN
3491 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
3492ENDIF
3493IF (PRESENT(day)) THEN
3494 day = int(this%iminuti/86400000_int_ll)
3495ENDIF
3496IF (PRESENT(amonth)) THEN
3497 amonth = this%month
3498ENDIF
3499IF (PRESENT(month)) THEN
3500 month = mod(this%month-1,12)+1
3501ENDIF
3502IF (PRESENT(year)) THEN
3503 year = this%month/12
3504ENDIF
3505IF (PRESENT(isodate)) THEN ! Non standard, inventato!
3506 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3507 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), ':', &
3508 mod(this%iminuti/60000_int_ll, 60_int_ll), ':', mod(this%iminuti/1000_int_ll, 60_int_ll), &
3509 '.', mod(this%iminuti, 1000_int_ll)
3510 isodate = datebuf(1:min(len(isodate),23))
3511
3512ENDIF
3513IF (PRESENT(simpledate)) THEN
3514 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
3515 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
3516 mod(this%iminuti/60000_int_ll, 60_int_ll), mod(this%iminuti/1000_int_ll, 60_int_ll), &
3517 mod(this%iminuti, 1000_int_ll)
3518 simpledate = datebuf(1:min(len(simpledate),17))
3519ENDIF
3520IF (PRESENT(oraclesimdate)) THEN
3521!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
3522!!$ 'obsoleto, usare piuttosto simpledate')
3523 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
3524 mod(this%iminuti/3600000_int_ll, 24_int_ll), mod(this%iminuti/60000_int_ll, 60_int_ll)
3525ENDIF
3526
3527END SUBROUTINE timedelta_getval
3528
3529
3530!> Restituisce una rappresentazione carattere stampabile di un oggetto
3531!! \a timedelta.
3532elemental FUNCTION timedelta_to_char(this) RESULT(char)
3533TYPE(timedelta),INTENT(IN) :: this
3534
3535CHARACTER(len=23) :: char
3536
3537CALL getval(this, isodate=char)
3538
3539END FUNCTION timedelta_to_char
3540
3541
3542FUNCTION trim_timedelta_to_char(in) RESULT(char)
3543TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
3544
3545CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
3546
3547char=timedelta_to_char(in)
3548
3549END FUNCTION trim_timedelta_to_char
3550
3551
3552!> Restituisce il valore in millisecondi totali di un oggetto \a timedelta.
3553elemental FUNCTION timedelta_getamsec(this)
3554TYPE(timedelta),INTENT(IN) :: this !< oggetto di cui restituire il valore
3555INTEGER(kind=int_ll) :: timedelta_getamsec !< millisecondi totali
3556
3557timedelta_getamsec = this%iminuti
3558
3559END FUNCTION timedelta_getamsec
3560
3561
3562!> Depopularize a \a timedelta object.
3563!! If the object represents a "popular" or mixed interval, a fixed
3564!! interval representation is returned, by recomputing it on a
3565!! standard period (starting from 1970-01-01); if it represents
3566!! already a fixed interval, the same object is returned.
3567FUNCTION timedelta_depop(this)
3568TYPE(timedelta),INTENT(IN) :: this !< object to be depopularized
3569TYPE(timedelta) :: timedelta_depop
3570
3571TYPE(datetime) :: tmpdt
3572
3573IF (this%month == 0) THEN
3574 timedelta_depop = this
3575ELSE
3576 tmpdt = datetime_new(1970, 1, 1)
3577 timedelta_depop = (tmpdt + this) - tmpdt
3578ENDIF
3579
3580END FUNCTION timedelta_depop
3581
3582
3583elemental FUNCTION timedelta_eq(this, that) RESULT(res)
3584TYPE(timedelta),INTENT(IN) :: this, that
3585LOGICAL :: res
3586
3587res = (this%iminuti == that%iminuti .AND. this%month == that%month)
3588
3589END FUNCTION timedelta_eq
3590
3591
3592ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
3593TYPE(timedelta),INTENT(IN) :: this, that
3594LOGICAL :: res
3595
3596res = .NOT.(this == that)
3597
3598END FUNCTION timedelta_ne
3599
3600
3601ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
3602TYPE(timedelta),INTENT(IN) :: this, that
3603LOGICAL :: res
3604
3605res = this%iminuti > that%iminuti
3606
3607END FUNCTION timedelta_gt
3608
3609
3610ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
3611TYPE(timedelta),INTENT(IN) :: this, that
3612LOGICAL :: res
3613
3614res = this%iminuti < that%iminuti
3615
3616END FUNCTION timedelta_lt
3617
3618
3619ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
3620TYPE(timedelta),INTENT(IN) :: this, that
3621LOGICAL :: res
3622
3623IF (this == that) THEN
3624 res = .true.
3625ELSE IF (this > that) THEN
3626 res = .true.
3627ELSE
3628 res = .false.
3629ENDIF
3630
3631END FUNCTION timedelta_ge
3632
3633
3634elemental FUNCTION timedelta_le(this, that) RESULT(res)
3635TYPE(timedelta),INTENT(IN) :: this, that
3636LOGICAL :: res
3637
3638IF (this == that) THEN
3639 res = .true.
3640ELSE IF (this < that) THEN
3641 res = .true.
3642ELSE
3643 res = .false.
3644ENDIF
3645
3646END FUNCTION timedelta_le
3647
3648
3649ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
3650TYPE(timedelta),INTENT(IN) :: this, that
3651TYPE(timedelta) :: res
3652
3653res%iminuti = this%iminuti + that%iminuti
3654res%month = this%month + that%month
3655
3656END FUNCTION timedelta_add
3657
3658
3659ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
3660TYPE(timedelta),INTENT(IN) :: this, that
3661TYPE(timedelta) :: res
3662
3663res%iminuti = this%iminuti - that%iminuti
3664res%month = this%month - that%month
3665
3666END FUNCTION timedelta_sub
3667
3668
3669ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
3670TYPE(timedelta),INTENT(IN) :: this
3671INTEGER,INTENT(IN) :: n
3672TYPE(timedelta) :: res
3673
3674res%iminuti = this%iminuti*n
3675res%month = this%month*n
3676
3677END FUNCTION timedelta_mult
3678
3679
3680ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
3681INTEGER,INTENT(IN) :: n
3682TYPE(timedelta),INTENT(IN) :: this
3683TYPE(timedelta) :: res
3684
3685res%iminuti = this%iminuti*n
3686res%month = this%month*n
3687
3688END FUNCTION timedelta_tlum
3689
3690
3691ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
3692TYPE(timedelta),INTENT(IN) :: this
3693INTEGER,INTENT(IN) :: n
3694TYPE(timedelta) :: res
3695
3696res%iminuti = this%iminuti/n
3697res%month = this%month/n
3698
3699END FUNCTION timedelta_divint
3700
3701
3702ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
3703TYPE(timedelta),INTENT(IN) :: this, that
3704INTEGER :: res
3705
3706res = int(this%iminuti/that%iminuti)
3707
3708END FUNCTION timedelta_divtd
3709
3710
3711elemental FUNCTION timedelta_mod(this, that) RESULT(res)
3712TYPE(timedelta),INTENT(IN) :: this, that
3713TYPE(timedelta) :: res
3714
3715res%iminuti = mod(this%iminuti, that%iminuti)
3716res%month = 0
3717
3718END FUNCTION timedelta_mod
3719
3720
3721ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
3722TYPE(datetime),INTENT(IN) :: this
3723TYPE(timedelta),INTENT(IN) :: that
3724TYPE(timedelta) :: res
3725
3726IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
3727 res = timedelta_0
3728ELSE
3729 res%iminuti = mod(this%iminuti, that%iminuti)
3730 res%month = 0
3731ENDIF
3732
3733END FUNCTION datetime_timedelta_mod
3734
3735
3736ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
3737TYPE(timedelta),INTENT(IN) :: this
3738TYPE(timedelta) :: res
3739
3740res%iminuti = abs(this%iminuti)
3741res%month = abs(this%month)
3742
3743END FUNCTION timedelta_abs
3744
3745
3746!> This method reads from a Fortran file unit the contents of the
3747!! object \a this. The record to be read must have been written with
3748!! the ::write_unit method. The method works both on formatted and
3749!! unformatted files.
3750SUBROUTINE timedelta_read_unit(this, unit)
3751TYPE(timedelta),INTENT(out) :: this !< object to be read
3752INTEGER, INTENT(in) :: unit !< unit from which to read, it must be an opened Fortran file unit
3753
3754CALL timedelta_vect_read_unit((/this/), unit)
3755
3756END SUBROUTINE timedelta_read_unit
3757
3758
3759!> This method reads from a Fortran file unit the contents of the
3760!! object \a this. The record to be read must have been written with
3761!! the ::write_unit method. The method works both on formatted and
3762!! unformatted files.
3763SUBROUTINE timedelta_vect_read_unit(this, unit)
3764TYPE(timedelta) :: this(:) !< object to be read
3765INTEGER, INTENT(in) :: unit !< unit from which to read, it must be an opened Fortran file unit
3766
3767CHARACTER(len=40) :: form
3768CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3769INTEGER :: i
3770
3771ALLOCATE(dateiso(SIZE(this)))
3772INQUIRE(unit, form=form)
3773IF (form == 'FORMATTED') THEN
3774 READ(unit,'(3(A23,1X))')dateiso
3775ELSE
3776 READ(unit)dateiso
3777ENDIF
3778DO i = 1, SIZE(dateiso)
3779 CALL init(this(i), isodate=dateiso(i))
3780ENDDO
3781DEALLOCATE(dateiso)
3782
3783END SUBROUTINE timedelta_vect_read_unit
3784
3785
3786!> This method writes on a Fortran file unit the contents of the
3787!! object \a this. The record can successively be read by the
3788!! ::read_unit method. The method works both on formatted and
3789!! unformatted files.
3790SUBROUTINE timedelta_write_unit(this, unit)
3791TYPE(timedelta),INTENT(in) :: this !< object to be written
3792INTEGER, INTENT(in) :: unit !< unit where to write, it must be an opened Fortran file unit
3793
3794CALL timedelta_vect_write_unit((/this/), unit)
3795
3796END SUBROUTINE timedelta_write_unit
3797
3798
3799!> This method writes on a Fortran file unit the contents of the
3800!! object \a this. The record can successively be read by the
3801!! ::read_unit method. The method works both on formatted and
3802!! unformatted files.
3803SUBROUTINE timedelta_vect_write_unit(this, unit)
3804TYPE(timedelta),INTENT(in) :: this(:) !< object to be written
3805INTEGER, INTENT(in) :: unit !< unit where to write, it must be an opened Fortran file unit
3806
3807CHARACTER(len=40) :: form
3808CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3809INTEGER :: i
3810
3811ALLOCATE(dateiso(SIZE(this)))
3812DO i = 1, SIZE(dateiso)
3813 CALL getval(this(i), isodate=dateiso(i))
3814ENDDO
3815INQUIRE(unit, form=form)
3816IF (form == 'FORMATTED') THEN
3817 WRITE(unit,'(3(A23,1X))')dateiso
3818ELSE
3819 WRITE(unit)dateiso
3820ENDIF
3821DEALLOCATE(dateiso)
3822
3823END SUBROUTINE timedelta_vect_write_unit
3824
3825
3826ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
3827TYPE(timedelta),INTENT(in) :: this
3828LOGICAL :: res
3829
3830res = .not. this == timedelta_miss
3831
3832end FUNCTION c_e_timedelta
3833
3834
3835elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
3836
3837!!omstart JELADATA5
3838! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3839! 1 IMINUTI)
3840!
3841! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
3842!
3843! variabili integer*4
3844! IN:
3845! IDAY,IMONTH,IYEAR, I*4
3846! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3847!
3848! OUT:
3849! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3850!!OMEND
3851
3852INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
3853INTEGER,intent(out) :: iminuti
3854
3855iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
3856
3857END SUBROUTINE jeladata5
3858
3859
3860elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
3861INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
3862INTEGER(KIND=int_ll),intent(out) :: imillisec
3863
3864imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
3865 + imsec
3866
3867END SUBROUTINE jeladata5_1
3868
3869
3870
3871elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
3872
3873!!omstart JELADATA6
3874! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
3875! 1 IMINUTI)
3876!
3877! Calcola la data e l'ora corrispondente a IMINUTI dopo il
3878! 1/1/1
3879!
3880! variabili integer*4
3881! IN:
3882! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
3883!
3884! OUT:
3885! IDAY,IMONTH,IYEAR, I*4
3886! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
3887!!OMEND
3888
3889
3890INTEGER,intent(in) :: iminuti
3891INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
3892
3893INTEGER ::igiorno
3894
3895imin = mod(iminuti,60)
3896ihour = mod(iminuti,1440)/60
3897igiorno = iminuti/1440
3898IF (mod(iminuti,1440) < 0) igiorno = igiorno-1
3899CALL ndyin(igiorno,iday,imonth,iyear)
3900
3901END SUBROUTINE jeladata6
3902
3903
3904elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
3905INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
3906INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
3907
3908INTEGER :: igiorno
3909
3910imsec = int(mod(imillisec, 60000_int_ll)) ! partial msec
3911!imin = MOD(imillisec/60000_int_ll, 60)
3912!ihour = MOD(imillisec/3600000_int_ll, 24)
3913imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
3914ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
3915igiorno = int(imillisec/86400000_int_ll)
3916!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
3917CALL ndyin(igiorno,iday,imonth,iyear)
3918
3919END SUBROUTINE jeladata6_1
3920
3921
3922elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
3923
3924!!OMSTART NDYIN
3925! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
3926! restituisce la data fornendo in input il numero di
3927! giorni dal 1/1/1
3928!
3929!!omend
3930
3931INTEGER,intent(in) :: ndays
3932INTEGER,intent(out) :: igg, imm, iaa
3933integer :: n,lndays
3934
3935lndays=ndays
3936
3937n = lndays/d400
3938lndays = lndays - n*d400
3939iaa = year0 + n*400
3940n = min(lndays/d100, 3)
3941lndays = lndays - n*d100
3942iaa = iaa + n*100
3943n = lndays/d4
3944lndays = lndays - n*d4
3945iaa = iaa + n*4
3946n = min(lndays/d1, 3)
3947lndays = lndays - n*d1
3948iaa = iaa + n
3949n = bisextilis(iaa)
3950DO imm = 1, 12
3951 IF (lndays < ianno(imm+1,n)) EXIT
3952ENDDO
3953igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
3954
3955END SUBROUTINE ndyin
3956
3957
3958integer elemental FUNCTION ndays(igg,imm,iaa)
3959
3960!!OMSTART NDAYS
3961! FUNCTION NDAYS(IGG,IMM,IAA)
3962! restituisce il numero di giorni dal 1/1/1
3963! fornendo in input la data
3964!
3965!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3966! nota bene E' SICURO !!!
3967! un anno e' bisestile se divisibile per 4
3968! un anno rimane bisestile se divisibile per 400
3969! un anno NON e' bisestile se divisibile per 100
3970!
3971!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3972!
3973!!omend
3974
3975INTEGER, intent(in) :: igg, imm, iaa
3976
3977INTEGER :: lmonth, lyear
3978
3979! Limito il mese a [1-12] e correggo l'anno coerentemente
3980lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
3981lyear = iaa + (imm - lmonth)/12
3982ndays = igg+ianno(lmonth, bisextilis(lyear))
3983ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
3984 (lyear-year0)/400
3985
3986END FUNCTION ndays
3987
3988
3989elemental FUNCTION bisextilis(annum)
3990INTEGER,INTENT(in) :: annum
3991INTEGER :: bisextilis
3992
3993IF (mod(annum,4) == 0 .AND. (mod(annum,400) == 0 .EQV. mod(annum,100) == 0)) THEN
3994 bisextilis = 2
3995ELSE
3996 bisextilis = 1
3997ENDIF
3998END FUNCTION bisextilis
3999
4000
4001ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4002TYPE(cyclicdatetime),INTENT(IN) :: this, that
4003LOGICAL :: res
4004
4005res = .true.
4006if (this%minute /= that%minute) res=.false.
4007if (this%hour /= that%hour) res=.false.
4008if (this%day /= that%day) res=.false.
4009if (this%month /= that%month) res=.false.
4010if (this%tendaysp /= that%tendaysp) res=.false.
4011
4012END FUNCTION cyclicdatetime_eq
4013
4014
4015ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4016TYPE(cyclicdatetime),INTENT(IN) :: this
4017TYPE(datetime),INTENT(IN) :: that
4018LOGICAL :: res
4019
4020integer :: minute,hour,day,month
4021
4022call getval(that,minute=minute,hour=hour,day=day,month=month)
4023
4024res = .true.
4025if (c_e(this%minute) .and. this%minute /= minute) res=.false.
4026if (c_e(this%hour) .and. this%hour /= hour) res=.false.
4027if (c_e(this%day) .and. this%day /= day) res=.false.
4028if (c_e(this%month) .and. this%month /= month) res=.false.
4029if (c_e(this%tendaysp)) then
4030 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4031end if
4032
4033END FUNCTION cyclicdatetime_datetime_eq
4034
4035
4036ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4037TYPE(datetime),INTENT(IN) :: this
4038TYPE(cyclicdatetime),INTENT(IN) :: that
4039LOGICAL :: res
4040
4041integer :: minute,hour,day,month
4042
4043call getval(this,minute=minute,hour=hour,day=day,month=month)
4044
4045res = .true.
4046if (c_e(that%minute) .and. that%minute /= minute) res=.false.
4047if (c_e(that%hour) .and. that%hour /= hour) res=.false.
4048if (c_e(that%day) .and. that%day /= day) res=.false.
4049if (c_e(that%month) .and. that%month /= month) res=.false.
4050
4051if (c_e(that%tendaysp)) then
4052 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4053end if
4054
4055
4056END FUNCTION datetime_cyclicdatetime_eq
4057
4058ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4059TYPE(cyclicdatetime),INTENT(in) :: this
4060LOGICAL :: res
4061
4062res = .not. this == cyclicdatetime_miss
4063
4064end FUNCTION c_e_cyclicdatetime
4065
4066
4067!> Costruisce un oggetto \a cyclicdatetime con i parametri opzionali forniti.
4068!! Se non viene passato nulla lo inizializza a missing.
4069FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4070INTEGER,INTENT(IN),OPTIONAL :: tendaysp !< ten days period in month (1, 2, 3)
4071INTEGER,INTENT(IN),OPTIONAL :: month !< mese, default=missing
4072INTEGER,INTENT(IN),OPTIONAL :: day !< mese, default=missing
4073INTEGER,INTENT(IN),OPTIONAL :: hour !< ore, default=missing
4074INTEGER,INTENT(IN),OPTIONAL :: minute !< minuti, default=missing
4075CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate !< inizializza l'oggetto ad una data espressa nel formato \c TMMGGhhmm where any doubled char should be // for missing. This parameter have priority on others also if set to missing.
4076
4077integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4078
4079
4080TYPE(cyclicdatetime) :: this !< oggetto da inizializzare
4081
4082if (present(chardate)) then
4083
4084 ltendaysp=imiss
4085 lmonth=imiss
4086 lday=imiss
4087 lhour=imiss
4088 lminute=imiss
4089
4090 if (c_e(chardate))then
4091 ! TMMGGhhmm
4092 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4093 !print*,chardate(1:1),ios,ltendaysp
4094 if (ios /= 0)ltendaysp=imiss
4095
4096 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4097 !print*,chardate(2:3),ios,lmonth
4098 if (ios /= 0)lmonth=imiss
4099
4100 read(chardate(4:5),'(i2)',iostat=ios)lday
4101 !print*,chardate(4:5),ios,lday
4102 if (ios /= 0)lday=imiss
4103
4104 read(chardate(6:7),'(i2)',iostat=ios)lhour
4105 !print*,chardate(6:7),ios,lhour
4106 if (ios /= 0)lhour=imiss
4107
4108 read(chardate(8:9),'(i2)',iostat=ios)lminute
4109 !print*,chardate(8:9),ios,lminute
4110 if (ios /= 0)lminute=imiss
4111 end if
4112
4113 this%tendaysp=ltendaysp
4114 this%month=lmonth
4115 this%day=lday
4116 this%hour=lhour
4117 this%minute=lminute
4118else
4119 this%tendaysp=optio_l(tendaysp)
4120 this%month=optio_l(month)
4121 this%day=optio_l(day)
4122 this%hour=optio_l(hour)
4123 this%minute=optio_l(minute)
4124end if
4125
4126END FUNCTION cyclicdatetime_new
4127
4128!> Restituisce una rappresentazione carattere stampabile di un oggetto
4129!! \a cyclicdatetime.
4130elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4131TYPE(cyclicdatetime),INTENT(IN) :: this
4132
4133CHARACTER(len=80) :: char
4134
4135char=to_char(this%tendaysp)//";"//to_char(this%month)//";"//to_char(this%day)//";"//&
4136to_char(this%hour)//";"//to_char(this%minute)
4137
4138END FUNCTION cyclicdatetime_to_char
4139
4140
4141!> Restituisce una rappresentazione convenzionale in forma datetime
4142!! \a cyclicdatetime.
4143!! The following conventional code values are used to specify which data was taken into account in the computation:
4144!! year=1001 : dayly values of a specified month (depends by day and month)
4145!! year=1002 : dayly,hourly values of a specified month (depends by day and month and hour)
4146!! year=1003 : 10 day period of a specified month (depends by day(1,11,21) and month)
4147!! year=1004 : 10 day period of a specified month,hourly (depends by day(1,11,21) and month and hour)
4148!! year=1005 : mounthly values (depend by month)
4149!! year=1006 : mounthly,hourly values (depend by month and hour)
4150!! year=1007 : yearly values (no other time dependence)
4151!! year=1008 : yearly,hourly values (depend by year and hour)
4152!! The other conventional month hour and minute should be 01 when they are not significative, day should be 1 or, if year=1003 or year=1004 is used, 1,11 or 21.
4153FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4154TYPE(cyclicdatetime),INTENT(IN) :: this !< cycliddatetime to use in compute
4155
4156TYPE(datetime) :: dtc
4157
4158integer :: year,month,day,hour
4159
4160dtc = datetime_miss
4161
4162! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4163if ( .not. c_e(this)) then
4164 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4165 return
4166end if
4167
4168! minute present -> not good for conventional datetime
4169if (c_e(this%minute)) return
4170! day, month and tendaysp present -> no good
4171if (c_e(this%day) .and. c_e(this%month) .and. c_e(this%tendaysp)) return
4172
4173if (c_e(this%day) .and. c_e(this%month)) then
4174 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4175else if (c_e(this%tendaysp) .and. c_e(this%month)) then
4176 day=(this%tendaysp-1)*10+1
4177 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4178else if (c_e(this%month)) then
4179 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4180else if (c_e(this%day)) then
4181 ! only day present -> no good
4182 return
4183end if
4184
4185if (c_e(this%hour)) then
4186 call getval(dtc,year=year,month=month,day=day,hour=hour)
4187 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4188end if
4189
4190
4191END FUNCTION cyclicdatetime_to_conventional
4192
4193
4194
4195FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4196TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4197
4198CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4199
4200char=cyclicdatetime_to_char(in)
4201
4202END FUNCTION trim_cyclicdatetime_to_char
4203
4204
4205
4206SUBROUTINE display_cyclicdatetime(this)
4207TYPE(cyclicdatetime),INTENT(in) :: this
4208
4209print*,"CYCLICDATETIME: ",to_char(this)
4210
4211end subroutine display_cyclicdatetime
4212
4213
4214#include "array_utilities_inc.F90"
4215
4216END MODULE datetime_class
4217
Operatore di valore assoluto di un intervallo.
Quick method to append an element to the array.
Distruttori per le 2 classi.
Restituiscono il valore dell'oggetto nella forma desiderata.
Index method with sorted array.
Costruttori per le classi datetime e timedelta.
Method for inserting elements of the array at a desired position.
Operatore di resto della divisione.
Method for packing the array object reducing at a minimum the memory occupation, without destroying i...
Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o...
Method for removing elements of the array at a desired position.
Functions that return a trimmed CHARACTER representation of the input variable.
Restituiscono il valore dell'oggetto in forma di stringa stampabile.
Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ...
Index method.
Utilities for CHARACTER variables.
Classi per la gestione delle coordinate temporali.
Gestione degli errori.
Definition of constants to be used for declaring variables of a desired type.
Definition kinds.F90:245
classe per la gestione del logging
Definitions of constants and functions for working with missing values.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Class for expressing a cyclic datetime.
Class for expressing an absolute time value.
Class for expressing a relative time interval.

Generated with Doxygen.