libsim Versione 7.2.6

◆ count_distinct_datetime()

integer function count_distinct_datetime ( type(datetime), dimension(:), intent(in) vect,
logical, dimension(:), intent(in), optional mask,
logical, intent(in), optional back )
private

conta gli elementi distinti in vect

Definizione alla linea 2522 del file datetime_class.F90.

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