libsim Versione 7.2.6

◆ sort_datetime()

subroutine sort_datetime ( type(datetime), dimension (:), intent(inout) xdont)
private

Sorts inline into ascending order - Quicksort Quicksort chooses a "pivot" in the set, and explores the array from both ends, looking for a value > pivot with the increasing index, for a value <= pivot with the decreasing index, and swapping them when it has found one of each.

The array is then subdivided in 2 ([3]) subsets: { values <= pivot} {pivot} {values > pivot} One then call recursively the program to sort each subset. When the size of the subarray is small enough or the maximum level of recursion is gained, one uses an insertion sort that is faster for very small sets.

Parametri
[in,out]xdontvector to sort inline

Definizione alla linea 3162 del file datetime_class.F90.

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