libsim Versione 7.2.6

◆ pack_distinct_sorted_datetime()

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

compatta gli elementi distinti di vect in un sorted array

Definizione alla linea 2599 del file datetime_class.F90.

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