libsim Versione 7.1.11
|
◆ index_datetime()
Cerca l'indice del primo o ultimo elemento di vect uguale a search. Definizione alla linea 2969 del file datetime_class.F90. 2971! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2972! authors:
2973! Davide Cesari <dcesari@arpa.emr.it>
2974! Paolo Patruno <ppatruno@arpa.emr.it>
2975
2976! This program is free software; you can redistribute it and/or
2977! modify it under the terms of the GNU General Public License as
2978! published by the Free Software Foundation; either version 2 of
2979! the License, or (at your option) any later version.
2980
2981! This program is distributed in the hope that it will be useful,
2982! but WITHOUT ANY WARRANTY; without even the implied warranty of
2983! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2984! GNU General Public License for more details.
2985
2986! You should have received a copy of the GNU General Public License
2987! along with this program. If not, see <http://www.gnu.org/licenses/>.
2988#include "config.h"
2989
3010IMPLICIT NONE
3011
3012INTEGER, PARAMETER :: dateint=selected_int_kind(13)
3013
3016 PRIVATE
3017 INTEGER(KIND=int_ll) :: iminuti
3019
3028 PRIVATE
3029 INTEGER(KIND=int_ll) :: iminuti
3030 INTEGER :: month
3032
3033
3038 PRIVATE
3039 INTEGER :: minute
3040 INTEGER :: hour
3041 INTEGER :: day
3042 INTEGER :: tendaysp
3043 INTEGER :: month
3045
3046
3054INTEGER, PARAMETER :: datetime_utc=1
3056INTEGER, PARAMETER :: datetime_local=2
3066TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
3067
3068
3069INTEGER(kind=dateint), PARAMETER :: &
3070 sec_in_day=86400, &
3071 sec_in_hour=3600, &
3072 sec_in_min=60, &
3073 min_in_day=1440, &
3074 min_in_hour=60, &
3075 hour_in_day=24
3076
3077INTEGER,PARAMETER :: &
3078 year0=1, & ! anno di origine per iminuti
3079 d1=365, & ! giorni/1 anno nel calendario gregoriano
3080 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
3081 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
3082 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
3083 ianno(13,2)=reshape((/ &
3084 0,31,59,90,120,151,181,212,243,273,304,334,365, &
3085 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
3086
3087INTEGER(KIND=int_ll),PARAMETER :: &
3088 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
3089
3094 MODULE PROCEDURE datetime_init, timedelta_init
3095END INTERFACE
3096
3100 MODULE PROCEDURE datetime_delete, timedelta_delete
3101END INTERFACE
3102
3105 MODULE PROCEDURE datetime_getval, timedelta_getval
3106END INTERFACE
3107
3110 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
3111END INTERFACE
3112
3113
3132 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
3133END INTERFACE
3134
3140INTERFACE OPERATOR (==)
3141 MODULE PROCEDURE datetime_eq, timedelta_eq, &
3142 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
3143END INTERFACE
3144
3150INTERFACE OPERATOR (/=)
3151 MODULE PROCEDURE datetime_ne, timedelta_ne
3152END INTERFACE
3153
3161INTERFACE OPERATOR (>)
3162 MODULE PROCEDURE datetime_gt, timedelta_gt
3163END INTERFACE
3164
3172INTERFACE OPERATOR (<)
3173 MODULE PROCEDURE datetime_lt, timedelta_lt
3174END INTERFACE
3175
3183INTERFACE OPERATOR (>=)
3184 MODULE PROCEDURE datetime_ge, timedelta_ge
3185END INTERFACE
3186
3194INTERFACE OPERATOR (<=)
3195 MODULE PROCEDURE datetime_le, timedelta_le
3196END INTERFACE
3197
3204INTERFACE OPERATOR (+)
3205 MODULE PROCEDURE datetime_add, timedelta_add
3206END INTERFACE
3207
3215INTERFACE OPERATOR (-)
3216 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
3217END INTERFACE
3218
3224INTERFACE OPERATOR (*)
3225 MODULE PROCEDURE timedelta_mult, timedelta_tlum
3226END INTERFACE
3227
3234INTERFACE OPERATOR (/)
3235 MODULE PROCEDURE timedelta_divint, timedelta_divtd
3236END INTERFACE
3237
3249 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3250END INTERFACE
3251
3255 MODULE PROCEDURE timedelta_abs
3256END INTERFACE
3257
3261 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3262 timedelta_read_unit, timedelta_vect_read_unit
3263END INTERFACE
3264
3268 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3269 timedelta_write_unit, timedelta_vect_write_unit
3270END INTERFACE
3271
3274 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3275END INTERFACE
3276
3279 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
3280END INTERFACE
3281
3282#undef VOL7D_POLY_TYPE
3283#undef VOL7D_POLY_TYPES
3284#undef ENABLE_SORT
3285#define VOL7D_POLY_TYPE TYPE(datetime)
3286#define VOL7D_POLY_TYPES _datetime
3287#define ENABLE_SORT
3288#include "array_utilities_pre.F90"
3289
3290
3291#define ARRAYOF_ORIGTYPE TYPE(datetime)
3292#define ARRAYOF_TYPE arrayof_datetime
3293#define ARRAYOF_ORIGEQ 1
3294#include "arrayof_pre.F90"
3295! from arrayof
3296
3297PRIVATE
3298
3300 datetime_min, datetime_max, &
3303 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3304 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3306 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3307 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3309 count_distinct, pack_distinct, &
3310 count_distinct_sorted, pack_distinct_sorted, &
3311 count_and_pack_distinct, &
3313 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
3315PUBLIC insert_unique, append_unique
3316PUBLIC cyclicdatetime_to_conventional
3317
3318CONTAINS
3319
3320
3321! ==============
3322! == datetime ==
3323! ==============
3324
3331ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3332 unixtime, isodate, simpledate) RESULT(this)
3333INTEGER,INTENT(IN),OPTIONAL :: year
3334INTEGER,INTENT(IN),OPTIONAL :: month
3335INTEGER,INTENT(IN),OPTIONAL :: day
3336INTEGER,INTENT(IN),OPTIONAL :: hour
3337INTEGER,INTENT(IN),OPTIONAL :: minute
3338INTEGER,INTENT(IN),OPTIONAL :: msec
3339INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3340CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3341CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3342
3343TYPE(datetime) :: this
3344INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3345CHARACTER(len=23) :: datebuf
3346
3347IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3348 lyear = year
3349 IF (PRESENT(month)) THEN
3350 lmonth = month
3351 ELSE
3352 lmonth = 1
3353 ENDIF
3354 IF (PRESENT(day)) THEN
3355 lday = day
3356 ELSE
3357 lday = 1
3358 ENDIF
3359 IF (PRESENT(hour)) THEN
3360 lhour = hour
3361 ELSE
3362 lhour = 0
3363 ENDIF
3364 IF (PRESENT(minute)) THEN
3365 lminute = minute
3366 ELSE
3367 lminute = 0
3368 ENDIF
3369 IF (PRESENT(msec)) THEN
3370 lmsec = msec
3371 ELSE
3372 lmsec = 0
3373 ENDIF
3374
3377 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3378 else
3379 this=datetime_miss
3380 end if
3381
3382ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3384 this%iminuti = (unixtime + unsec)*1000
3385 else
3386 this=datetime_miss
3387 end if
3388
3389ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3390
3392 datebuf(1:23) = '0001-01-01 00:00:00.000'
3393 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3394 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3395 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3396 lmsec = lmsec + lsec*1000
3397 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3398 RETURN
3399
3400100 CONTINUE ! condizione di errore in isodate
3402 RETURN
3403 ELSE
3404 this = datetime_miss
3405 ENDIF
3406
3407ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3409 datebuf(1:17) = '00010101000000000'
3410 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3411 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3412 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3413 lmsec = lmsec + lsec*1000
3414 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3415 RETURN
3416
3417120 CONTINUE ! condizione di errore in simpledate
3419 RETURN
3420 ELSE
3421 this = datetime_miss
3422 ENDIF
3423
3424ELSE
3425 this = datetime_miss
3426ENDIF
3427
3428END FUNCTION datetime_new
3429
3430
3432FUNCTION datetime_new_now(now) RESULT(this)
3433INTEGER,INTENT(IN) :: now
3434TYPE(datetime) :: this
3435
3436INTEGER :: dt(8)
3437
3439 CALL date_and_time(values=dt)
3440 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3442 msec=dt(7)*1000+dt(8))
3443ELSE
3444 this = datetime_miss
3445ENDIF
3446
3447END FUNCTION datetime_new_now
3448
3449
3456SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3457 unixtime, isodate, simpledate, now)
3458TYPE(datetime),INTENT(INOUT) :: this
3459INTEGER,INTENT(IN),OPTIONAL :: year
3460INTEGER,INTENT(IN),OPTIONAL :: month
3461INTEGER,INTENT(IN),OPTIONAL :: day
3462INTEGER,INTENT(IN),OPTIONAL :: hour
3463INTEGER,INTENT(IN),OPTIONAL :: minute
3464INTEGER,INTENT(IN),OPTIONAL :: msec
3465INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3466CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3467CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3468INTEGER,INTENT(IN),OPTIONAL :: now
3469
3470IF (PRESENT(now)) THEN
3471 this = datetime_new_now(now)
3472ELSE
3473 this = datetime_new(year, month, day, hour, minute, msec, &
3474 unixtime, isodate, simpledate)
3475ENDIF
3476
3477END SUBROUTINE datetime_init
3478
3479
3480ELEMENTAL SUBROUTINE datetime_delete(this)
3481TYPE(datetime),INTENT(INOUT) :: this
3482
3483this%iminuti = illmiss
3484
3485END SUBROUTINE datetime_delete
3486
3487
3492PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3493 unixtime, isodate, simpledate, oraclesimdate)
3494TYPE(datetime),INTENT(IN) :: this
3495INTEGER,INTENT(OUT),OPTIONAL :: year
3496INTEGER,INTENT(OUT),OPTIONAL :: month
3497INTEGER,INTENT(OUT),OPTIONAL :: day
3498INTEGER,INTENT(OUT),OPTIONAL :: hour
3499INTEGER,INTENT(OUT),OPTIONAL :: minute
3500INTEGER,INTENT(OUT),OPTIONAL :: msec
3501INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3502CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3503CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3504CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3505
3506INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3507CHARACTER(len=23) :: datebuf
3508
3509IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3510 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3511 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3512
3513 IF (this == datetime_miss) THEN
3514
3515 IF (PRESENT(msec)) THEN
3516 msec = imiss
3517 ENDIF
3518 IF (PRESENT(minute)) THEN
3519 minute = imiss
3520 ENDIF
3521 IF (PRESENT(hour)) THEN
3522 hour = imiss
3523 ENDIF
3524 IF (PRESENT(day)) THEN
3525 day = imiss
3526 ENDIF
3527 IF (PRESENT(month)) THEN
3528 month = imiss
3529 ENDIF
3530 IF (PRESENT(year)) THEN
3531 year = imiss
3532 ENDIF
3533 IF (PRESENT(isodate)) THEN
3534 isodate = cmiss
3535 ENDIF
3536 IF (PRESENT(simpledate)) THEN
3537 simpledate = cmiss
3538 ENDIF
3539 IF (PRESENT(oraclesimdate)) THEN
3540!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3541!!$ 'obsoleto, usare piuttosto simpledate')
3542 oraclesimdate=cmiss
3543 ENDIF
3544 IF (PRESENT(unixtime)) THEN
3545 unixtime = illmiss
3546 ENDIF
3547
3548 ELSE
3549
3550 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3551 IF (PRESENT(msec)) THEN
3552 msec = lmsec
3553 ENDIF
3554 IF (PRESENT(minute)) THEN
3555 minute = lminute
3556 ENDIF
3557 IF (PRESENT(hour)) THEN
3558 hour = lhour
3559 ENDIF
3560 IF (PRESENT(day)) THEN
3561 day = lday
3562 ENDIF
3563 IF (PRESENT(month)) THEN
3564 month = lmonth
3565 ENDIF
3566 IF (PRESENT(year)) THEN
3567 year = lyear
3568 ENDIF
3569 IF (PRESENT(isodate)) THEN
3570 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3571 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3573 isodate = datebuf(1:min(len(isodate),23))
3574 ENDIF
3575 IF (PRESENT(simpledate)) THEN
3576 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3577 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3578 simpledate = datebuf(1:min(len(simpledate),17))
3579 ENDIF
3580 IF (PRESENT(oraclesimdate)) THEN
3581!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3582!!$ 'obsoleto, usare piuttosto simpledate')
3583 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3584 ENDIF
3585 IF (PRESENT(unixtime)) THEN
3586 unixtime = this%iminuti/1000_int_ll-unsec
3587 ENDIF
3588
3589 ENDIF
3590ENDIF
3591
3592END SUBROUTINE datetime_getval
3593
3594
3597elemental FUNCTION datetime_to_char(this) RESULT(char)
3598TYPE(datetime),INTENT(IN) :: this
3599
3600CHARACTER(len=23) :: char
3601
3603
3604END FUNCTION datetime_to_char
3605
3606
3607FUNCTION trim_datetime_to_char(in) RESULT(char)
3608TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3609
3610CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3611
3612char=datetime_to_char(in)
3613
3614END FUNCTION trim_datetime_to_char
3615
3616
3617
3618SUBROUTINE display_datetime(this)
3619TYPE(datetime),INTENT(in) :: this
3620
3622
3623end subroutine display_datetime
3624
3625
3626
3627SUBROUTINE display_timedelta(this)
3628TYPE(timedelta),INTENT(in) :: this
3629
3631
3632end subroutine display_timedelta
3633
3634
3635
3636ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3637TYPE(datetime),INTENT(in) :: this
3638LOGICAL :: res
3639
3640res = .not. this == datetime_miss
3641
3642end FUNCTION c_e_datetime
3643
3644
3645ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3646TYPE(datetime),INTENT(IN) :: this, that
3647LOGICAL :: res
3648
3649res = this%iminuti == that%iminuti
3650
3651END FUNCTION datetime_eq
3652
3653
3654ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3655TYPE(datetime),INTENT(IN) :: this, that
3656LOGICAL :: res
3657
3658res = .NOT.(this == that)
3659
3660END FUNCTION datetime_ne
3661
3662
3663ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3664TYPE(datetime),INTENT(IN) :: this, that
3665LOGICAL :: res
3666
3667res = this%iminuti > that%iminuti
3668
3669END FUNCTION datetime_gt
3670
3671
3672ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3673TYPE(datetime),INTENT(IN) :: this, that
3674LOGICAL :: res
3675
3676res = this%iminuti < that%iminuti
3677
3678END FUNCTION datetime_lt
3679
3680
3681ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3682TYPE(datetime),INTENT(IN) :: this, that
3683LOGICAL :: res
3684
3685IF (this == that) THEN
3686 res = .true.
3687ELSE IF (this > that) THEN
3688 res = .true.
3689ELSE
3690 res = .false.
3691ENDIF
3692
3693END FUNCTION datetime_ge
3694
3695
3696ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3697TYPE(datetime),INTENT(IN) :: this, that
3698LOGICAL :: res
3699
3700IF (this == that) THEN
3701 res = .true.
3702ELSE IF (this < that) THEN
3703 res = .true.
3704ELSE
3705 res = .false.
3706ENDIF
3707
3708END FUNCTION datetime_le
3709
3710
3711FUNCTION datetime_add(this, that) RESULT(res)
3712TYPE(datetime),INTENT(IN) :: this
3713TYPE(timedelta),INTENT(IN) :: that
3714TYPE(datetime) :: res
3715
3716INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3717
3718IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3719 res = datetime_miss
3720ELSE
3721 res%iminuti = this%iminuti + that%iminuti
3722 IF (that%month /= 0) THEN
3724 minute=lminute, msec=lmsec)
3726 hour=lhour, minute=lminute, msec=lmsec)
3727 ENDIF
3728ENDIF
3729
3730END FUNCTION datetime_add
3731
3732
3733ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3734TYPE(datetime),INTENT(IN) :: this, that
3735TYPE(timedelta) :: res
3736
3737IF (this == datetime_miss .OR. that == datetime_miss) THEN
3738 res = timedelta_miss
3739ELSE
3740 res%iminuti = this%iminuti - that%iminuti
3741 res%month = 0
3742ENDIF
3743
3744END FUNCTION datetime_subdt
3745
3746
3747FUNCTION datetime_subtd(this, that) RESULT(res)
3748TYPE(datetime),INTENT(IN) :: this
3749TYPE(timedelta),INTENT(IN) :: that
3750TYPE(datetime) :: res
3751
3752INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3753
3754IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3755 res = datetime_miss
3756ELSE
3757 res%iminuti = this%iminuti - that%iminuti
3758 IF (that%month /= 0) THEN
3760 minute=lminute, msec=lmsec)
3762 hour=lhour, minute=lminute, msec=lmsec)
3763 ENDIF
3764ENDIF
3765
3766END FUNCTION datetime_subtd
3767
3768
3773SUBROUTINE datetime_read_unit(this, unit)
3774TYPE(datetime),INTENT(out) :: this
3775INTEGER, INTENT(in) :: unit
3776CALL datetime_vect_read_unit((/this/), unit)
3777
3778END SUBROUTINE datetime_read_unit
3779
3780
3785SUBROUTINE datetime_vect_read_unit(this, unit)
3786TYPE(datetime) :: this(:)
3787INTEGER, INTENT(in) :: unit
3788
3789CHARACTER(len=40) :: form
3790CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3791INTEGER :: i
3792
3793ALLOCATE(dateiso(SIZE(this)))
3794INQUIRE(unit, form=form)
3795IF (form == 'FORMATTED') THEN
3796 READ(unit,'(A23,1X)')dateiso
3797ELSE
3798 READ(unit)dateiso
3799ENDIF
3800DO i = 1, SIZE(dateiso)
3802ENDDO
3803DEALLOCATE(dateiso)
3804
3805END SUBROUTINE datetime_vect_read_unit
3806
3807
3812SUBROUTINE datetime_write_unit(this, unit)
3813TYPE(datetime),INTENT(in) :: this
3814INTEGER, INTENT(in) :: unit
3815
3816CALL datetime_vect_write_unit((/this/), unit)
3817
3818END SUBROUTINE datetime_write_unit
3819
3820
3825SUBROUTINE datetime_vect_write_unit(this, unit)
3826TYPE(datetime),INTENT(in) :: this(:)
3827INTEGER, INTENT(in) :: unit
3828
3829CHARACTER(len=40) :: form
3830CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3831INTEGER :: i
3832
3833ALLOCATE(dateiso(SIZE(this)))
3834DO i = 1, SIZE(dateiso)
3836ENDDO
3837INQUIRE(unit, form=form)
3838IF (form == 'FORMATTED') THEN
3839 WRITE(unit,'(A23,1X)')dateiso
3840ELSE
3841 WRITE(unit)dateiso
3842ENDIF
3843DEALLOCATE(dateiso)
3844
3845END SUBROUTINE datetime_vect_write_unit
3846
3847
3848#include "arrayof_post.F90"
3849
3850
3851! ===============
3852! == timedelta ==
3853! ===============
3860FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3861 isodate, simpledate, oraclesimdate) RESULT (this)
3862INTEGER,INTENT(IN),OPTIONAL :: year
3863INTEGER,INTENT(IN),OPTIONAL :: month
3864INTEGER,INTENT(IN),OPTIONAL :: day
3865INTEGER,INTENT(IN),OPTIONAL :: hour
3866INTEGER,INTENT(IN),OPTIONAL :: minute
3867INTEGER,INTENT(IN),OPTIONAL :: sec
3868INTEGER,INTENT(IN),OPTIONAL :: msec
3869CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3870CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3871CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3872
3873TYPE(timedelta) :: this
3874
3875CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3876 isodate, simpledate, oraclesimdate)
3877
3878END FUNCTION timedelta_new
3879
3880
3885SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3886 isodate, simpledate, oraclesimdate)
3887TYPE(timedelta),INTENT(INOUT) :: this
3888INTEGER,INTENT(IN),OPTIONAL :: year
3889INTEGER,INTENT(IN),OPTIONAL :: month
3890INTEGER,INTENT(IN),OPTIONAL :: day
3891INTEGER,INTENT(IN),OPTIONAL :: hour
3892INTEGER,INTENT(IN),OPTIONAL :: minute
3893INTEGER,INTENT(IN),OPTIONAL :: sec
3894INTEGER,INTENT(IN),OPTIONAL :: msec
3895CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3896CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3897CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3898
3899INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3900CHARACTER(len=23) :: datebuf
3901
3902this%month = 0
3903
3904IF (PRESENT(isodate)) THEN
3905 datebuf(1:23) = '0000000000 00:00:00.000'
3906 l = len_trim(isodate)
3907! IF (l > 0) THEN
3909 IF (n > 0) THEN
3910 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3911 datebuf(12-n:12-n+l-1) = isodate(:l)
3912 ELSE
3913 datebuf(1:l) = isodate(1:l)
3914 ENDIF
3915! ENDIF
3916
3917! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3918 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3919 h, m, s, ms
3920 this%month = lmonth + 12*lyear
3921 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3922 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3923 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3924 RETURN
3925
3926200 CONTINUE ! condizione di errore in isodate
3928 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
3929 CALL raise_error()
3930
3931ELSE IF (PRESENT(simpledate)) THEN
3932 datebuf(1:17) = '00000000000000000'
3933 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3934 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
3935 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3936 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
3937 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
3938
3939220 CONTINUE ! condizione di errore in simpledate
3941 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
3942 CALL raise_error()
3943 RETURN
3944
3945ELSE IF (PRESENT(oraclesimdate)) THEN
3946 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
3947 'obsoleto, usare piuttosto simpledate')
3948 READ(oraclesimdate, '(I8,2I2)')d, h, m
3949 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3950 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
3951
3952ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
3953 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
3954 .and. .not. present(msec) .and. .not. present(isodate) &
3955 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
3956
3957 this=timedelta_miss
3958
3959ELSE
3960 this%iminuti = 0
3961 IF (PRESENT(year)) THEN
3963 this%month = this%month + year*12
3964 else
3965 this=timedelta_miss
3966 return
3967 end if
3968 ENDIF
3969 IF (PRESENT(month)) THEN
3971 this%month = this%month + month
3972 else
3973 this=timedelta_miss
3974 return
3975 end if
3976 ENDIF
3977 IF (PRESENT(day)) THEN
3979 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
3980 else
3981 this=timedelta_miss
3982 return
3983 end if
3984 ENDIF
3985 IF (PRESENT(hour)) THEN
3987 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
3988 else
3989 this=timedelta_miss
3990 return
3991 end if
3992 ENDIF
3993 IF (PRESENT(minute)) THEN
3995 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
3996 else
3997 this=timedelta_miss
3998 return
3999 end if
4000 ENDIF
4001 IF (PRESENT(sec)) THEN
4003 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
4004 else
4005 this=timedelta_miss
4006 return
4007 end if
4008 ENDIF
4009 IF (PRESENT(msec)) THEN
4011 this%iminuti = this%iminuti + msec
4012 else
4013 this=timedelta_miss
4014 return
4015 end if
4016 ENDIF
4017ENDIF
4018
4019
4020
4021
4022END SUBROUTINE timedelta_init
4023
4024
4025SUBROUTINE timedelta_delete(this)
4026TYPE(timedelta),INTENT(INOUT) :: this
4027
4028this%iminuti = imiss
4029this%month = 0
4030
4031END SUBROUTINE timedelta_delete
4032
4033
4038PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
4039 day, hour, minute, sec, msec, &
4040 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
4041TYPE(timedelta),INTENT(IN) :: this
4042INTEGER,INTENT(OUT),OPTIONAL :: year
4043INTEGER,INTENT(OUT),OPTIONAL :: month
4044INTEGER,INTENT(OUT),OPTIONAL :: amonth
4045INTEGER,INTENT(OUT),OPTIONAL :: day
4046INTEGER,INTENT(OUT),OPTIONAL :: hour
4047INTEGER,INTENT(OUT),OPTIONAL :: minute
4048INTEGER,INTENT(OUT),OPTIONAL :: sec
4049INTEGER,INTENT(OUT),OPTIONAL :: msec
4050INTEGER,INTENT(OUT),OPTIONAL :: ahour
4051INTEGER,INTENT(OUT),OPTIONAL :: aminute
4052INTEGER,INTENT(OUT),OPTIONAL :: asec
4053INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
4054CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
4055CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
4056CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
4057
4058CHARACTER(len=23) :: datebuf
4059
4060IF (PRESENT(amsec)) THEN
4061 amsec = this%iminuti
4062ENDIF
4063IF (PRESENT(asec)) THEN
4064 asec = int(this%iminuti/1000_int_ll)
4065ENDIF
4066IF (PRESENT(aminute)) THEN
4067 aminute = int(this%iminuti/60000_int_ll)
4068ENDIF
4069IF (PRESENT(ahour)) THEN
4070 ahour = int(this%iminuti/3600000_int_ll)
4071ENDIF
4072IF (PRESENT(msec)) THEN
4073 msec = int(mod(this%iminuti, 1000_int_ll))
4074ENDIF
4075IF (PRESENT(sec)) THEN
4076 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
4077ENDIF
4078IF (PRESENT(minute)) THEN
4079 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
4080ENDIF
4081IF (PRESENT(hour)) THEN
4082 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
4083ENDIF
4084IF (PRESENT(day)) THEN
4085 day = int(this%iminuti/86400000_int_ll)
4086ENDIF
4087IF (PRESENT(amonth)) THEN
4088 amonth = this%month
4089ENDIF
4090IF (PRESENT(month)) THEN
4091 month = mod(this%month-1,12)+1
4092ENDIF
4093IF (PRESENT(year)) THEN
4094 year = this%month/12
4095ENDIF
4096IF (PRESENT(isodate)) THEN ! Non standard, inventato!
4097 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
4101 isodate = datebuf(1:min(len(isodate),23))
4102
4103ENDIF
4104IF (PRESENT(simpledate)) THEN
4105 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
4106 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
4108 mod(this%iminuti, 1000_int_ll)
4109 simpledate = datebuf(1:min(len(simpledate),17))
4110ENDIF
4111IF (PRESENT(oraclesimdate)) THEN
4112!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
4113!!$ 'obsoleto, usare piuttosto simpledate')
4114 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
4116ENDIF
4117
4118END SUBROUTINE timedelta_getval
4119
4120
4123elemental FUNCTION timedelta_to_char(this) RESULT(char)
4124TYPE(timedelta),INTENT(IN) :: this
4125
4126CHARACTER(len=23) :: char
4127
4129
4130END FUNCTION timedelta_to_char
4131
4132
4133FUNCTION trim_timedelta_to_char(in) RESULT(char)
4134TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
4135
4136CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
4137
4138char=timedelta_to_char(in)
4139
4140END FUNCTION trim_timedelta_to_char
4141
4142
4144elemental FUNCTION timedelta_getamsec(this)
4145TYPE(timedelta),INTENT(IN) :: this
4146INTEGER(kind=int_ll) :: timedelta_getamsec
4147
4148timedelta_getamsec = this%iminuti
4149
4150END FUNCTION timedelta_getamsec
4151
4152
4158FUNCTION timedelta_depop(this)
4159TYPE(timedelta),INTENT(IN) :: this
4160TYPE(timedelta) :: timedelta_depop
4161
4162TYPE(datetime) :: tmpdt
4163
4164IF (this%month == 0) THEN
4165 timedelta_depop = this
4166ELSE
4167 tmpdt = datetime_new(1970, 1, 1)
4168 timedelta_depop = (tmpdt + this) - tmpdt
4169ENDIF
4170
4171END FUNCTION timedelta_depop
4172
4173
4174elemental FUNCTION timedelta_eq(this, that) RESULT(res)
4175TYPE(timedelta),INTENT(IN) :: this, that
4176LOGICAL :: res
4177
4178res = (this%iminuti == that%iminuti .AND. this%month == that%month)
4179
4180END FUNCTION timedelta_eq
4181
4182
4183ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
4184TYPE(timedelta),INTENT(IN) :: this, that
4185LOGICAL :: res
4186
4187res = .NOT.(this == that)
4188
4189END FUNCTION timedelta_ne
4190
4191
4192ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
4193TYPE(timedelta),INTENT(IN) :: this, that
4194LOGICAL :: res
4195
4196res = this%iminuti > that%iminuti
4197
4198END FUNCTION timedelta_gt
4199
4200
4201ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
4202TYPE(timedelta),INTENT(IN) :: this, that
4203LOGICAL :: res
4204
4205res = this%iminuti < that%iminuti
4206
4207END FUNCTION timedelta_lt
4208
4209
4210ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
4211TYPE(timedelta),INTENT(IN) :: this, that
4212LOGICAL :: res
4213
4214IF (this == that) THEN
4215 res = .true.
4216ELSE IF (this > that) THEN
4217 res = .true.
4218ELSE
4219 res = .false.
4220ENDIF
4221
4222END FUNCTION timedelta_ge
4223
4224
4225elemental FUNCTION timedelta_le(this, that) RESULT(res)
4226TYPE(timedelta),INTENT(IN) :: this, that
4227LOGICAL :: res
4228
4229IF (this == that) THEN
4230 res = .true.
4231ELSE IF (this < that) THEN
4232 res = .true.
4233ELSE
4234 res = .false.
4235ENDIF
4236
4237END FUNCTION timedelta_le
4238
4239
4240ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
4241TYPE(timedelta),INTENT(IN) :: this, that
4242TYPE(timedelta) :: res
4243
4244res%iminuti = this%iminuti + that%iminuti
4245res%month = this%month + that%month
4246
4247END FUNCTION timedelta_add
4248
4249
4250ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
4251TYPE(timedelta),INTENT(IN) :: this, that
4252TYPE(timedelta) :: res
4253
4254res%iminuti = this%iminuti - that%iminuti
4255res%month = this%month - that%month
4256
4257END FUNCTION timedelta_sub
4258
4259
4260ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
4261TYPE(timedelta),INTENT(IN) :: this
4262INTEGER,INTENT(IN) :: n
4263TYPE(timedelta) :: res
4264
4265res%iminuti = this%iminuti*n
4266res%month = this%month*n
4267
4268END FUNCTION timedelta_mult
4269
4270
4271ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
4272INTEGER,INTENT(IN) :: n
4273TYPE(timedelta),INTENT(IN) :: this
4274TYPE(timedelta) :: res
4275
4276res%iminuti = this%iminuti*n
4277res%month = this%month*n
4278
4279END FUNCTION timedelta_tlum
4280
4281
4282ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
4283TYPE(timedelta),INTENT(IN) :: this
4284INTEGER,INTENT(IN) :: n
4285TYPE(timedelta) :: res
4286
4287res%iminuti = this%iminuti/n
4288res%month = this%month/n
4289
4290END FUNCTION timedelta_divint
4291
4292
4293ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
4294TYPE(timedelta),INTENT(IN) :: this, that
4295INTEGER :: res
4296
4297res = int(this%iminuti/that%iminuti)
4298
4299END FUNCTION timedelta_divtd
4300
4301
4302elemental FUNCTION timedelta_mod(this, that) RESULT(res)
4303TYPE(timedelta),INTENT(IN) :: this, that
4304TYPE(timedelta) :: res
4305
4306res%iminuti = mod(this%iminuti, that%iminuti)
4307res%month = 0
4308
4309END FUNCTION timedelta_mod
4310
4311
4312ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
4313TYPE(datetime),INTENT(IN) :: this
4314TYPE(timedelta),INTENT(IN) :: that
4315TYPE(timedelta) :: res
4316
4317IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
4318 res = timedelta_0
4319ELSE
4320 res%iminuti = mod(this%iminuti, that%iminuti)
4321 res%month = 0
4322ENDIF
4323
4324END FUNCTION datetime_timedelta_mod
4325
4326
4327ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
4328TYPE(timedelta),INTENT(IN) :: this
4329TYPE(timedelta) :: res
4330
4331res%iminuti = abs(this%iminuti)
4332res%month = abs(this%month)
4333
4334END FUNCTION timedelta_abs
4335
4336
4341SUBROUTINE timedelta_read_unit(this, unit)
4342TYPE(timedelta),INTENT(out) :: this
4343INTEGER, INTENT(in) :: unit
4344
4345CALL timedelta_vect_read_unit((/this/), unit)
4346
4347END SUBROUTINE timedelta_read_unit
4348
4349
4354SUBROUTINE timedelta_vect_read_unit(this, unit)
4355TYPE(timedelta) :: this(:)
4356INTEGER, INTENT(in) :: unit
4357
4358CHARACTER(len=40) :: form
4359CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4360INTEGER :: i
4361
4362ALLOCATE(dateiso(SIZE(this)))
4363INQUIRE(unit, form=form)
4364IF (form == 'FORMATTED') THEN
4365 READ(unit,'(3(A23,1X))')dateiso
4366ELSE
4367 READ(unit)dateiso
4368ENDIF
4369DO i = 1, SIZE(dateiso)
4371ENDDO
4372DEALLOCATE(dateiso)
4373
4374END SUBROUTINE timedelta_vect_read_unit
4375
4376
4381SUBROUTINE timedelta_write_unit(this, unit)
4382TYPE(timedelta),INTENT(in) :: this
4383INTEGER, INTENT(in) :: unit
4384
4385CALL timedelta_vect_write_unit((/this/), unit)
4386
4387END SUBROUTINE timedelta_write_unit
4388
4389
4394SUBROUTINE timedelta_vect_write_unit(this, unit)
4395TYPE(timedelta),INTENT(in) :: this(:)
4396INTEGER, INTENT(in) :: unit
4397
4398CHARACTER(len=40) :: form
4399CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4400INTEGER :: i
4401
4402ALLOCATE(dateiso(SIZE(this)))
4403DO i = 1, SIZE(dateiso)
4405ENDDO
4406INQUIRE(unit, form=form)
4407IF (form == 'FORMATTED') THEN
4408 WRITE(unit,'(3(A23,1X))')dateiso
4409ELSE
4410 WRITE(unit)dateiso
4411ENDIF
4412DEALLOCATE(dateiso)
4413
4414END SUBROUTINE timedelta_vect_write_unit
4415
4416
4417ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4418TYPE(timedelta),INTENT(in) :: this
4419LOGICAL :: res
4420
4421res = .not. this == timedelta_miss
4422
4423end FUNCTION c_e_timedelta
4424
4425
4426elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4427
4428!!omstart JELADATA5
4429! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4430! 1 IMINUTI)
4431!
4432! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4433!
4434! variabili integer*4
4435! IN:
4436! IDAY,IMONTH,IYEAR, I*4
4437! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4438!
4439! OUT:
4440! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4441!!OMEND
4442
4443INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4444INTEGER,intent(out) :: iminuti
4445
4446iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4447
4448END SUBROUTINE jeladata5
4449
4450
4451elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4452INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4453INTEGER(KIND=int_ll),intent(out) :: imillisec
4454
4455imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4456 + imsec
4457
4458END SUBROUTINE jeladata5_1
4459
4460
4461
4462elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4463
4464!!omstart JELADATA6
4465! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4466! 1 IMINUTI)
4467!
4468! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4469! 1/1/1
4470!
4471! variabili integer*4
4472! IN:
4473! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4474!
4475! OUT:
4476! IDAY,IMONTH,IYEAR, I*4
4477! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4478!!OMEND
4479
4480
4481INTEGER,intent(in) :: iminuti
4482INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4483
4484INTEGER ::igiorno
4485
4486imin = mod(iminuti,60)
4487ihour = mod(iminuti,1440)/60
4488igiorno = iminuti/1440
4490CALL ndyin(igiorno,iday,imonth,iyear)
4491
4492END SUBROUTINE jeladata6
4493
4494
4495elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4496INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4497INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4498
4499INTEGER :: igiorno
4500
4502!imin = MOD(imillisec/60000_int_ll, 60)
4503!ihour = MOD(imillisec/3600000_int_ll, 24)
4504imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4505ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4506igiorno = int(imillisec/86400000_int_ll)
4507!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4508CALL ndyin(igiorno,iday,imonth,iyear)
4509
4510END SUBROUTINE jeladata6_1
4511
4512
4513elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4514
4515!!OMSTART NDYIN
4516! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4517! restituisce la data fornendo in input il numero di
4518! giorni dal 1/1/1
4519!
4520!!omend
4521
4522INTEGER,intent(in) :: ndays
4523INTEGER,intent(out) :: igg, imm, iaa
4524integer :: n,lndays
4525
4526lndays=ndays
4527
4528n = lndays/d400
4529lndays = lndays - n*d400
4530iaa = year0 + n*400
4531n = min(lndays/d100, 3)
4532lndays = lndays - n*d100
4533iaa = iaa + n*100
4534n = lndays/d4
4535lndays = lndays - n*d4
4536iaa = iaa + n*4
4537n = min(lndays/d1, 3)
4538lndays = lndays - n*d1
4539iaa = iaa + n
4540n = bisextilis(iaa)
4541DO imm = 1, 12
4542 IF (lndays < ianno(imm+1,n)) EXIT
4543ENDDO
4544igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4545
4546END SUBROUTINE ndyin
4547
4548
4549integer elemental FUNCTION ndays(igg,imm,iaa)
4550
4551!!OMSTART NDAYS
4552! FUNCTION NDAYS(IGG,IMM,IAA)
4553! restituisce il numero di giorni dal 1/1/1
4554! fornendo in input la data
4555!
4556!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4557! nota bene E' SICURO !!!
4558! un anno e' bisestile se divisibile per 4
4559! un anno rimane bisestile se divisibile per 400
4560! un anno NON e' bisestile se divisibile per 100
4561!
4562!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4563!
4564!!omend
4565
4566INTEGER, intent(in) :: igg, imm, iaa
4567
4568INTEGER :: lmonth, lyear
4569
4570! Limito il mese a [1-12] e correggo l'anno coerentemente
4571lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4572lyear = iaa + (imm - lmonth)/12
4573ndays = igg+ianno(lmonth, bisextilis(lyear))
4574ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4575 (lyear-year0)/400
4576
4577END FUNCTION ndays
4578
4579
4580elemental FUNCTION bisextilis(annum)
4581INTEGER,INTENT(in) :: annum
4582INTEGER :: bisextilis
4583
4585 bisextilis = 2
4586ELSE
4587 bisextilis = 1
4588ENDIF
4589END FUNCTION bisextilis
4590
4591
4592ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4593TYPE(cyclicdatetime),INTENT(IN) :: this, that
4594LOGICAL :: res
4595
4596res = .true.
4597if (this%minute /= that%minute) res=.false.
4598if (this%hour /= that%hour) res=.false.
4599if (this%day /= that%day) res=.false.
4600if (this%month /= that%month) res=.false.
4601if (this%tendaysp /= that%tendaysp) res=.false.
4602
4603END FUNCTION cyclicdatetime_eq
4604
4605
4606ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4607TYPE(cyclicdatetime),INTENT(IN) :: this
4608TYPE(datetime),INTENT(IN) :: that
4609LOGICAL :: res
4610
4611integer :: minute,hour,day,month
4612
4614
4615res = .true.
4621 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4622end if
4623
4624END FUNCTION cyclicdatetime_datetime_eq
4625
4626
4627ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4628TYPE(datetime),INTENT(IN) :: this
4629TYPE(cyclicdatetime),INTENT(IN) :: that
4630LOGICAL :: res
4631
4632integer :: minute,hour,day,month
4633
4635
4636res = .true.
4641
4643 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4644end if
4645
4646
4647END FUNCTION datetime_cyclicdatetime_eq
4648
4649ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4650TYPE(cyclicdatetime),INTENT(in) :: this
4651LOGICAL :: res
4652
4653res = .not. this == cyclicdatetime_miss
4654
4655end FUNCTION c_e_cyclicdatetime
4656
4657
4660FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4661INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4662INTEGER,INTENT(IN),OPTIONAL :: month
4663INTEGER,INTENT(IN),OPTIONAL :: day
4664INTEGER,INTENT(IN),OPTIONAL :: hour
4665INTEGER,INTENT(IN),OPTIONAL :: minute
4666CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4667
4668integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4669
4670
4671TYPE(cyclicdatetime) :: this
4672
4673if (present(chardate)) then
4674
4675 ltendaysp=imiss
4676 lmonth=imiss
4677 lday=imiss
4678 lhour=imiss
4679 lminute=imiss
4680
4682 ! TMMGGhhmm
4683 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4684 !print*,chardate(1:1),ios,ltendaysp
4685 if (ios /= 0)ltendaysp=imiss
4686
4687 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4688 !print*,chardate(2:3),ios,lmonth
4689 if (ios /= 0)lmonth=imiss
4690
4691 read(chardate(4:5),'(i2)',iostat=ios)lday
4692 !print*,chardate(4:5),ios,lday
4693 if (ios /= 0)lday=imiss
4694
4695 read(chardate(6:7),'(i2)',iostat=ios)lhour
4696 !print*,chardate(6:7),ios,lhour
4697 if (ios /= 0)lhour=imiss
4698
4699 read(chardate(8:9),'(i2)',iostat=ios)lminute
4700 !print*,chardate(8:9),ios,lminute
4701 if (ios /= 0)lminute=imiss
4702 end if
4703
4704 this%tendaysp=ltendaysp
4705 this%month=lmonth
4706 this%day=lday
4707 this%hour=lhour
4708 this%minute=lminute
4709else
4710 this%tendaysp=optio_l(tendaysp)
4711 this%month=optio_l(month)
4712 this%day=optio_l(day)
4713 this%hour=optio_l(hour)
4714 this%minute=optio_l(minute)
4715end if
4716
4717END FUNCTION cyclicdatetime_new
4718
4721elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4722TYPE(cyclicdatetime),INTENT(IN) :: this
4723
4724CHARACTER(len=80) :: char
4725
4728
4729END FUNCTION cyclicdatetime_to_char
4730
4731
4744FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4745TYPE(cyclicdatetime),INTENT(IN) :: this
4746
4747TYPE(datetime) :: dtc
4748
4749integer :: year,month,day,hour
4750
4751dtc = datetime_miss
4752
4753! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4755 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4756 return
4757end if
4758
4759! minute present -> not good for conventional datetime
4761! day, month and tendaysp present -> no good
4763
4765 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4767 day=(this%tendaysp-1)*10+1
4768 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4770 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4772 ! only day present -> no good
4773 return
4774end if
4775
4778 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4779end if
4780
4781
4782END FUNCTION cyclicdatetime_to_conventional
4783
4784
4785
4786FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4787TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4788
4789CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4790
4791char=cyclicdatetime_to_char(in)
4792
4793END FUNCTION trim_cyclicdatetime_to_char
4794
4795
4796
4797SUBROUTINE display_cyclicdatetime(this)
4798TYPE(cyclicdatetime),INTENT(in) :: this
4799
4801
4802end subroutine display_cyclicdatetime
4803
4804
4805#include "array_utilities_inc.F90"
4806
4808
Quick method to append an element to the array. Definition: datetime_class.F90:622 Restituiscono il valore dell'oggetto nella forma desiderata. Definition: datetime_class.F90:328 Costruttori per le classi datetime e timedelta. Definition: datetime_class.F90:317 Method for inserting elements of the array at a desired position. Definition: datetime_class.F90:613 Method for packing the array object reducing at a minimum the memory occupation, without destroying i... Definition: datetime_class.F90:645 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition: datetime_class.F90:484 Method for removing elements of the array at a desired position. Definition: datetime_class.F90:628 Functions that return a trimmed CHARACTER representation of the input variable. Definition: datetime_class.F90:355 Restituiscono il valore dell'oggetto in forma di stringa stampabile. Definition: datetime_class.F90:333 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition: datetime_class.F90:491 Definition of constants to be used for declaring variables of a desired type. Definition: kinds.F90:251 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:261 Class for expressing an absolute time value. Definition: datetime_class.F90:239 Class for expressing a relative time interval. Definition: datetime_class.F90:251 |