libsim Versione 7.2.6
|
◆ inssor_datetime()
Sorts into increasing order (Insertion sort) Sorts XDONT into increasing order (Insertion sort) This subroutine uses insertion sort. It does not use any work array and is faster when XDONT is of very small size (< 20), or already almost sorted, so it is used in a final pass when the partial quicksorting has left a sequence of small subsets and that sorting is only necessary within each subset to complete the process. Michel Olagnon - Apr. 2000 Definizione alla linea 3287 del file datetime_class.F90. 3288! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
3289! authors:
3290! Davide Cesari <dcesari@arpa.emr.it>
3291! Paolo Patruno <ppatruno@arpa.emr.it>
3292
3293! This program is free software; you can redistribute it and/or
3294! modify it under the terms of the GNU General Public License as
3295! published by the Free Software Foundation; either version 2 of
3296! the License, or (at your option) any later version.
3297
3298! This program is distributed in the hope that it will be useful,
3299! but WITHOUT ANY WARRANTY; without even the implied warranty of
3300! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3301! GNU General Public License for more details.
3302
3303! You should have received a copy of the GNU General Public License
3304! along with this program. If not, see <http://www.gnu.org/licenses/>.
3305#include "config.h"
3306!> \brief Classi per la gestione delle coordinate temporali.
3307!!
3308!! Questo module definisce un paio di classi per la gestione di
3309!! date assolute e di intervalli temporali.
3310!! Entrambe le classi hanno le componenti di tipo \c PRIVATE, per
3311!! cui non possono essere manipolate direttamente ma solo tramite i
3312!! relativi metodi. Attualmente la precisione massima consentita � di un
3313!! minuto, mentre l'estensione delle date rappresentabili va dall'anno 1
3314!! all'anno 4074 d.C. circa, ipotizzando un calendario gregoriano per
3315!! tutto il periodo. Questo fatto implica che le date precedenti
3316!! all'introduzione del calendario gregoriano avranno discrepanze di uno
3317!! o pi� giorni rispetto alle date storiche "vere", ammesso che
3318!! qualcuno conosca queste ultime.
3319!! \ingroup base
3327IMPLICIT NONE
3328
3329INTEGER, PARAMETER :: dateint=selected_int_kind(13)
3330
3331!> Class for expressing an absolute time value.
3333 PRIVATE
3334 INTEGER(KIND=int_ll) :: iminuti
3336
3337!> Class for expressing a relative time interval.
3338!! It can take also negative values. According to how it is
3339!! initilasied, it can indicate an interval of fixed duration, or a
3340!! "calendar" interval of variable duration in units of months and/or
3341!! years or even a mix of the two, however, in the latter two cases
3342!! the operations that can be made with objects of this class are
3343!! restricted.
3345 PRIVATE
3346 INTEGER(KIND=int_ll) :: iminuti
3347 INTEGER :: month
3349
3350
3351!> Class for expressing a cyclic datetime.
3352!! It can be used to specify, for example, every January in all years
3353!! or the same time for all days and so on.
3355 PRIVATE
3356 INTEGER :: minute
3357 INTEGER :: hour
3358 INTEGER :: day
3359 INTEGER :: tendaysp
3360 INTEGER :: month
3362
3363
3364!> valore mancante per datetime
3366!> valore mancante per timedelta
3368!> intervallo timedelta di durata nulla
3370!> inizializza con l'ora UTC
3371INTEGER, PARAMETER :: datetime_utc=1
3372!> inizializza con l'ora locale
3373INTEGER, PARAMETER :: datetime_local=2
3374!> Minimum valid value for datetime
3376!> Minimum valid value for datetime
3378!> Minimum valid value for timedelta
3380!> Minimum valid value for timedelta
3382!> missing value for cyclicdatetime
3383TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
3384
3385
3386INTEGER(kind=dateint), PARAMETER :: &
3387 sec_in_day=86400, &
3388 sec_in_hour=3600, &
3389 sec_in_min=60, &
3390 min_in_day=1440, &
3391 min_in_hour=60, &
3392 hour_in_day=24
3393
3394INTEGER,PARAMETER :: &
3395 year0=1, & ! anno di origine per iminuti
3396 d1=365, & ! giorni/1 anno nel calendario gregoriano
3397 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
3398 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
3399 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
3400 ianno(13,2)=reshape((/ &
3401 0,31,59,90,120,151,181,212,243,273,304,334,365, &
3402 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
3403
3404INTEGER(KIND=int_ll),PARAMETER :: &
3405 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
3406
3407!> Costruttori per le classi datetime e timedelta. Devono essere richiamati
3408!! per tutti gli oggetti di questo tipo definiti in un programma
3409!! tranne i casi in cui un oggetto viene creato per assegnazione.
3411 MODULE PROCEDURE datetime_init, timedelta_init
3412END INTERFACE
3413
3414!> Distruttori per le 2 classi. Distruggono gli oggetti in maniera pulita,
3415!! assegnando loro un valore mancante.
3417 MODULE PROCEDURE datetime_delete, timedelta_delete
3418END INTERFACE
3419
3420!> Restituiscono il valore dell'oggetto nella forma desiderata.
3422 MODULE PROCEDURE datetime_getval, timedelta_getval
3423END INTERFACE
3424
3425!> Restituiscono il valore dell'oggetto in forma di stringa stampabile.
3427 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
3428END INTERFACE
3429
3430
3431!> Functions that return a trimmed CHARACTER representation of the
3432!! input variable. The functions are analogous to \a to_char but they
3433!! return representation of the input in a CHARACTER with a variable
3434!! length, which needs not to be trimmed before use. The optional
3435!! format here is not accepted and these functions are not \a
3436!! ELEMENTAL so they work only on scalar arguments.
3437!!
3438!! \param in (datetime or timedelta) value to be represented as CHARACTER
3439!!
3440!! Example of use:
3441!! \code
3442!! USE datetime_class
3443!! type(datetime) :: t
3444!! ...
3445!! WRITE(*,*)'The value provided is, '//t2c(t)'
3446!! ...
3447!! \endcode
3449 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
3450END INTERFACE
3451
3452!> Operatore logico di uguaglianza tra oggetti della stessa classe.
3453!! Funziona anche per
3454!! confronti di tipo array-array (qualsiasi n. di dimensioni) e di tipo
3455!! scalare-vettore(1-d) (ma non vettore(1-d)-scalare o tra array con pi�
3456!! di 1 dimensione e scalari).
3457INTERFACE OPERATOR (==)
3458 MODULE PROCEDURE datetime_eq, timedelta_eq, &
3459 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
3460END INTERFACE
3461
3462!> Operatore logico di disuguaglianza tra oggetti della stessa classe.
3463!! Funziona anche per
3464!! confronti di tipo array-array (qualsiasi n. di dimensioni) e di tipo
3465!! scalare-vettore(1-d) (ma non vettore(1-d)-scalare o tra array con pi�
3466!! di 1 dimensione e scalari).
3467INTERFACE OPERATOR (/=)
3468 MODULE PROCEDURE datetime_ne, timedelta_ne
3469END INTERFACE
3470
3471!> Operatore logico maggiore tra oggetti della stessa classe.
3472!! Funziona anche per
3473!! confronti di tipo array-array (qualsiasi n. di dimensioni) e di tipo
3474!! scalare-vettore(1-d) (ma non vettore(1-d)-scalare o tra array con pi�
3475!! di 1 dimensione e scalari). Nel caso di valori mancanti il risultato
3476!! non � specificato. Il risultato non � altres� specificato nel caso di oggetti
3477!! \a timedelta "popolari" o misti.
3478INTERFACE OPERATOR (>)
3479 MODULE PROCEDURE datetime_gt, timedelta_gt
3480END INTERFACE
3481
3482!> Operatore logico minore tra oggetti della stessa classe.
3483!! Funziona anche per
3484!! confronti di tipo array-array (qualsiasi n. di dimensioni) e di tipo
3485!! scalare-vettore(1-d) (ma non vettore(1-d)-scalare o tra array con pi�
3486!! di 1 dimensione e scalari). Nel caso di valori mancanti il risultato
3487!! non � specificato. Il risultato non � altres� specificato nel caso di oggetti
3488!! \a timedelta "popolari" o misti.
3489INTERFACE OPERATOR (<)
3490 MODULE PROCEDURE datetime_lt, timedelta_lt
3491END INTERFACE
3492
3493!> Operatore logico maggiore-uguale tra oggetti della stessa classe.
3494!! Funziona anche per
3495!! confronti di tipo array-array (qualsiasi n. di dimensioni) e di tipo
3496!! scalare-vettore(1-d) (ma non vettore(1-d)-scalare o tra array con pi�
3497!! di 1 dimensione e scalari). Nel caso di valori mancanti il risultato
3498!! non � specificato. Il risultato non � altres� specificato nel caso di oggetti
3499!! \a timedelta "popolari" o misti.
3500INTERFACE OPERATOR (>=)
3501 MODULE PROCEDURE datetime_ge, timedelta_ge
3502END INTERFACE
3503
3504!> Operatore logico minore-uguale tra oggetti della stessa classe.
3505!! Funziona anche per
3506!! confronti di tipo array-array (qualsiasi n. di dimensioni) e di tipo
3507!! scalare-vettore(1-d) (ma non vettore(1-d)-scalare o tra array con pi�
3508!! di 1 dimensione e scalari). Nel caso di valori mancanti il risultato
3509!! non � specificato. Il risultato non � altres� specificato nel caso di oggetti
3510!! \a timedelta "popolari" o misti.
3511INTERFACE OPERATOR (<=)
3512 MODULE PROCEDURE datetime_le, timedelta_le
3513END INTERFACE
3514
3515!> Operatore di somma per datetime e timedelta. Solo alcune combinazioni
3516!! sono definite:
3517!! - \a timedelta + \a timedelta = \a timedelta
3518!! - \a datetime + \a timedelta = \a datetime
3519!! .
3520!! Funzionano anche con oggetti \a timedelta "popolari" o misti.
3521INTERFACE OPERATOR (+)
3522 MODULE PROCEDURE datetime_add, timedelta_add
3523END INTERFACE
3524
3525!> Operatore di sottrazione per datetime e timedelta. Solo alcune combinazioni
3526!! sono definite:
3527!! - \a timedelta - \a timedelta = \a timedelta
3528!! - \a datetime - \a timedelta = \a datetime
3529!! - \a datetime - \a datetime = \a timedelta
3530!! .
3531!! Funzionano anche con oggetti \a timedelta "popolari" o misti.
3532INTERFACE OPERATOR (-)
3533 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
3534END INTERFACE
3535
3536!> Operatore di moltiplicazione di timedelta per uno scalare. Sono definite:
3537!! - \a timedelta * \a INTEGER = \a timedelta
3538!! - \a INTEGER * \a timedelta = \a timedelta
3539!! .
3540!! Funzionano anche con oggetti \a timedelta "popolari" o misti.
3541INTERFACE OPERATOR (*)
3542 MODULE PROCEDURE timedelta_mult, timedelta_tlum
3543END INTERFACE
3544
3545!> Operatore di divisione di timedelta. Sono definite:
3546!! - \a timedelta / \a INTEGER = \a timedelta
3547!! - \a timedelta / \a timedelta = \a INTEGER
3548!! .
3549!! La prima combinazione � valida per tutti i tipi di intervallo, mentre la
3550!! seconda � definita solo per intervalli "puri".
3551INTERFACE OPERATOR (/)
3552 MODULE PROCEDURE timedelta_divint, timedelta_divtd
3553END INTERFACE
3554
3555!> Operatore di resto della divisione.
3556!! Sono definite le combinazioni:
3557!! - \a MOD(\a timedelta, \a timedelta) = \a timedelta
3558!! - \a MOD(\a datetime, \a timedelta) = \a timedelta.
3559!!
3560!! Sono definite solo per intervalli "puri"
3561!! La seconda combinazione ha senso principalmente con intervalli di
3562!! 1 minuto, 1 ora o
3563!! 1 giorno, per calcolare di quanto l'oggetto \a datetime indicato dista
3564!! dal minuto, ora o giorno tondo precedente pi� vicino.
3566 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3567END INTERFACE
3568
3569!> Operatore di valore assoluto di un intervallo.
3570!! - \a ABS(\a timedelta) = \a timedelta
3572 MODULE PROCEDURE timedelta_abs
3573END INTERFACE
3574
3575!> Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da
3576!! un file \c FORMATTED o \c UNFORMATTED.
3578 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3579 timedelta_read_unit, timedelta_vect_read_unit
3580END INTERFACE
3581
3582!> Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su
3583!! un file \c FORMATTED o \c UNFORMATTED.
3585 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3586 timedelta_write_unit, timedelta_vect_write_unit
3587END INTERFACE
3588
3589!> Print object
3591 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3592END INTERFACE
3593
3594!> Missing check
3596 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
3597END INTERFACE
3598
3599#undef VOL7D_POLY_TYPE
3600#undef VOL7D_POLY_TYPES
3601#undef ENABLE_SORT
3602#define VOL7D_POLY_TYPE TYPE(datetime)
3603#define VOL7D_POLY_TYPES _datetime
3604#define ENABLE_SORT
3605#include "array_utilities_pre.F90"
3606
3607
3608#define ARRAYOF_ORIGTYPE TYPE(datetime)
3609#define ARRAYOF_TYPE arrayof_datetime
3610#define ARRAYOF_ORIGEQ 1
3611#include "arrayof_pre.F90"
3612! from arrayof
3613
3614PRIVATE
3615
3617 datetime_min, datetime_max, &
3620 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3621 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3623 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3624 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3626 count_distinct, pack_distinct, &
3627 count_distinct_sorted, pack_distinct_sorted, &
3628 count_and_pack_distinct, &
3630 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
3632PUBLIC insert_unique, append_unique
3633PUBLIC cyclicdatetime_to_conventional
3634
3635CONTAINS
3636
3637
3638! ==============
3639! == datetime ==
3640! ==============
3641
3642!> Initialize a \a datetime object according to the provided arguments
3643!! If no arguments are passed a missing object is created. Notice
3644!! that the optional parameter groups (\a year, \a month, \a hour, \a
3645!! minute, \a msec), (\a unixtime), (\a isodate), (\a simpledate) are
3646!! mutually exclusive, the results are not guaranteed if arguments of
3647!! different groups are present.
3648ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3649 unixtime, isodate, simpledate) RESULT(this)
3650INTEGER,INTENT(IN),OPTIONAL :: year !< year a.C.; for reasons not yet investigated, only years >0 (a.C.) are allowed
3651INTEGER,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
3652INTEGER,INTENT(IN),OPTIONAL :: day !< day, default=1 if \a year is present, it can have non canonical values too
3653INTEGER,INTENT(IN),OPTIONAL :: hour !< hours, default=0 if \a year is present, it can have non canonical values too
3654INTEGER,INTENT(IN),OPTIONAL :: minute !< minutes, default=0 if \a year is present, it can have non canonical values too
3655INTEGER,INTENT(IN),OPTIONAL :: msec !< milliseconds, default=0 if \a year is present, it can have non canonical values too
3656INTEGER(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
3657CHARACTER(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
3658CHARACTER(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
3659
3660TYPE(datetime) :: this
3661INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3662CHARACTER(len=23) :: datebuf
3663
3664IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3665 lyear = year
3666 IF (PRESENT(month)) THEN
3667 lmonth = month
3668 ELSE
3669 lmonth = 1
3670 ENDIF
3671 IF (PRESENT(day)) THEN
3672 lday = day
3673 ELSE
3674 lday = 1
3675 ENDIF
3676 IF (PRESENT(hour)) THEN
3677 lhour = hour
3678 ELSE
3679 lhour = 0
3680 ENDIF
3681 IF (PRESENT(minute)) THEN
3682 lminute = minute
3683 ELSE
3684 lminute = 0
3685 ENDIF
3686 IF (PRESENT(msec)) THEN
3687 lmsec = msec
3688 ELSE
3689 lmsec = 0
3690 ENDIF
3691
3694 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3695 else
3696 this=datetime_miss
3697 end if
3698
3699ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3701 this%iminuti = (unixtime + unsec)*1000
3702 else
3703 this=datetime_miss
3704 end if
3705
3706ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3707
3709 datebuf(1:23) = '0001-01-01 00:00:00.000'
3710 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3711 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3712 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3713 lmsec = lmsec + lsec*1000
3714 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3715 RETURN
3716
3717100 CONTINUE ! condizione di errore in isodate
3719 RETURN
3720 ELSE
3721 this = datetime_miss
3722 ENDIF
3723
3724ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3726 datebuf(1:17) = '00010101000000000'
3727 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3728 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3729 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3730 lmsec = lmsec + lsec*1000
3731 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3732 RETURN
3733
3734120 CONTINUE ! condizione di errore in simpledate
3736 RETURN
3737 ELSE
3738 this = datetime_miss
3739 ENDIF
3740
3741ELSE
3742 this = datetime_miss
3743ENDIF
3744
3745END FUNCTION datetime_new
3746
3747
3748!> Initialize a datetime object with the current system time.
3749FUNCTION datetime_new_now(now) RESULT(this)
3750INTEGER,INTENT(IN) :: now !< select the time for initialisation, \a datetime_utc for UTC (preferred) or \a datetime_local for local time
3751TYPE(datetime) :: this
3752
3753INTEGER :: dt(8)
3754
3756 CALL date_and_time(values=dt)
3757 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3759 msec=dt(7)*1000+dt(8))
3760ELSE
3761 this = datetime_miss
3762ENDIF
3763
3764END FUNCTION datetime_new_now
3765
3766
3767!> Costruisce un oggetto \a datetime con i parametri opzionali forniti.
3768!! Se non viene passato nulla lo inizializza a 1/1/1.
3769!! Notare che i gruppi di parametri opzionali (\a year, \a month, \a hour,
3770!! \a minute, \a msec), (\a unixtime), (\a isodate), (\a simpledate),
3771!! (\a oraclesimdate) sono mutualmente escludentesi; \a oraclesimedate �
3772!! obsoleto, usare piuttosto \a simpledate.
3773SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3774 unixtime, isodate, simpledate, now)
3775TYPE(datetime),INTENT(INOUT) :: this !< oggetto da inizializzare
3776INTEGER,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.)
3777INTEGER,INTENT(IN),OPTIONAL :: month !< mese, default=1 se � specificato \a year; pu� assumere anche valori <1 o >12, l'oggetto finale si aggiusta coerentemente
3778INTEGER,INTENT(IN),OPTIONAL :: day !< mese, default=1 se � specificato \a year; pu� anch'esso assumere valori fuori dai limiti canonici
3779INTEGER,INTENT(IN),OPTIONAL :: hour !< ore, default=0 se � specificato \a year; pu� anch'esso assumere valori fuori dai limiti canonici
3780INTEGER,INTENT(IN),OPTIONAL :: minute !< minuti, default=0 se � specificato \a year; pu� anch'esso assumere valori fuori dai limiti canonici
3781INTEGER,INTENT(IN),OPTIONAL :: msec !< millisecondi, default=0 se � specificato \a year; pu� anch'esso assumere valori fuori dai limiti canonici
3782INTEGER(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)
3783CHARACTER(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
3784CHARACTER(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
3785INTEGER,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
3786
3787IF (PRESENT(now)) THEN
3788 this = datetime_new_now(now)
3789ELSE
3790 this = datetime_new(year, month, day, hour, minute, msec, &
3791 unixtime, isodate, simpledate)
3792ENDIF
3793
3794END SUBROUTINE datetime_init
3795
3796
3797ELEMENTAL SUBROUTINE datetime_delete(this)
3798TYPE(datetime),INTENT(INOUT) :: this
3799
3800this%iminuti = illmiss
3801
3802END SUBROUTINE datetime_delete
3803
3804
3805!> Restituisce il valore di un oggetto \a datetime in una o pi�
3806!! modalit� desiderate. Qualsiasi combinazione dei parametri
3807!! opzionali � consentita. \a oraclesimedate �
3808!! obsoleto, usare piuttosto \a simpledate.
3809PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3810 unixtime, isodate, simpledate, oraclesimdate)
3811TYPE(datetime),INTENT(IN) :: this !< oggetto di cui restituire il valore
3812INTEGER,INTENT(OUT),OPTIONAL :: year !< anno
3813INTEGER,INTENT(OUT),OPTIONAL :: month !< mese
3814INTEGER,INTENT(OUT),OPTIONAL :: day !< giorno
3815INTEGER,INTENT(OUT),OPTIONAL :: hour !< ore
3816INTEGER,INTENT(OUT),OPTIONAL :: minute !< minuti
3817INTEGER,INTENT(OUT),OPTIONAL :: msec !< millisecondi
3818INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime !< secondi a partire dal 1/1/1970
3819CHARACTER(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
3820CHARACTER(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
3821CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate !< data parziale nel formato \c AAAAMMGGhhmm
3822
3823INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3824CHARACTER(len=23) :: datebuf
3825
3826IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3827 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3828 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3829
3830 IF (this == datetime_miss) THEN
3831
3832 IF (PRESENT(msec)) THEN
3833 msec = imiss
3834 ENDIF
3835 IF (PRESENT(minute)) THEN
3836 minute = imiss
3837 ENDIF
3838 IF (PRESENT(hour)) THEN
3839 hour = imiss
3840 ENDIF
3841 IF (PRESENT(day)) THEN
3842 day = imiss
3843 ENDIF
3844 IF (PRESENT(month)) THEN
3845 month = imiss
3846 ENDIF
3847 IF (PRESENT(year)) THEN
3848 year = imiss
3849 ENDIF
3850 IF (PRESENT(isodate)) THEN
3851 isodate = cmiss
3852 ENDIF
3853 IF (PRESENT(simpledate)) THEN
3854 simpledate = cmiss
3855 ENDIF
3856 IF (PRESENT(oraclesimdate)) THEN
3857!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3858!!$ 'obsoleto, usare piuttosto simpledate')
3859 oraclesimdate=cmiss
3860 ENDIF
3861 IF (PRESENT(unixtime)) THEN
3862 unixtime = illmiss
3863 ENDIF
3864
3865 ELSE
3866
3867 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3868 IF (PRESENT(msec)) THEN
3869 msec = lmsec
3870 ENDIF
3871 IF (PRESENT(minute)) THEN
3872 minute = lminute
3873 ENDIF
3874 IF (PRESENT(hour)) THEN
3875 hour = lhour
3876 ENDIF
3877 IF (PRESENT(day)) THEN
3878 day = lday
3879 ENDIF
3880 IF (PRESENT(month)) THEN
3881 month = lmonth
3882 ENDIF
3883 IF (PRESENT(year)) THEN
3884 year = lyear
3885 ENDIF
3886 IF (PRESENT(isodate)) THEN
3887 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3888 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3890 isodate = datebuf(1:min(len(isodate),23))
3891 ENDIF
3892 IF (PRESENT(simpledate)) THEN
3893 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3894 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3895 simpledate = datebuf(1:min(len(simpledate),17))
3896 ENDIF
3897 IF (PRESENT(oraclesimdate)) THEN
3898!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3899!!$ 'obsoleto, usare piuttosto simpledate')
3900 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3901 ENDIF
3902 IF (PRESENT(unixtime)) THEN
3903 unixtime = this%iminuti/1000_int_ll-unsec
3904 ENDIF
3905
3906 ENDIF
3907ENDIF
3908
3909END SUBROUTINE datetime_getval
3910
3911
3912!> Restituisce una rappresentazione carattere stampabile di un oggetto
3913!! \a datetime.
3914elemental FUNCTION datetime_to_char(this) RESULT(char)
3915TYPE(datetime),INTENT(IN) :: this
3916
3917CHARACTER(len=23) :: char
3918
3920
3921END FUNCTION datetime_to_char
3922
3923
3924FUNCTION trim_datetime_to_char(in) RESULT(char)
3925TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3926
3927CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3928
3929char=datetime_to_char(in)
3930
3931END FUNCTION trim_datetime_to_char
3932
3933
3934
3935SUBROUTINE display_datetime(this)
3936TYPE(datetime),INTENT(in) :: this
3937
3939
3940end subroutine display_datetime
3941
3942
3943
3944SUBROUTINE display_timedelta(this)
3945TYPE(timedelta),INTENT(in) :: this
3946
3948
3949end subroutine display_timedelta
3950
3951
3952
3953ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3954TYPE(datetime),INTENT(in) :: this
3955LOGICAL :: res
3956
3957res = .not. this == datetime_miss
3958
3959end FUNCTION c_e_datetime
3960
3961
3962ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3963TYPE(datetime),INTENT(IN) :: this, that
3964LOGICAL :: res
3965
3966res = this%iminuti == that%iminuti
3967
3968END FUNCTION datetime_eq
3969
3970
3971ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3972TYPE(datetime),INTENT(IN) :: this, that
3973LOGICAL :: res
3974
3975res = .NOT.(this == that)
3976
3977END FUNCTION datetime_ne
3978
3979
3980ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3981TYPE(datetime),INTENT(IN) :: this, that
3982LOGICAL :: res
3983
3984res = this%iminuti > that%iminuti
3985
3986END FUNCTION datetime_gt
3987
3988
3989ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3990TYPE(datetime),INTENT(IN) :: this, that
3991LOGICAL :: res
3992
3993res = this%iminuti < that%iminuti
3994
3995END FUNCTION datetime_lt
3996
3997
3998ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3999TYPE(datetime),INTENT(IN) :: this, that
4000LOGICAL :: res
4001
4002IF (this == that) THEN
4003 res = .true.
4004ELSE IF (this > that) THEN
4005 res = .true.
4006ELSE
4007 res = .false.
4008ENDIF
4009
4010END FUNCTION datetime_ge
4011
4012
4013ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
4014TYPE(datetime),INTENT(IN) :: this, that
4015LOGICAL :: res
4016
4017IF (this == that) THEN
4018 res = .true.
4019ELSE IF (this < that) THEN
4020 res = .true.
4021ELSE
4022 res = .false.
4023ENDIF
4024
4025END FUNCTION datetime_le
4026
4027
4028FUNCTION datetime_add(this, that) RESULT(res)
4029TYPE(datetime),INTENT(IN) :: this
4030TYPE(timedelta),INTENT(IN) :: that
4031TYPE(datetime) :: res
4032
4033INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
4034
4035IF (this == datetime_miss .OR. that == timedelta_miss) THEN
4036 res = datetime_miss
4037ELSE
4038 res%iminuti = this%iminuti + that%iminuti
4039 IF (that%month /= 0) THEN
4041 minute=lminute, msec=lmsec)
4043 hour=lhour, minute=lminute, msec=lmsec)
4044 ENDIF
4045ENDIF
4046
4047END FUNCTION datetime_add
4048
4049
4050ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
4051TYPE(datetime),INTENT(IN) :: this, that
4052TYPE(timedelta) :: res
4053
4054IF (this == datetime_miss .OR. that == datetime_miss) THEN
4055 res = timedelta_miss
4056ELSE
4057 res%iminuti = this%iminuti - that%iminuti
4058 res%month = 0
4059ENDIF
4060
4061END FUNCTION datetime_subdt
4062
4063
4064FUNCTION datetime_subtd(this, that) RESULT(res)
4065TYPE(datetime),INTENT(IN) :: this
4066TYPE(timedelta),INTENT(IN) :: that
4067TYPE(datetime) :: res
4068
4069INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
4070
4071IF (this == datetime_miss .OR. that == timedelta_miss) THEN
4072 res = datetime_miss
4073ELSE
4074 res%iminuti = this%iminuti - that%iminuti
4075 IF (that%month /= 0) THEN
4077 minute=lminute, msec=lmsec)
4079 hour=lhour, minute=lminute, msec=lmsec)
4080 ENDIF
4081ENDIF
4082
4083END FUNCTION datetime_subtd
4084
4085
4086!> This method reads from a Fortran file unit the contents of the
4087!! object \a this. The record to be read must have been written with
4088!! the ::write_unit method. The method works both on formatted and
4089!! unformatted files.
4090SUBROUTINE datetime_read_unit(this, unit)
4091TYPE(datetime),INTENT(out) :: this !< object to be read
4092INTEGER, INTENT(in) :: unit !< unit from which to read, it must be an opened Fortran file unit
4093CALL datetime_vect_read_unit((/this/), unit)
4094
4095END SUBROUTINE datetime_read_unit
4096
4097
4098!> This method reads from a Fortran file unit the contents of the
4099!! object \a this. The record to be read must have been written with
4100!! the ::write_unit method. The method works both on formatted and
4101!! unformatted files.
4102SUBROUTINE datetime_vect_read_unit(this, unit)
4103TYPE(datetime) :: this(:) !< object to be read
4104INTEGER, INTENT(in) :: unit !< unit from which to read, it must be an opened Fortran file unit
4105
4106CHARACTER(len=40) :: form
4107CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4108INTEGER :: i
4109
4110ALLOCATE(dateiso(SIZE(this)))
4111INQUIRE(unit, form=form)
4112IF (form == 'FORMATTED') THEN
4113 READ(unit,'(A23,1X)')dateiso
4114ELSE
4115 READ(unit)dateiso
4116ENDIF
4117DO i = 1, SIZE(dateiso)
4119ENDDO
4120DEALLOCATE(dateiso)
4121
4122END SUBROUTINE datetime_vect_read_unit
4123
4124
4125!> This method writes on a Fortran file unit the contents of the
4126!! object \a this. The record can successively be read by the
4127!! ::read_unit method. The method works both on formatted and
4128!! unformatted files.
4129SUBROUTINE datetime_write_unit(this, unit)
4130TYPE(datetime),INTENT(in) :: this !< object to be written
4131INTEGER, INTENT(in) :: unit !< unit where to write, it must be an opened Fortran file unit
4132
4133CALL datetime_vect_write_unit((/this/), unit)
4134
4135END SUBROUTINE datetime_write_unit
4136
4137
4138!> This method writes on a Fortran file unit the contents of the
4139!! object \a this. The record can successively be read by the
4140!! ::read_unit method. The method works both on formatted and
4141!! unformatted files.
4142SUBROUTINE datetime_vect_write_unit(this, unit)
4143TYPE(datetime),INTENT(in) :: this(:) !< object to be written
4144INTEGER, INTENT(in) :: unit !< unit where to write, it must be an opened Fortran file unit
4145
4146CHARACTER(len=40) :: form
4147CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4148INTEGER :: i
4149
4150ALLOCATE(dateiso(SIZE(this)))
4151DO i = 1, SIZE(dateiso)
4153ENDDO
4154INQUIRE(unit, form=form)
4155IF (form == 'FORMATTED') THEN
4156 WRITE(unit,'(A23,1X)')dateiso
4157ELSE
4158 WRITE(unit)dateiso
4159ENDIF
4160DEALLOCATE(dateiso)
4161
4162END SUBROUTINE datetime_vect_write_unit
4163
4164
4165#include "arrayof_post.F90"
4166
4167
4168! ===============
4169! == timedelta ==
4170! ===============
4171!> Costruisce un oggetto \a timedelta con i parametri opzionali forniti.
4172!! Se non viene passato nulla lo inizializza a intervallo di durata nulla.
4173!! L'intervallo ottenuto � pari alla somma dei valori di tutti i parametri
4174!! forniti, ovviamente non fornire un parametro equivale a fornirlo =0.
4175!! Questa � la versione \c FUNCTION, in stile F2003, del costruttore, da preferire
4176!! rispetto alla versione \c SUBROUTINE \c init.
4177FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
4178 isodate, simpledate, oraclesimdate) RESULT (this)
4179INTEGER,INTENT(IN),OPTIONAL :: year !< anni, se presente l'oggetto diventa "popolare"
4180INTEGER,INTENT(IN),OPTIONAL :: month !< mesi, se presente l'oggetto diventa "popolare"
4181INTEGER,INTENT(IN),OPTIONAL :: day !< giorni
4182INTEGER,INTENT(IN),OPTIONAL :: hour !< ore
4183INTEGER,INTENT(IN),OPTIONAL :: minute !< minuti
4184INTEGER,INTENT(IN),OPTIONAL :: sec !< secondi
4185INTEGER,INTENT(IN),OPTIONAL :: msec !< millisecondi
4186CHARACTER(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
4187CHARACTER(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
4188CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate !< inizializza l'oggetto ad un intervallo nel formato \c GGGGGGGGhhmm, ignorando tutti gli altri parametri
4189
4190TYPE(timedelta) :: this !< oggetto da inizializzare
4191
4192CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
4193 isodate, simpledate, oraclesimdate)
4194
4195END FUNCTION timedelta_new
4196
4197
4198!> Costruisce un oggetto \a timedelta con i parametri opzionali forniti.
4199!! Se non viene passato nulla lo inizializza a intervallo di durata nulla.
4200!! L'intervallo ottenuto � pari alla somma dei valori di tutti i parametri
4201!! forniti, ovviamente non fornire un parametro equivale a fornirlo =0.
4202SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
4203 isodate, simpledate, oraclesimdate)
4204TYPE(timedelta),INTENT(INOUT) :: this !< oggetto da inizializzare
4205INTEGER,INTENT(IN),OPTIONAL :: year !< anni, se presente l'oggetto diventa "popolare"
4206INTEGER,INTENT(IN),OPTIONAL :: month !< mesi, se presente l'oggetto diventa "popolare"
4207INTEGER,INTENT(IN),OPTIONAL :: day !< giorni
4208INTEGER,INTENT(IN),OPTIONAL :: hour !< ore
4209INTEGER,INTENT(IN),OPTIONAL :: minute !< minuti
4210INTEGER,INTENT(IN),OPTIONAL :: sec !< secondi
4211INTEGER,INTENT(IN),OPTIONAL :: msec !< millisecondi
4212CHARACTER(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"
4213CHARACTER(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
4214CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate !< inizializza l'oggetto ad un intervallo nel formato \c GGGGGGGGhhmm, ignorando tutti gli altri parametri
4215
4216INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
4217CHARACTER(len=23) :: datebuf
4218
4219this%month = 0
4220
4221IF (PRESENT(isodate)) THEN
4222 datebuf(1:23) = '0000000000 00:00:00.000'
4223 l = len_trim(isodate)
4224! IF (l > 0) THEN
4226 IF (n > 0) THEN
4227 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
4228 datebuf(12-n:12-n+l-1) = isodate(:l)
4229 ELSE
4230 datebuf(1:l) = isodate(1:l)
4231 ENDIF
4232! ENDIF
4233
4234! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
4235 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
4236 h, m, s, ms
4237 this%month = lmonth + 12*lyear
4238 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4239 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4240 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4241 RETURN
4242
4243200 CONTINUE ! condizione di errore in isodate
4245 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
4246 CALL raise_error()
4247
4248ELSE IF (PRESENT(simpledate)) THEN
4249 datebuf(1:17) = '00000000000000000'
4250 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
4251 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
4252 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4253 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4254 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4255
4256220 CONTINUE ! condizione di errore in simpledate
4258 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
4259 CALL raise_error()
4260 RETURN
4261
4262ELSE IF (PRESENT(oraclesimdate)) THEN
4263 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
4264 'obsoleto, usare piuttosto simpledate')
4265 READ(oraclesimdate, '(I8,2I2)')d, h, m
4266 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4267 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
4268
4269ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
4270 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
4271 .and. .not. present(msec) .and. .not. present(isodate) &
4272 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
4273
4274 this=timedelta_miss
4275
4276ELSE
4277 this%iminuti = 0
4278 IF (PRESENT(year)) THEN
4280 this%month = this%month + year*12
4281 else
4282 this=timedelta_miss
4283 return
4284 end if
4285 ENDIF
4286 IF (PRESENT(month)) THEN
4288 this%month = this%month + month
4289 else
4290 this=timedelta_miss
4291 return
4292 end if
4293 ENDIF
4294 IF (PRESENT(day)) THEN
4296 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
4297 else
4298 this=timedelta_miss
4299 return
4300 end if
4301 ENDIF
4302 IF (PRESENT(hour)) THEN
4304 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
4305 else
4306 this=timedelta_miss
4307 return
4308 end if
4309 ENDIF
4310 IF (PRESENT(minute)) THEN
4312 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
4313 else
4314 this=timedelta_miss
4315 return
4316 end if
4317 ENDIF
4318 IF (PRESENT(sec)) THEN
4320 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
4321 else
4322 this=timedelta_miss
4323 return
4324 end if
4325 ENDIF
4326 IF (PRESENT(msec)) THEN
4328 this%iminuti = this%iminuti + msec
4329 else
4330 this=timedelta_miss
4331 return
4332 end if
4333 ENDIF
4334ENDIF
4335
4336
4337
4338
4339END SUBROUTINE timedelta_init
4340
4341
4342SUBROUTINE timedelta_delete(this)
4343TYPE(timedelta),INTENT(INOUT) :: this
4344
4345this%iminuti = imiss
4346this%month = 0
4347
4348END SUBROUTINE timedelta_delete
4349
4350
4351!> Restituisce il valore di un oggetto \a timedelta in una o pi�
4352!! modalit� desiderate. Qualsiasi combinazione dei parametri
4353!! opzionali � consentita. \a oraclesimedate �
4354!! obsoleto, usare piuttosto \a simpledate.
4355PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
4356 day, hour, minute, sec, msec, &
4357 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
4358TYPE(timedelta),INTENT(IN) :: this !< oggetto di cui restituire il valore
4359INTEGER,INTENT(OUT),OPTIONAL :: year !< anni, /=0 solo per intervalli "popolari"
4360INTEGER,INTENT(OUT),OPTIONAL :: month !< mesi modulo 12, /=0 solo per intervalli "popolari"
4361INTEGER,INTENT(OUT),OPTIONAL :: amonth !< mesi totali, /=0 solo per intervalli "popolari"
4362INTEGER,INTENT(OUT),OPTIONAL :: day !< giorni totali
4363INTEGER,INTENT(OUT),OPTIONAL :: hour !< ore modulo 24
4364INTEGER,INTENT(OUT),OPTIONAL :: minute !< minuti modulo 60
4365INTEGER,INTENT(OUT),OPTIONAL :: sec !< secondi modulo 60
4366INTEGER,INTENT(OUT),OPTIONAL :: msec !< millisecondi modulo 1000
4367INTEGER,INTENT(OUT),OPTIONAL :: ahour !< ore totali
4368INTEGER,INTENT(OUT),OPTIONAL :: aminute !< minuti totali
4369INTEGER,INTENT(OUT),OPTIONAL :: asec !< secondi totali
4370INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec !< millisecondi totali
4371CHARACTER(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
4372CHARACTER(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
4373CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate !< intervallo totale nel formato \c GGGGGGGGhhmm
4374
4375CHARACTER(len=23) :: datebuf
4376
4377IF (PRESENT(amsec)) THEN
4378 amsec = this%iminuti
4379ENDIF
4380IF (PRESENT(asec)) THEN
4381 asec = int(this%iminuti/1000_int_ll)
4382ENDIF
4383IF (PRESENT(aminute)) THEN
4384 aminute = int(this%iminuti/60000_int_ll)
4385ENDIF
4386IF (PRESENT(ahour)) THEN
4387 ahour = int(this%iminuti/3600000_int_ll)
4388ENDIF
4389IF (PRESENT(msec)) THEN
4390 msec = int(mod(this%iminuti, 1000_int_ll))
4391ENDIF
4392IF (PRESENT(sec)) THEN
4393 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
4394ENDIF
4395IF (PRESENT(minute)) THEN
4396 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
4397ENDIF
4398IF (PRESENT(hour)) THEN
4399 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
4400ENDIF
4401IF (PRESENT(day)) THEN
4402 day = int(this%iminuti/86400000_int_ll)
4403ENDIF
4404IF (PRESENT(amonth)) THEN
4405 amonth = this%month
4406ENDIF
4407IF (PRESENT(month)) THEN
4408 month = mod(this%month-1,12)+1
4409ENDIF
4410IF (PRESENT(year)) THEN
4411 year = this%month/12
4412ENDIF
4413IF (PRESENT(isodate)) THEN ! Non standard, inventato!
4414 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
4418 isodate = datebuf(1:min(len(isodate),23))
4419
4420ENDIF
4421IF (PRESENT(simpledate)) THEN
4422 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
4423 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
4425 mod(this%iminuti, 1000_int_ll)
4426 simpledate = datebuf(1:min(len(simpledate),17))
4427ENDIF
4428IF (PRESENT(oraclesimdate)) THEN
4429!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
4430!!$ 'obsoleto, usare piuttosto simpledate')
4431 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
4433ENDIF
4434
4435END SUBROUTINE timedelta_getval
4436
4437
4438!> Restituisce una rappresentazione carattere stampabile di un oggetto
4439!! \a timedelta.
4440elemental FUNCTION timedelta_to_char(this) RESULT(char)
4441TYPE(timedelta),INTENT(IN) :: this
4442
4443CHARACTER(len=23) :: char
4444
4446
4447END FUNCTION timedelta_to_char
4448
4449
4450FUNCTION trim_timedelta_to_char(in) RESULT(char)
4451TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
4452
4453CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
4454
4455char=timedelta_to_char(in)
4456
4457END FUNCTION trim_timedelta_to_char
4458
4459
4460!> Restituisce il valore in millisecondi totali di un oggetto \a timedelta.
4461elemental FUNCTION timedelta_getamsec(this)
4462TYPE(timedelta),INTENT(IN) :: this !< oggetto di cui restituire il valore
4463INTEGER(kind=int_ll) :: timedelta_getamsec !< millisecondi totali
4464
4465timedelta_getamsec = this%iminuti
4466
4467END FUNCTION timedelta_getamsec
4468
4469
4470!> Depopularize a \a timedelta object.
4471!! If the object represents a "popular" or mixed interval, a fixed
4472!! interval representation is returned, by recomputing it on a
4473!! standard period (starting from 1970-01-01); if it represents
4474!! already a fixed interval, the same object is returned.
4475FUNCTION timedelta_depop(this)
4476TYPE(timedelta),INTENT(IN) :: this !< object to be depopularized
4477TYPE(timedelta) :: timedelta_depop
4478
4479TYPE(datetime) :: tmpdt
4480
4481IF (this%month == 0) THEN
4482 timedelta_depop = this
4483ELSE
4484 tmpdt = datetime_new(1970, 1, 1)
4485 timedelta_depop = (tmpdt + this) - tmpdt
4486ENDIF
4487
4488END FUNCTION timedelta_depop
4489
4490
4491elemental FUNCTION timedelta_eq(this, that) RESULT(res)
4492TYPE(timedelta),INTENT(IN) :: this, that
4493LOGICAL :: res
4494
4495res = (this%iminuti == that%iminuti .AND. this%month == that%month)
4496
4497END FUNCTION timedelta_eq
4498
4499
4500ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
4501TYPE(timedelta),INTENT(IN) :: this, that
4502LOGICAL :: res
4503
4504res = .NOT.(this == that)
4505
4506END FUNCTION timedelta_ne
4507
4508
4509ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
4510TYPE(timedelta),INTENT(IN) :: this, that
4511LOGICAL :: res
4512
4513res = this%iminuti > that%iminuti
4514
4515END FUNCTION timedelta_gt
4516
4517
4518ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
4519TYPE(timedelta),INTENT(IN) :: this, that
4520LOGICAL :: res
4521
4522res = this%iminuti < that%iminuti
4523
4524END FUNCTION timedelta_lt
4525
4526
4527ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
4528TYPE(timedelta),INTENT(IN) :: this, that
4529LOGICAL :: res
4530
4531IF (this == that) THEN
4532 res = .true.
4533ELSE IF (this > that) THEN
4534 res = .true.
4535ELSE
4536 res = .false.
4537ENDIF
4538
4539END FUNCTION timedelta_ge
4540
4541
4542elemental FUNCTION timedelta_le(this, that) RESULT(res)
4543TYPE(timedelta),INTENT(IN) :: this, that
4544LOGICAL :: res
4545
4546IF (this == that) THEN
4547 res = .true.
4548ELSE IF (this < that) THEN
4549 res = .true.
4550ELSE
4551 res = .false.
4552ENDIF
4553
4554END FUNCTION timedelta_le
4555
4556
4557ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
4558TYPE(timedelta),INTENT(IN) :: this, that
4559TYPE(timedelta) :: res
4560
4561res%iminuti = this%iminuti + that%iminuti
4562res%month = this%month + that%month
4563
4564END FUNCTION timedelta_add
4565
4566
4567ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
4568TYPE(timedelta),INTENT(IN) :: this, that
4569TYPE(timedelta) :: res
4570
4571res%iminuti = this%iminuti - that%iminuti
4572res%month = this%month - that%month
4573
4574END FUNCTION timedelta_sub
4575
4576
4577ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
4578TYPE(timedelta),INTENT(IN) :: this
4579INTEGER,INTENT(IN) :: n
4580TYPE(timedelta) :: res
4581
4582res%iminuti = this%iminuti*n
4583res%month = this%month*n
4584
4585END FUNCTION timedelta_mult
4586
4587
4588ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
4589INTEGER,INTENT(IN) :: n
4590TYPE(timedelta),INTENT(IN) :: this
4591TYPE(timedelta) :: res
4592
4593res%iminuti = this%iminuti*n
4594res%month = this%month*n
4595
4596END FUNCTION timedelta_tlum
4597
4598
4599ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
4600TYPE(timedelta),INTENT(IN) :: this
4601INTEGER,INTENT(IN) :: n
4602TYPE(timedelta) :: res
4603
4604res%iminuti = this%iminuti/n
4605res%month = this%month/n
4606
4607END FUNCTION timedelta_divint
4608
4609
4610ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
4611TYPE(timedelta),INTENT(IN) :: this, that
4612INTEGER :: res
4613
4614res = int(this%iminuti/that%iminuti)
4615
4616END FUNCTION timedelta_divtd
4617
4618
4619elemental FUNCTION timedelta_mod(this, that) RESULT(res)
4620TYPE(timedelta),INTENT(IN) :: this, that
4621TYPE(timedelta) :: res
4622
4623res%iminuti = mod(this%iminuti, that%iminuti)
4624res%month = 0
4625
4626END FUNCTION timedelta_mod
4627
4628
4629ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
4630TYPE(datetime),INTENT(IN) :: this
4631TYPE(timedelta),INTENT(IN) :: that
4632TYPE(timedelta) :: res
4633
4634IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
4635 res = timedelta_0
4636ELSE
4637 res%iminuti = mod(this%iminuti, that%iminuti)
4638 res%month = 0
4639ENDIF
4640
4641END FUNCTION datetime_timedelta_mod
4642
4643
4644ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
4645TYPE(timedelta),INTENT(IN) :: this
4646TYPE(timedelta) :: res
4647
4648res%iminuti = abs(this%iminuti)
4649res%month = abs(this%month)
4650
4651END FUNCTION timedelta_abs
4652
4653
4654!> This method reads from a Fortran file unit the contents of the
4655!! object \a this. The record to be read must have been written with
4656!! the ::write_unit method. The method works both on formatted and
4657!! unformatted files.
4658SUBROUTINE timedelta_read_unit(this, unit)
4659TYPE(timedelta),INTENT(out) :: this !< object to be read
4660INTEGER, INTENT(in) :: unit !< unit from which to read, it must be an opened Fortran file unit
4661
4662CALL timedelta_vect_read_unit((/this/), unit)
4663
4664END SUBROUTINE timedelta_read_unit
4665
4666
4667!> This method reads from a Fortran file unit the contents of the
4668!! object \a this. The record to be read must have been written with
4669!! the ::write_unit method. The method works both on formatted and
4670!! unformatted files.
4671SUBROUTINE timedelta_vect_read_unit(this, unit)
4672TYPE(timedelta) :: this(:) !< object to be read
4673INTEGER, INTENT(in) :: unit !< unit from which to read, it must be an opened Fortran file unit
4674
4675CHARACTER(len=40) :: form
4676CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4677INTEGER :: i
4678
4679ALLOCATE(dateiso(SIZE(this)))
4680INQUIRE(unit, form=form)
4681IF (form == 'FORMATTED') THEN
4682 READ(unit,'(3(A23,1X))')dateiso
4683ELSE
4684 READ(unit)dateiso
4685ENDIF
4686DO i = 1, SIZE(dateiso)
4688ENDDO
4689DEALLOCATE(dateiso)
4690
4691END SUBROUTINE timedelta_vect_read_unit
4692
4693
4694!> This method writes on a Fortran file unit the contents of the
4695!! object \a this. The record can successively be read by the
4696!! ::read_unit method. The method works both on formatted and
4697!! unformatted files.
4698SUBROUTINE timedelta_write_unit(this, unit)
4699TYPE(timedelta),INTENT(in) :: this !< object to be written
4700INTEGER, INTENT(in) :: unit !< unit where to write, it must be an opened Fortran file unit
4701
4702CALL timedelta_vect_write_unit((/this/), unit)
4703
4704END SUBROUTINE timedelta_write_unit
4705
4706
4707!> This method writes on a Fortran file unit the contents of the
4708!! object \a this. The record can successively be read by the
4709!! ::read_unit method. The method works both on formatted and
4710!! unformatted files.
4711SUBROUTINE timedelta_vect_write_unit(this, unit)
4712TYPE(timedelta),INTENT(in) :: this(:) !< object to be written
4713INTEGER, INTENT(in) :: unit !< unit where to write, it must be an opened Fortran file unit
4714
4715CHARACTER(len=40) :: form
4716CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4717INTEGER :: i
4718
4719ALLOCATE(dateiso(SIZE(this)))
4720DO i = 1, SIZE(dateiso)
4722ENDDO
4723INQUIRE(unit, form=form)
4724IF (form == 'FORMATTED') THEN
4725 WRITE(unit,'(3(A23,1X))')dateiso
4726ELSE
4727 WRITE(unit)dateiso
4728ENDIF
4729DEALLOCATE(dateiso)
4730
4731END SUBROUTINE timedelta_vect_write_unit
4732
4733
4734ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4735TYPE(timedelta),INTENT(in) :: this
4736LOGICAL :: res
4737
4738res = .not. this == timedelta_miss
4739
4740end FUNCTION c_e_timedelta
4741
4742
4743elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4744
4745!!omstart JELADATA5
4746! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4747! 1 IMINUTI)
4748!
4749! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4750!
4751! variabili integer*4
4752! IN:
4753! IDAY,IMONTH,IYEAR, I*4
4754! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4755!
4756! OUT:
4757! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4758!!OMEND
4759
4760INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4761INTEGER,intent(out) :: iminuti
4762
4763iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4764
4765END SUBROUTINE jeladata5
4766
4767
4768elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4769INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4770INTEGER(KIND=int_ll),intent(out) :: imillisec
4771
4772imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4773 + imsec
4774
4775END SUBROUTINE jeladata5_1
4776
4777
4778
4779elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4780
4781!!omstart JELADATA6
4782! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4783! 1 IMINUTI)
4784!
4785! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4786! 1/1/1
4787!
4788! variabili integer*4
4789! IN:
4790! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4791!
4792! OUT:
4793! IDAY,IMONTH,IYEAR, I*4
4794! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4795!!OMEND
4796
4797
4798INTEGER,intent(in) :: iminuti
4799INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4800
4801INTEGER ::igiorno
4802
4803imin = mod(iminuti,60)
4804ihour = mod(iminuti,1440)/60
4805igiorno = iminuti/1440
4807CALL ndyin(igiorno,iday,imonth,iyear)
4808
4809END SUBROUTINE jeladata6
4810
4811
4812elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4813INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4814INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4815
4816INTEGER :: igiorno
4817
4819!imin = MOD(imillisec/60000_int_ll, 60)
4820!ihour = MOD(imillisec/3600000_int_ll, 24)
4821imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4822ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4823igiorno = int(imillisec/86400000_int_ll)
4824!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4825CALL ndyin(igiorno,iday,imonth,iyear)
4826
4827END SUBROUTINE jeladata6_1
4828
4829
4830elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4831
4832!!OMSTART NDYIN
4833! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4834! restituisce la data fornendo in input il numero di
4835! giorni dal 1/1/1
4836!
4837!!omend
4838
4839INTEGER,intent(in) :: ndays
4840INTEGER,intent(out) :: igg, imm, iaa
4841integer :: n,lndays
4842
4843lndays=ndays
4844
4845n = lndays/d400
4846lndays = lndays - n*d400
4847iaa = year0 + n*400
4848n = min(lndays/d100, 3)
4849lndays = lndays - n*d100
4850iaa = iaa + n*100
4851n = lndays/d4
4852lndays = lndays - n*d4
4853iaa = iaa + n*4
4854n = min(lndays/d1, 3)
4855lndays = lndays - n*d1
4856iaa = iaa + n
4857n = bisextilis(iaa)
4858DO imm = 1, 12
4859 IF (lndays < ianno(imm+1,n)) EXIT
4860ENDDO
4861igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4862
4863END SUBROUTINE ndyin
4864
4865
4866integer elemental FUNCTION ndays(igg,imm,iaa)
4867
4868!!OMSTART NDAYS
4869! FUNCTION NDAYS(IGG,IMM,IAA)
4870! restituisce il numero di giorni dal 1/1/1
4871! fornendo in input la data
4872!
4873!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4874! nota bene E' SICURO !!!
4875! un anno e' bisestile se divisibile per 4
4876! un anno rimane bisestile se divisibile per 400
4877! un anno NON e' bisestile se divisibile per 100
4878!
4879!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4880!
4881!!omend
4882
4883INTEGER, intent(in) :: igg, imm, iaa
4884
4885INTEGER :: lmonth, lyear
4886
4887! Limito il mese a [1-12] e correggo l'anno coerentemente
4888lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4889lyear = iaa + (imm - lmonth)/12
4890ndays = igg+ianno(lmonth, bisextilis(lyear))
4891ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4892 (lyear-year0)/400
4893
4894END FUNCTION ndays
4895
4896
4897elemental FUNCTION bisextilis(annum)
4898INTEGER,INTENT(in) :: annum
4899INTEGER :: bisextilis
4900
4902 bisextilis = 2
4903ELSE
4904 bisextilis = 1
4905ENDIF
4906END FUNCTION bisextilis
4907
4908
4909ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4910TYPE(cyclicdatetime),INTENT(IN) :: this, that
4911LOGICAL :: res
4912
4913res = .true.
4914if (this%minute /= that%minute) res=.false.
4915if (this%hour /= that%hour) res=.false.
4916if (this%day /= that%day) res=.false.
4917if (this%month /= that%month) res=.false.
4918if (this%tendaysp /= that%tendaysp) res=.false.
4919
4920END FUNCTION cyclicdatetime_eq
4921
4922
4923ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4924TYPE(cyclicdatetime),INTENT(IN) :: this
4925TYPE(datetime),INTENT(IN) :: that
4926LOGICAL :: res
4927
4928integer :: minute,hour,day,month
4929
4931
4932res = .true.
4938 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4939end if
4940
4941END FUNCTION cyclicdatetime_datetime_eq
4942
4943
4944ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4945TYPE(datetime),INTENT(IN) :: this
4946TYPE(cyclicdatetime),INTENT(IN) :: that
4947LOGICAL :: res
4948
4949integer :: minute,hour,day,month
4950
4952
4953res = .true.
4958
4960 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4961end if
4962
4963
4964END FUNCTION datetime_cyclicdatetime_eq
4965
4966ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4967TYPE(cyclicdatetime),INTENT(in) :: this
4968LOGICAL :: res
4969
4970res = .not. this == cyclicdatetime_miss
4971
4972end FUNCTION c_e_cyclicdatetime
4973
4974
4975!> Costruisce un oggetto \a cyclicdatetime con i parametri opzionali forniti.
4976!! Se non viene passato nulla lo inizializza a missing.
4977FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4978INTEGER,INTENT(IN),OPTIONAL :: tendaysp !< ten days period in month (1, 2, 3)
4979INTEGER,INTENT(IN),OPTIONAL :: month !< mese, default=missing
4980INTEGER,INTENT(IN),OPTIONAL :: day !< mese, default=missing
4981INTEGER,INTENT(IN),OPTIONAL :: hour !< ore, default=missing
4982INTEGER,INTENT(IN),OPTIONAL :: minute !< minuti, default=missing
4983CHARACTER(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.
4984
4985integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4986
4987
4988TYPE(cyclicdatetime) :: this !< oggetto da inizializzare
4989
4990if (present(chardate)) then
4991
4992 ltendaysp=imiss
4993 lmonth=imiss
4994 lday=imiss
4995 lhour=imiss
4996 lminute=imiss
4997
4999 ! TMMGGhhmm
5000 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
5001 !print*,chardate(1:1),ios,ltendaysp
5002 if (ios /= 0)ltendaysp=imiss
5003
5004 read(chardate(2:3),'(i2)',iostat=ios)lmonth
5005 !print*,chardate(2:3),ios,lmonth
5006 if (ios /= 0)lmonth=imiss
5007
5008 read(chardate(4:5),'(i2)',iostat=ios)lday
5009 !print*,chardate(4:5),ios,lday
5010 if (ios /= 0)lday=imiss
5011
5012 read(chardate(6:7),'(i2)',iostat=ios)lhour
5013 !print*,chardate(6:7),ios,lhour
5014 if (ios /= 0)lhour=imiss
5015
5016 read(chardate(8:9),'(i2)',iostat=ios)lminute
5017 !print*,chardate(8:9),ios,lminute
5018 if (ios /= 0)lminute=imiss
5019 end if
5020
5021 this%tendaysp=ltendaysp
5022 this%month=lmonth
5023 this%day=lday
5024 this%hour=lhour
5025 this%minute=lminute
5026else
5027 this%tendaysp=optio_l(tendaysp)
5028 this%month=optio_l(month)
5029 this%day=optio_l(day)
5030 this%hour=optio_l(hour)
5031 this%minute=optio_l(minute)
5032end if
5033
5034END FUNCTION cyclicdatetime_new
5035
5036!> Restituisce una rappresentazione carattere stampabile di un oggetto
5037!! \a cyclicdatetime.
5038elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
5039TYPE(cyclicdatetime),INTENT(IN) :: this
5040
5041CHARACTER(len=80) :: char
5042
5045
5046END FUNCTION cyclicdatetime_to_char
5047
5048
5049!> Restituisce una rappresentazione convenzionale in forma datetime
5050!! \a cyclicdatetime.
5051!! The following conventional code values are used to specify which data was taken into account in the computation:
5052!! year=1001 : dayly values of a specified month (depends by day and month)
5053!! year=1002 : dayly,hourly values of a specified month (depends by day and month and hour)
5054!! year=1003 : 10 day period of a specified month (depends by day(1,11,21) and month)
5055!! year=1004 : 10 day period of a specified month,hourly (depends by day(1,11,21) and month and hour)
5056!! year=1005 : mounthly values (depend by month)
5057!! year=1006 : mounthly,hourly values (depend by month and hour)
5058!! year=1007 : yearly values (no other time dependence)
5059!! year=1008 : yearly,hourly values (depend by year and hour)
5060!! 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.
5061FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
5062TYPE(cyclicdatetime),INTENT(IN) :: this !< cycliddatetime to use in compute
5063
5064TYPE(datetime) :: dtc
5065
5066integer :: year,month,day,hour
5067
5068dtc = datetime_miss
5069
5070! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
5072 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
5073 return
5074end if
5075
5076! minute present -> not good for conventional datetime
5078! day, month and tendaysp present -> no good
5080
5082 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
5084 day=(this%tendaysp-1)*10+1
5085 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
5087 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
5089 ! only day present -> no good
5090 return
5091end if
5092
5095 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
5096end if
5097
5098
5099END FUNCTION cyclicdatetime_to_conventional
5100
5101
5102
5103FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
5104TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
5105
5106CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
5107
5108char=cyclicdatetime_to_char(in)
5109
5110END FUNCTION trim_cyclicdatetime_to_char
5111
5112
5113
5114SUBROUTINE display_cyclicdatetime(this)
5115TYPE(cyclicdatetime),INTENT(in) :: this
5116
5118
5119end subroutine display_cyclicdatetime
5120
5121
5122#include "array_utilities_inc.F90"
5123
5125
Quick method to append an element to the array. Definition datetime_class.F90:616 Restituiscono il valore dell'oggetto nella forma desiderata. Definition datetime_class.F90:322 Costruttori per le classi datetime e timedelta. Definition datetime_class.F90:311 Method for inserting elements of the array at a desired position. Definition datetime_class.F90:607 Method for packing the array object reducing at a minimum the memory occupation, without destroying i... Definition datetime_class.F90:639 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition datetime_class.F90:478 Method for removing elements of the array at a desired position. Definition datetime_class.F90:622 Functions that return a trimmed CHARACTER representation of the input variable. Definition datetime_class.F90:349 Restituiscono il valore dell'oggetto in forma di stringa stampabile. Definition datetime_class.F90:327 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition datetime_class.F90:485 Definition of constants to be used for declaring variables of a desired type. Definition kinds.F90:245 Definitions of constants and functions for working with missing values. Definition missing_values.f90:50 Module for quickly interpreting the OPTIONAL parameters passed to a subprogram. Definition optional_values.f90:28 Class for expressing a cyclic datetime. Definition datetime_class.F90:255 Class for expressing an absolute time value. Definition datetime_class.F90:233 Class for expressing a relative time interval. Definition datetime_class.F90:245 |