libsim Versione 7.2.0
|
◆ index_datetime()
Cerca l'indice del primo o ultimo elemento di vect uguale a search. Definizione alla linea 2963 del file datetime_class.F90. 2965! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2966! authors:
2967! Davide Cesari <dcesari@arpa.emr.it>
2968! Paolo Patruno <ppatruno@arpa.emr.it>
2969
2970! This program is free software; you can redistribute it and/or
2971! modify it under the terms of the GNU General Public License as
2972! published by the Free Software Foundation; either version 2 of
2973! the License, or (at your option) any later version.
2974
2975! This program is distributed in the hope that it will be useful,
2976! but WITHOUT ANY WARRANTY; without even the implied warranty of
2977! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2978! GNU General Public License for more details.
2979
2980! You should have received a copy of the GNU General Public License
2981! along with this program. If not, see <http://www.gnu.org/licenses/>.
2982#include "config.h"
2983
3004IMPLICIT NONE
3005
3006INTEGER, PARAMETER :: dateint=selected_int_kind(13)
3007
3010 PRIVATE
3011 INTEGER(KIND=int_ll) :: iminuti
3013
3022 PRIVATE
3023 INTEGER(KIND=int_ll) :: iminuti
3024 INTEGER :: month
3026
3027
3032 PRIVATE
3033 INTEGER :: minute
3034 INTEGER :: hour
3035 INTEGER :: day
3036 INTEGER :: tendaysp
3037 INTEGER :: month
3039
3040
3048INTEGER, PARAMETER :: datetime_utc=1
3050INTEGER, PARAMETER :: datetime_local=2
3060TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
3061
3062
3063INTEGER(kind=dateint), PARAMETER :: &
3064 sec_in_day=86400, &
3065 sec_in_hour=3600, &
3066 sec_in_min=60, &
3067 min_in_day=1440, &
3068 min_in_hour=60, &
3069 hour_in_day=24
3070
3071INTEGER,PARAMETER :: &
3072 year0=1, & ! anno di origine per iminuti
3073 d1=365, & ! giorni/1 anno nel calendario gregoriano
3074 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
3075 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
3076 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
3077 ianno(13,2)=reshape((/ &
3078 0,31,59,90,120,151,181,212,243,273,304,334,365, &
3079 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
3080
3081INTEGER(KIND=int_ll),PARAMETER :: &
3082 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
3083
3088 MODULE PROCEDURE datetime_init, timedelta_init
3089END INTERFACE
3090
3094 MODULE PROCEDURE datetime_delete, timedelta_delete
3095END INTERFACE
3096
3099 MODULE PROCEDURE datetime_getval, timedelta_getval
3100END INTERFACE
3101
3104 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
3105END INTERFACE
3106
3107
3126 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
3127END INTERFACE
3128
3134INTERFACE OPERATOR (==)
3135 MODULE PROCEDURE datetime_eq, timedelta_eq, &
3136 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
3137END INTERFACE
3138
3144INTERFACE OPERATOR (/=)
3145 MODULE PROCEDURE datetime_ne, timedelta_ne
3146END INTERFACE
3147
3155INTERFACE OPERATOR (>)
3156 MODULE PROCEDURE datetime_gt, timedelta_gt
3157END INTERFACE
3158
3166INTERFACE OPERATOR (<)
3167 MODULE PROCEDURE datetime_lt, timedelta_lt
3168END INTERFACE
3169
3177INTERFACE OPERATOR (>=)
3178 MODULE PROCEDURE datetime_ge, timedelta_ge
3179END INTERFACE
3180
3188INTERFACE OPERATOR (<=)
3189 MODULE PROCEDURE datetime_le, timedelta_le
3190END INTERFACE
3191
3198INTERFACE OPERATOR (+)
3199 MODULE PROCEDURE datetime_add, timedelta_add
3200END INTERFACE
3201
3209INTERFACE OPERATOR (-)
3210 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
3211END INTERFACE
3212
3218INTERFACE OPERATOR (*)
3219 MODULE PROCEDURE timedelta_mult, timedelta_tlum
3220END INTERFACE
3221
3228INTERFACE OPERATOR (/)
3229 MODULE PROCEDURE timedelta_divint, timedelta_divtd
3230END INTERFACE
3231
3243 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3244END INTERFACE
3245
3249 MODULE PROCEDURE timedelta_abs
3250END INTERFACE
3251
3255 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3256 timedelta_read_unit, timedelta_vect_read_unit
3257END INTERFACE
3258
3262 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3263 timedelta_write_unit, timedelta_vect_write_unit
3264END INTERFACE
3265
3268 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3269END INTERFACE
3270
3273 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
3274END INTERFACE
3275
3276#undef VOL7D_POLY_TYPE
3277#undef VOL7D_POLY_TYPES
3278#undef ENABLE_SORT
3279#define VOL7D_POLY_TYPE TYPE(datetime)
3280#define VOL7D_POLY_TYPES _datetime
3281#define ENABLE_SORT
3282#include "array_utilities_pre.F90"
3283
3284
3285#define ARRAYOF_ORIGTYPE TYPE(datetime)
3286#define ARRAYOF_TYPE arrayof_datetime
3287#define ARRAYOF_ORIGEQ 1
3288#include "arrayof_pre.F90"
3289! from arrayof
3290
3291PRIVATE
3292
3294 datetime_min, datetime_max, &
3297 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3298 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3300 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3301 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3303 count_distinct, pack_distinct, &
3304 count_distinct_sorted, pack_distinct_sorted, &
3305 count_and_pack_distinct, &
3307 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
3309PUBLIC insert_unique, append_unique
3310PUBLIC cyclicdatetime_to_conventional
3311
3312CONTAINS
3313
3314
3315! ==============
3316! == datetime ==
3317! ==============
3318
3325ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3326 unixtime, isodate, simpledate) RESULT(this)
3327INTEGER,INTENT(IN),OPTIONAL :: year
3328INTEGER,INTENT(IN),OPTIONAL :: month
3329INTEGER,INTENT(IN),OPTIONAL :: day
3330INTEGER,INTENT(IN),OPTIONAL :: hour
3331INTEGER,INTENT(IN),OPTIONAL :: minute
3332INTEGER,INTENT(IN),OPTIONAL :: msec
3333INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3334CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3335CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3336
3337TYPE(datetime) :: this
3338INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3339CHARACTER(len=23) :: datebuf
3340
3341IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3342 lyear = year
3343 IF (PRESENT(month)) THEN
3344 lmonth = month
3345 ELSE
3346 lmonth = 1
3347 ENDIF
3348 IF (PRESENT(day)) THEN
3349 lday = day
3350 ELSE
3351 lday = 1
3352 ENDIF
3353 IF (PRESENT(hour)) THEN
3354 lhour = hour
3355 ELSE
3356 lhour = 0
3357 ENDIF
3358 IF (PRESENT(minute)) THEN
3359 lminute = minute
3360 ELSE
3361 lminute = 0
3362 ENDIF
3363 IF (PRESENT(msec)) THEN
3364 lmsec = msec
3365 ELSE
3366 lmsec = 0
3367 ENDIF
3368
3371 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3372 else
3373 this=datetime_miss
3374 end if
3375
3376ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3378 this%iminuti = (unixtime + unsec)*1000
3379 else
3380 this=datetime_miss
3381 end if
3382
3383ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3384
3386 datebuf(1:23) = '0001-01-01 00:00:00.000'
3387 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3388 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3389 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3390 lmsec = lmsec + lsec*1000
3391 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3392 RETURN
3393
3394100 CONTINUE ! condizione di errore in isodate
3396 RETURN
3397 ELSE
3398 this = datetime_miss
3399 ENDIF
3400
3401ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3403 datebuf(1:17) = '00010101000000000'
3404 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3405 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3406 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3407 lmsec = lmsec + lsec*1000
3408 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3409 RETURN
3410
3411120 CONTINUE ! condizione di errore in simpledate
3413 RETURN
3414 ELSE
3415 this = datetime_miss
3416 ENDIF
3417
3418ELSE
3419 this = datetime_miss
3420ENDIF
3421
3422END FUNCTION datetime_new
3423
3424
3426FUNCTION datetime_new_now(now) RESULT(this)
3427INTEGER,INTENT(IN) :: now
3428TYPE(datetime) :: this
3429
3430INTEGER :: dt(8)
3431
3433 CALL date_and_time(values=dt)
3434 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3436 msec=dt(7)*1000+dt(8))
3437ELSE
3438 this = datetime_miss
3439ENDIF
3440
3441END FUNCTION datetime_new_now
3442
3443
3450SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3451 unixtime, isodate, simpledate, now)
3452TYPE(datetime),INTENT(INOUT) :: this
3453INTEGER,INTENT(IN),OPTIONAL :: year
3454INTEGER,INTENT(IN),OPTIONAL :: month
3455INTEGER,INTENT(IN),OPTIONAL :: day
3456INTEGER,INTENT(IN),OPTIONAL :: hour
3457INTEGER,INTENT(IN),OPTIONAL :: minute
3458INTEGER,INTENT(IN),OPTIONAL :: msec
3459INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3460CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3461CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3462INTEGER,INTENT(IN),OPTIONAL :: now
3463
3464IF (PRESENT(now)) THEN
3465 this = datetime_new_now(now)
3466ELSE
3467 this = datetime_new(year, month, day, hour, minute, msec, &
3468 unixtime, isodate, simpledate)
3469ENDIF
3470
3471END SUBROUTINE datetime_init
3472
3473
3474ELEMENTAL SUBROUTINE datetime_delete(this)
3475TYPE(datetime),INTENT(INOUT) :: this
3476
3477this%iminuti = illmiss
3478
3479END SUBROUTINE datetime_delete
3480
3481
3486PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3487 unixtime, isodate, simpledate, oraclesimdate)
3488TYPE(datetime),INTENT(IN) :: this
3489INTEGER,INTENT(OUT),OPTIONAL :: year
3490INTEGER,INTENT(OUT),OPTIONAL :: month
3491INTEGER,INTENT(OUT),OPTIONAL :: day
3492INTEGER,INTENT(OUT),OPTIONAL :: hour
3493INTEGER,INTENT(OUT),OPTIONAL :: minute
3494INTEGER,INTENT(OUT),OPTIONAL :: msec
3495INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3496CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3497CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3498CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3499
3500INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3501CHARACTER(len=23) :: datebuf
3502
3503IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3504 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3505 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3506
3507 IF (this == datetime_miss) THEN
3508
3509 IF (PRESENT(msec)) THEN
3510 msec = imiss
3511 ENDIF
3512 IF (PRESENT(minute)) THEN
3513 minute = imiss
3514 ENDIF
3515 IF (PRESENT(hour)) THEN
3516 hour = imiss
3517 ENDIF
3518 IF (PRESENT(day)) THEN
3519 day = imiss
3520 ENDIF
3521 IF (PRESENT(month)) THEN
3522 month = imiss
3523 ENDIF
3524 IF (PRESENT(year)) THEN
3525 year = imiss
3526 ENDIF
3527 IF (PRESENT(isodate)) THEN
3528 isodate = cmiss
3529 ENDIF
3530 IF (PRESENT(simpledate)) THEN
3531 simpledate = cmiss
3532 ENDIF
3533 IF (PRESENT(oraclesimdate)) THEN
3534!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3535!!$ 'obsoleto, usare piuttosto simpledate')
3536 oraclesimdate=cmiss
3537 ENDIF
3538 IF (PRESENT(unixtime)) THEN
3539 unixtime = illmiss
3540 ENDIF
3541
3542 ELSE
3543
3544 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3545 IF (PRESENT(msec)) THEN
3546 msec = lmsec
3547 ENDIF
3548 IF (PRESENT(minute)) THEN
3549 minute = lminute
3550 ENDIF
3551 IF (PRESENT(hour)) THEN
3552 hour = lhour
3553 ENDIF
3554 IF (PRESENT(day)) THEN
3555 day = lday
3556 ENDIF
3557 IF (PRESENT(month)) THEN
3558 month = lmonth
3559 ENDIF
3560 IF (PRESENT(year)) THEN
3561 year = lyear
3562 ENDIF
3563 IF (PRESENT(isodate)) THEN
3564 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3565 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3567 isodate = datebuf(1:min(len(isodate),23))
3568 ENDIF
3569 IF (PRESENT(simpledate)) THEN
3570 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3571 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3572 simpledate = datebuf(1:min(len(simpledate),17))
3573 ENDIF
3574 IF (PRESENT(oraclesimdate)) THEN
3575!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3576!!$ 'obsoleto, usare piuttosto simpledate')
3577 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3578 ENDIF
3579 IF (PRESENT(unixtime)) THEN
3580 unixtime = this%iminuti/1000_int_ll-unsec
3581 ENDIF
3582
3583 ENDIF
3584ENDIF
3585
3586END SUBROUTINE datetime_getval
3587
3588
3591elemental FUNCTION datetime_to_char(this) RESULT(char)
3592TYPE(datetime),INTENT(IN) :: this
3593
3594CHARACTER(len=23) :: char
3595
3597
3598END FUNCTION datetime_to_char
3599
3600
3601FUNCTION trim_datetime_to_char(in) RESULT(char)
3602TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3603
3604CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3605
3606char=datetime_to_char(in)
3607
3608END FUNCTION trim_datetime_to_char
3609
3610
3611
3612SUBROUTINE display_datetime(this)
3613TYPE(datetime),INTENT(in) :: this
3614
3616
3617end subroutine display_datetime
3618
3619
3620
3621SUBROUTINE display_timedelta(this)
3622TYPE(timedelta),INTENT(in) :: this
3623
3625
3626end subroutine display_timedelta
3627
3628
3629
3630ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3631TYPE(datetime),INTENT(in) :: this
3632LOGICAL :: res
3633
3634res = .not. this == datetime_miss
3635
3636end FUNCTION c_e_datetime
3637
3638
3639ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3640TYPE(datetime),INTENT(IN) :: this, that
3641LOGICAL :: res
3642
3643res = this%iminuti == that%iminuti
3644
3645END FUNCTION datetime_eq
3646
3647
3648ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3649TYPE(datetime),INTENT(IN) :: this, that
3650LOGICAL :: res
3651
3652res = .NOT.(this == that)
3653
3654END FUNCTION datetime_ne
3655
3656
3657ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3658TYPE(datetime),INTENT(IN) :: this, that
3659LOGICAL :: res
3660
3661res = this%iminuti > that%iminuti
3662
3663END FUNCTION datetime_gt
3664
3665
3666ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3667TYPE(datetime),INTENT(IN) :: this, that
3668LOGICAL :: res
3669
3670res = this%iminuti < that%iminuti
3671
3672END FUNCTION datetime_lt
3673
3674
3675ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3676TYPE(datetime),INTENT(IN) :: this, that
3677LOGICAL :: res
3678
3679IF (this == that) THEN
3680 res = .true.
3681ELSE IF (this > that) THEN
3682 res = .true.
3683ELSE
3684 res = .false.
3685ENDIF
3686
3687END FUNCTION datetime_ge
3688
3689
3690ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3691TYPE(datetime),INTENT(IN) :: this, that
3692LOGICAL :: res
3693
3694IF (this == that) THEN
3695 res = .true.
3696ELSE IF (this < that) THEN
3697 res = .true.
3698ELSE
3699 res = .false.
3700ENDIF
3701
3702END FUNCTION datetime_le
3703
3704
3705FUNCTION datetime_add(this, that) RESULT(res)
3706TYPE(datetime),INTENT(IN) :: this
3707TYPE(timedelta),INTENT(IN) :: that
3708TYPE(datetime) :: res
3709
3710INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3711
3712IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3713 res = datetime_miss
3714ELSE
3715 res%iminuti = this%iminuti + that%iminuti
3716 IF (that%month /= 0) THEN
3718 minute=lminute, msec=lmsec)
3720 hour=lhour, minute=lminute, msec=lmsec)
3721 ENDIF
3722ENDIF
3723
3724END FUNCTION datetime_add
3725
3726
3727ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3728TYPE(datetime),INTENT(IN) :: this, that
3729TYPE(timedelta) :: res
3730
3731IF (this == datetime_miss .OR. that == datetime_miss) THEN
3732 res = timedelta_miss
3733ELSE
3734 res%iminuti = this%iminuti - that%iminuti
3735 res%month = 0
3736ENDIF
3737
3738END FUNCTION datetime_subdt
3739
3740
3741FUNCTION datetime_subtd(this, that) RESULT(res)
3742TYPE(datetime),INTENT(IN) :: this
3743TYPE(timedelta),INTENT(IN) :: that
3744TYPE(datetime) :: res
3745
3746INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3747
3748IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3749 res = datetime_miss
3750ELSE
3751 res%iminuti = this%iminuti - that%iminuti
3752 IF (that%month /= 0) THEN
3754 minute=lminute, msec=lmsec)
3756 hour=lhour, minute=lminute, msec=lmsec)
3757 ENDIF
3758ENDIF
3759
3760END FUNCTION datetime_subtd
3761
3762
3767SUBROUTINE datetime_read_unit(this, unit)
3768TYPE(datetime),INTENT(out) :: this
3769INTEGER, INTENT(in) :: unit
3770CALL datetime_vect_read_unit((/this/), unit)
3771
3772END SUBROUTINE datetime_read_unit
3773
3774
3779SUBROUTINE datetime_vect_read_unit(this, unit)
3780TYPE(datetime) :: this(:)
3781INTEGER, INTENT(in) :: unit
3782
3783CHARACTER(len=40) :: form
3784CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3785INTEGER :: i
3786
3787ALLOCATE(dateiso(SIZE(this)))
3788INQUIRE(unit, form=form)
3789IF (form == 'FORMATTED') THEN
3790 READ(unit,'(A23,1X)')dateiso
3791ELSE
3792 READ(unit)dateiso
3793ENDIF
3794DO i = 1, SIZE(dateiso)
3796ENDDO
3797DEALLOCATE(dateiso)
3798
3799END SUBROUTINE datetime_vect_read_unit
3800
3801
3806SUBROUTINE datetime_write_unit(this, unit)
3807TYPE(datetime),INTENT(in) :: this
3808INTEGER, INTENT(in) :: unit
3809
3810CALL datetime_vect_write_unit((/this/), unit)
3811
3812END SUBROUTINE datetime_write_unit
3813
3814
3819SUBROUTINE datetime_vect_write_unit(this, unit)
3820TYPE(datetime),INTENT(in) :: this(:)
3821INTEGER, INTENT(in) :: unit
3822
3823CHARACTER(len=40) :: form
3824CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3825INTEGER :: i
3826
3827ALLOCATE(dateiso(SIZE(this)))
3828DO i = 1, SIZE(dateiso)
3830ENDDO
3831INQUIRE(unit, form=form)
3832IF (form == 'FORMATTED') THEN
3833 WRITE(unit,'(A23,1X)')dateiso
3834ELSE
3835 WRITE(unit)dateiso
3836ENDIF
3837DEALLOCATE(dateiso)
3838
3839END SUBROUTINE datetime_vect_write_unit
3840
3841
3842#include "arrayof_post.F90"
3843
3844
3845! ===============
3846! == timedelta ==
3847! ===============
3854FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3855 isodate, simpledate, oraclesimdate) RESULT (this)
3856INTEGER,INTENT(IN),OPTIONAL :: year
3857INTEGER,INTENT(IN),OPTIONAL :: month
3858INTEGER,INTENT(IN),OPTIONAL :: day
3859INTEGER,INTENT(IN),OPTIONAL :: hour
3860INTEGER,INTENT(IN),OPTIONAL :: minute
3861INTEGER,INTENT(IN),OPTIONAL :: sec
3862INTEGER,INTENT(IN),OPTIONAL :: msec
3863CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3864CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3865CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3866
3867TYPE(timedelta) :: this
3868
3869CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3870 isodate, simpledate, oraclesimdate)
3871
3872END FUNCTION timedelta_new
3873
3874
3879SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3880 isodate, simpledate, oraclesimdate)
3881TYPE(timedelta),INTENT(INOUT) :: this
3882INTEGER,INTENT(IN),OPTIONAL :: year
3883INTEGER,INTENT(IN),OPTIONAL :: month
3884INTEGER,INTENT(IN),OPTIONAL :: day
3885INTEGER,INTENT(IN),OPTIONAL :: hour
3886INTEGER,INTENT(IN),OPTIONAL :: minute
3887INTEGER,INTENT(IN),OPTIONAL :: sec
3888INTEGER,INTENT(IN),OPTIONAL :: msec
3889CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3890CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3891CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3892
3893INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3894CHARACTER(len=23) :: datebuf
3895
3896this%month = 0
3897
3898IF (PRESENT(isodate)) THEN
3899 datebuf(1:23) = '0000000000 00:00:00.000'
3900 l = len_trim(isodate)
3901! IF (l > 0) THEN
3903 IF (n > 0) THEN
3904 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3905 datebuf(12-n:12-n+l-1) = isodate(:l)
3906 ELSE
3907 datebuf(1:l) = isodate(1:l)
3908 ENDIF
3909! ENDIF
3910
3911! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3912 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3913 h, m, s, ms
3914 this%month = lmonth + 12*lyear
3915 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3916 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3917 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3918 RETURN
3919
3920200 CONTINUE ! condizione di errore in isodate
3922 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3923 CALL raise_error()
3924
3925ELSE IF (PRESENT(simpledate)) THEN
3926 datebuf(1:17) = '00000000000000000'
3927 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3928 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3929 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3930 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3931 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3932
3933220 CONTINUE ! condizione di errore in simpledate
3935 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3936 CALL raise_error()
3937 RETURN
3938
3939ELSE IF (PRESENT(oraclesimdate)) THEN
3940 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3941 'obsoleto, usare piuttosto simpledate')
3942 READ(oraclesimdate, '(I8,2I2)')d, h, m
3943 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3944 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3945
3946ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3947 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3948 .and. .not. present(msec) .and. .not. present(isodate) &
3949 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3950
3951 this=timedelta_miss
3952
3953ELSE
3954 this%iminuti = 0
3955 IF (PRESENT(year)) THEN
3957 this%month = this%month + year*12
3958 else
3959 this=timedelta_miss
3960 return
3961 end if
3962 ENDIF
3963 IF (PRESENT(month)) THEN
3965 this%month = this%month + month
3966 else
3967 this=timedelta_miss
3968 return
3969 end if
3970 ENDIF
3971 IF (PRESENT(day)) THEN
3973 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3974 else
3975 this=timedelta_miss
3976 return
3977 end if
3978 ENDIF
3979 IF (PRESENT(hour)) THEN
3981 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3982 else
3983 this=timedelta_miss
3984 return
3985 end if
3986 ENDIF
3987 IF (PRESENT(minute)) THEN
3989 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3990 else
3991 this=timedelta_miss
3992 return
3993 end if
3994 ENDIF
3995 IF (PRESENT(sec)) THEN
3997 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
3998 else
3999 this=timedelta_miss
4000 return
4001 end if
4002 ENDIF
4003 IF (PRESENT(msec)) THEN
4005 this%iminuti = this%iminuti + msec
4006 else
4007 this=timedelta_miss
4008 return
4009 end if
4010 ENDIF
4011ENDIF
4012
4013
4014
4015
4016END SUBROUTINE timedelta_init
4017
4018
4019SUBROUTINE timedelta_delete(this)
4020TYPE(timedelta),INTENT(INOUT) :: this
4021
4022this%iminuti = imiss
4023this%month = 0
4024
4025END SUBROUTINE timedelta_delete
4026
4027
4032PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
4033 day, hour, minute, sec, msec, &
4034 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
4035TYPE(timedelta),INTENT(IN) :: this
4036INTEGER,INTENT(OUT),OPTIONAL :: year
4037INTEGER,INTENT(OUT),OPTIONAL :: month
4038INTEGER,INTENT(OUT),OPTIONAL :: amonth
4039INTEGER,INTENT(OUT),OPTIONAL :: day
4040INTEGER,INTENT(OUT),OPTIONAL :: hour
4041INTEGER,INTENT(OUT),OPTIONAL :: minute
4042INTEGER,INTENT(OUT),OPTIONAL :: sec
4043INTEGER,INTENT(OUT),OPTIONAL :: msec
4044INTEGER,INTENT(OUT),OPTIONAL :: ahour
4045INTEGER,INTENT(OUT),OPTIONAL :: aminute
4046INTEGER,INTENT(OUT),OPTIONAL :: asec
4047INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
4048CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
4049CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
4050CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
4051
4052CHARACTER(len=23) :: datebuf
4053
4054IF (PRESENT(amsec)) THEN
4055 amsec = this%iminuti
4056ENDIF
4057IF (PRESENT(asec)) THEN
4058 asec = int(this%iminuti/1000_int_ll)
4059ENDIF
4060IF (PRESENT(aminute)) THEN
4061 aminute = int(this%iminuti/60000_int_ll)
4062ENDIF
4063IF (PRESENT(ahour)) THEN
4064 ahour = int(this%iminuti/3600000_int_ll)
4065ENDIF
4066IF (PRESENT(msec)) THEN
4067 msec = int(mod(this%iminuti, 1000_int_ll))
4068ENDIF
4069IF (PRESENT(sec)) THEN
4070 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
4071ENDIF
4072IF (PRESENT(minute)) THEN
4073 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
4074ENDIF
4075IF (PRESENT(hour)) THEN
4076 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
4077ENDIF
4078IF (PRESENT(day)) THEN
4079 day = int(this%iminuti/86400000_int_ll)
4080ENDIF
4081IF (PRESENT(amonth)) THEN
4082 amonth = this%month
4083ENDIF
4084IF (PRESENT(month)) THEN
4085 month = mod(this%month-1,12)+1
4086ENDIF
4087IF (PRESENT(year)) THEN
4088 year = this%month/12
4089ENDIF
4090IF (PRESENT(isodate)) THEN ! Non standard, inventato!
4091 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
4095 isodate = datebuf(1:min(len(isodate),23))
4096
4097ENDIF
4098IF (PRESENT(simpledate)) THEN
4099 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
4100 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
4102 mod(this%iminuti, 1000_int_ll)
4103 simpledate = datebuf(1:min(len(simpledate),17))
4104ENDIF
4105IF (PRESENT(oraclesimdate)) THEN
4106!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
4107!!$ 'obsoleto, usare piuttosto simpledate')
4108 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
4110ENDIF
4111
4112END SUBROUTINE timedelta_getval
4113
4114
4117elemental FUNCTION timedelta_to_char(this) RESULT(char)
4118TYPE(timedelta),INTENT(IN) :: this
4119
4120CHARACTER(len=23) :: char
4121
4123
4124END FUNCTION timedelta_to_char
4125
4126
4127FUNCTION trim_timedelta_to_char(in) RESULT(char)
4128TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
4129
4130CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
4131
4132char=timedelta_to_char(in)
4133
4134END FUNCTION trim_timedelta_to_char
4135
4136
4138elemental FUNCTION timedelta_getamsec(this)
4139TYPE(timedelta),INTENT(IN) :: this
4140INTEGER(kind=int_ll) :: timedelta_getamsec
4141
4142timedelta_getamsec = this%iminuti
4143
4144END FUNCTION timedelta_getamsec
4145
4146
4152FUNCTION timedelta_depop(this)
4153TYPE(timedelta),INTENT(IN) :: this
4154TYPE(timedelta) :: timedelta_depop
4155
4156TYPE(datetime) :: tmpdt
4157
4158IF (this%month == 0) THEN
4159 timedelta_depop = this
4160ELSE
4161 tmpdt = datetime_new(1970, 1, 1)
4162 timedelta_depop = (tmpdt + this) - tmpdt
4163ENDIF
4164
4165END FUNCTION timedelta_depop
4166
4167
4168elemental FUNCTION timedelta_eq(this, that) RESULT(res)
4169TYPE(timedelta),INTENT(IN) :: this, that
4170LOGICAL :: res
4171
4172res = (this%iminuti == that%iminuti .AND. this%month == that%month)
4173
4174END FUNCTION timedelta_eq
4175
4176
4177ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
4178TYPE(timedelta),INTENT(IN) :: this, that
4179LOGICAL :: res
4180
4181res = .NOT.(this == that)
4182
4183END FUNCTION timedelta_ne
4184
4185
4186ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
4187TYPE(timedelta),INTENT(IN) :: this, that
4188LOGICAL :: res
4189
4190res = this%iminuti > that%iminuti
4191
4192END FUNCTION timedelta_gt
4193
4194
4195ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
4196TYPE(timedelta),INTENT(IN) :: this, that
4197LOGICAL :: res
4198
4199res = this%iminuti < that%iminuti
4200
4201END FUNCTION timedelta_lt
4202
4203
4204ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
4205TYPE(timedelta),INTENT(IN) :: this, that
4206LOGICAL :: res
4207
4208IF (this == that) THEN
4209 res = .true.
4210ELSE IF (this > that) THEN
4211 res = .true.
4212ELSE
4213 res = .false.
4214ENDIF
4215
4216END FUNCTION timedelta_ge
4217
4218
4219elemental FUNCTION timedelta_le(this, that) RESULT(res)
4220TYPE(timedelta),INTENT(IN) :: this, that
4221LOGICAL :: res
4222
4223IF (this == that) THEN
4224 res = .true.
4225ELSE IF (this < that) THEN
4226 res = .true.
4227ELSE
4228 res = .false.
4229ENDIF
4230
4231END FUNCTION timedelta_le
4232
4233
4234ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
4235TYPE(timedelta),INTENT(IN) :: this, that
4236TYPE(timedelta) :: res
4237
4238res%iminuti = this%iminuti + that%iminuti
4239res%month = this%month + that%month
4240
4241END FUNCTION timedelta_add
4242
4243
4244ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
4245TYPE(timedelta),INTENT(IN) :: this, that
4246TYPE(timedelta) :: res
4247
4248res%iminuti = this%iminuti - that%iminuti
4249res%month = this%month - that%month
4250
4251END FUNCTION timedelta_sub
4252
4253
4254ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
4255TYPE(timedelta),INTENT(IN) :: this
4256INTEGER,INTENT(IN) :: n
4257TYPE(timedelta) :: res
4258
4259res%iminuti = this%iminuti*n
4260res%month = this%month*n
4261
4262END FUNCTION timedelta_mult
4263
4264
4265ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
4266INTEGER,INTENT(IN) :: n
4267TYPE(timedelta),INTENT(IN) :: this
4268TYPE(timedelta) :: res
4269
4270res%iminuti = this%iminuti*n
4271res%month = this%month*n
4272
4273END FUNCTION timedelta_tlum
4274
4275
4276ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
4277TYPE(timedelta),INTENT(IN) :: this
4278INTEGER,INTENT(IN) :: n
4279TYPE(timedelta) :: res
4280
4281res%iminuti = this%iminuti/n
4282res%month = this%month/n
4283
4284END FUNCTION timedelta_divint
4285
4286
4287ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
4288TYPE(timedelta),INTENT(IN) :: this, that
4289INTEGER :: res
4290
4291res = int(this%iminuti/that%iminuti)
4292
4293END FUNCTION timedelta_divtd
4294
4295
4296elemental FUNCTION timedelta_mod(this, that) RESULT(res)
4297TYPE(timedelta),INTENT(IN) :: this, that
4298TYPE(timedelta) :: res
4299
4300res%iminuti = mod(this%iminuti, that%iminuti)
4301res%month = 0
4302
4303END FUNCTION timedelta_mod
4304
4305
4306ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
4307TYPE(datetime),INTENT(IN) :: this
4308TYPE(timedelta),INTENT(IN) :: that
4309TYPE(timedelta) :: res
4310
4311IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
4312 res = timedelta_0
4313ELSE
4314 res%iminuti = mod(this%iminuti, that%iminuti)
4315 res%month = 0
4316ENDIF
4317
4318END FUNCTION datetime_timedelta_mod
4319
4320
4321ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
4322TYPE(timedelta),INTENT(IN) :: this
4323TYPE(timedelta) :: res
4324
4325res%iminuti = abs(this%iminuti)
4326res%month = abs(this%month)
4327
4328END FUNCTION timedelta_abs
4329
4330
4335SUBROUTINE timedelta_read_unit(this, unit)
4336TYPE(timedelta),INTENT(out) :: this
4337INTEGER, INTENT(in) :: unit
4338
4339CALL timedelta_vect_read_unit((/this/), unit)
4340
4341END SUBROUTINE timedelta_read_unit
4342
4343
4348SUBROUTINE timedelta_vect_read_unit(this, unit)
4349TYPE(timedelta) :: this(:)
4350INTEGER, INTENT(in) :: unit
4351
4352CHARACTER(len=40) :: form
4353CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4354INTEGER :: i
4355
4356ALLOCATE(dateiso(SIZE(this)))
4357INQUIRE(unit, form=form)
4358IF (form == 'FORMATTED') THEN
4359 READ(unit,'(3(A23,1X))')dateiso
4360ELSE
4361 READ(unit)dateiso
4362ENDIF
4363DO i = 1, SIZE(dateiso)
4365ENDDO
4366DEALLOCATE(dateiso)
4367
4368END SUBROUTINE timedelta_vect_read_unit
4369
4370
4375SUBROUTINE timedelta_write_unit(this, unit)
4376TYPE(timedelta),INTENT(in) :: this
4377INTEGER, INTENT(in) :: unit
4378
4379CALL timedelta_vect_write_unit((/this/), unit)
4380
4381END SUBROUTINE timedelta_write_unit
4382
4383
4388SUBROUTINE timedelta_vect_write_unit(this, unit)
4389TYPE(timedelta),INTENT(in) :: this(:)
4390INTEGER, INTENT(in) :: unit
4391
4392CHARACTER(len=40) :: form
4393CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4394INTEGER :: i
4395
4396ALLOCATE(dateiso(SIZE(this)))
4397DO i = 1, SIZE(dateiso)
4399ENDDO
4400INQUIRE(unit, form=form)
4401IF (form == 'FORMATTED') THEN
4402 WRITE(unit,'(3(A23,1X))')dateiso
4403ELSE
4404 WRITE(unit)dateiso
4405ENDIF
4406DEALLOCATE(dateiso)
4407
4408END SUBROUTINE timedelta_vect_write_unit
4409
4410
4411ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4412TYPE(timedelta),INTENT(in) :: this
4413LOGICAL :: res
4414
4415res = .not. this == timedelta_miss
4416
4417end FUNCTION c_e_timedelta
4418
4419
4420elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4421
4422!!omstart JELADATA5
4423! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4424! 1 IMINUTI)
4425!
4426! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4427!
4428! variabili integer*4
4429! IN:
4430! IDAY,IMONTH,IYEAR, I*4
4431! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4432!
4433! OUT:
4434! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4435!!OMEND
4436
4437INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4438INTEGER,intent(out) :: iminuti
4439
4440iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4441
4442END SUBROUTINE jeladata5
4443
4444
4445elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4446INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4447INTEGER(KIND=int_ll),intent(out) :: imillisec
4448
4449imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4450 + imsec
4451
4452END SUBROUTINE jeladata5_1
4453
4454
4455
4456elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4457
4458!!omstart JELADATA6
4459! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4460! 1 IMINUTI)
4461!
4462! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4463! 1/1/1
4464!
4465! variabili integer*4
4466! IN:
4467! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4468!
4469! OUT:
4470! IDAY,IMONTH,IYEAR, I*4
4471! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4472!!OMEND
4473
4474
4475INTEGER,intent(in) :: iminuti
4476INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4477
4478INTEGER ::igiorno
4479
4480imin = mod(iminuti,60)
4481ihour = mod(iminuti,1440)/60
4482igiorno = iminuti/1440
4484CALL ndyin(igiorno,iday,imonth,iyear)
4485
4486END SUBROUTINE jeladata6
4487
4488
4489elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4490INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4491INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4492
4493INTEGER :: igiorno
4494
4496!imin = MOD(imillisec/60000_int_ll, 60)
4497!ihour = MOD(imillisec/3600000_int_ll, 24)
4498imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4499ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4500igiorno = int(imillisec/86400000_int_ll)
4501!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4502CALL ndyin(igiorno,iday,imonth,iyear)
4503
4504END SUBROUTINE jeladata6_1
4505
4506
4507elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4508
4509!!OMSTART NDYIN
4510! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4511! restituisce la data fornendo in input il numero di
4512! giorni dal 1/1/1
4513!
4514!!omend
4515
4516INTEGER,intent(in) :: ndays
4517INTEGER,intent(out) :: igg, imm, iaa
4518integer :: n,lndays
4519
4520lndays=ndays
4521
4522n = lndays/d400
4523lndays = lndays - n*d400
4524iaa = year0 + n*400
4525n = min(lndays/d100, 3)
4526lndays = lndays - n*d100
4527iaa = iaa + n*100
4528n = lndays/d4
4529lndays = lndays - n*d4
4530iaa = iaa + n*4
4531n = min(lndays/d1, 3)
4532lndays = lndays - n*d1
4533iaa = iaa + n
4534n = bisextilis(iaa)
4535DO imm = 1, 12
4536 IF (lndays < ianno(imm+1,n)) EXIT
4537ENDDO
4538igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4539
4540END SUBROUTINE ndyin
4541
4542
4543integer elemental FUNCTION ndays(igg,imm,iaa)
4544
4545!!OMSTART NDAYS
4546! FUNCTION NDAYS(IGG,IMM,IAA)
4547! restituisce il numero di giorni dal 1/1/1
4548! fornendo in input la data
4549!
4550!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4551! nota bene E' SICURO !!!
4552! un anno e' bisestile se divisibile per 4
4553! un anno rimane bisestile se divisibile per 400
4554! un anno NON e' bisestile se divisibile per 100
4555!
4556!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4557!
4558!!omend
4559
4560INTEGER, intent(in) :: igg, imm, iaa
4561
4562INTEGER :: lmonth, lyear
4563
4564! Limito il mese a [1-12] e correggo l'anno coerentemente
4565lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4566lyear = iaa + (imm - lmonth)/12
4567ndays = igg+ianno(lmonth, bisextilis(lyear))
4568ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4569 (lyear-year0)/400
4570
4571END FUNCTION ndays
4572
4573
4574elemental FUNCTION bisextilis(annum)
4575INTEGER,INTENT(in) :: annum
4576INTEGER :: bisextilis
4577
4579 bisextilis = 2
4580ELSE
4581 bisextilis = 1
4582ENDIF
4583END FUNCTION bisextilis
4584
4585
4586ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4587TYPE(cyclicdatetime),INTENT(IN) :: this, that
4588LOGICAL :: res
4589
4590res = .true.
4591if (this%minute /= that%minute) res=.false.
4592if (this%hour /= that%hour) res=.false.
4593if (this%day /= that%day) res=.false.
4594if (this%month /= that%month) res=.false.
4595if (this%tendaysp /= that%tendaysp) res=.false.
4596
4597END FUNCTION cyclicdatetime_eq
4598
4599
4600ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4601TYPE(cyclicdatetime),INTENT(IN) :: this
4602TYPE(datetime),INTENT(IN) :: that
4603LOGICAL :: res
4604
4605integer :: minute,hour,day,month
4606
4608
4609res = .true.
4615 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4616end if
4617
4618END FUNCTION cyclicdatetime_datetime_eq
4619
4620
4621ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4622TYPE(datetime),INTENT(IN) :: this
4623TYPE(cyclicdatetime),INTENT(IN) :: that
4624LOGICAL :: res
4625
4626integer :: minute,hour,day,month
4627
4629
4630res = .true.
4635
4637 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4638end if
4639
4640
4641END FUNCTION datetime_cyclicdatetime_eq
4642
4643ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4644TYPE(cyclicdatetime),INTENT(in) :: this
4645LOGICAL :: res
4646
4647res = .not. this == cyclicdatetime_miss
4648
4649end FUNCTION c_e_cyclicdatetime
4650
4651
4654FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4655INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4656INTEGER,INTENT(IN),OPTIONAL :: month
4657INTEGER,INTENT(IN),OPTIONAL :: day
4658INTEGER,INTENT(IN),OPTIONAL :: hour
4659INTEGER,INTENT(IN),OPTIONAL :: minute
4660CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4661
4662integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4663
4664
4665TYPE(cyclicdatetime) :: this
4666
4667if (present(chardate)) then
4668
4669 ltendaysp=imiss
4670 lmonth=imiss
4671 lday=imiss
4672 lhour=imiss
4673 lminute=imiss
4674
4676 ! TMMGGhhmm
4677 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4678 !print*,chardate(1:1),ios,ltendaysp
4679 if (ios /= 0)ltendaysp=imiss
4680
4681 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4682 !print*,chardate(2:3),ios,lmonth
4683 if (ios /= 0)lmonth=imiss
4684
4685 read(chardate(4:5),'(i2)',iostat=ios)lday
4686 !print*,chardate(4:5),ios,lday
4687 if (ios /= 0)lday=imiss
4688
4689 read(chardate(6:7),'(i2)',iostat=ios)lhour
4690 !print*,chardate(6:7),ios,lhour
4691 if (ios /= 0)lhour=imiss
4692
4693 read(chardate(8:9),'(i2)',iostat=ios)lminute
4694 !print*,chardate(8:9),ios,lminute
4695 if (ios /= 0)lminute=imiss
4696 end if
4697
4698 this%tendaysp=ltendaysp
4699 this%month=lmonth
4700 this%day=lday
4701 this%hour=lhour
4702 this%minute=lminute
4703else
4704 this%tendaysp=optio_l(tendaysp)
4705 this%month=optio_l(month)
4706 this%day=optio_l(day)
4707 this%hour=optio_l(hour)
4708 this%minute=optio_l(minute)
4709end if
4710
4711END FUNCTION cyclicdatetime_new
4712
4715elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4716TYPE(cyclicdatetime),INTENT(IN) :: this
4717
4718CHARACTER(len=80) :: char
4719
4722
4723END FUNCTION cyclicdatetime_to_char
4724
4725
4738FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4739TYPE(cyclicdatetime),INTENT(IN) :: this
4740
4741TYPE(datetime) :: dtc
4742
4743integer :: year,month,day,hour
4744
4745dtc = datetime_miss
4746
4747! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4749 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4750 return
4751end if
4752
4753! minute present -> not good for conventional datetime
4755! day, month and tendaysp present -> no good
4757
4759 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4761 day=(this%tendaysp-1)*10+1
4762 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4764 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4766 ! only day present -> no good
4767 return
4768end if
4769
4772 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4773end if
4774
4775
4776END FUNCTION cyclicdatetime_to_conventional
4777
4778
4779
4780FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4781TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4782
4783CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4784
4785char=cyclicdatetime_to_char(in)
4786
4787END FUNCTION trim_cyclicdatetime_to_char
4788
4789
4790
4791SUBROUTINE display_cyclicdatetime(this)
4792TYPE(cyclicdatetime),INTENT(in) :: this
4793
4795
4796end subroutine display_cyclicdatetime
4797
4798
4799#include "array_utilities_inc.F90"
4800
4802
Quick method to append an element to the array. Definition: datetime_class.F90:616 Restituiscono il valore dell'oggetto nella forma desiderata. Definition: datetime_class.F90:322 Costruttori per le classi datetime e timedelta. Definition: datetime_class.F90:311 Method for inserting elements of the array at a desired position. Definition: datetime_class.F90:607 Method for packing the array object reducing at a minimum the memory occupation, without destroying i... Definition: datetime_class.F90:639 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition: datetime_class.F90:478 Method for removing elements of the array at a desired position. Definition: datetime_class.F90:622 Functions that return a trimmed CHARACTER representation of the input variable. Definition: datetime_class.F90:349 Restituiscono il valore dell'oggetto in forma di stringa stampabile. Definition: datetime_class.F90:327 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition: datetime_class.F90:485 Definition of constants to be used for declaring variables of a desired type. Definition: kinds.F90:245 Definitions of constants and functions for working with missing values. Definition: missing_values.f90:50 Module for quickly interpreting the OPTIONAL parameters passed to a subprogram. Definition: optional_values.f90:28 Class for expressing a cyclic datetime. Definition: datetime_class.F90:255 Class for expressing an absolute time value. Definition: datetime_class.F90:233 Class for expressing a relative time interval. Definition: datetime_class.F90:245 |