libsim Versione 7.2.6

◆ index_sorted_datetime()

recursive integer function index_sorted_datetime ( type(datetime), dimension(:), intent(in) vect,
type(datetime), intent(in) search )
private

Cerca l'indice del primo o ultimo elemento di vect uguale a search.

Definizione alla linea 3040 del file datetime_class.F90.

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