libsim Versione 7.1.11
|
◆ index_sorted_datetime()
Cerca l'indice del primo o ultimo elemento di vect uguale a search. Definizione alla linea 3046 del file datetime_class.F90. 3048! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
3049! authors:
3050! Davide Cesari <dcesari@arpa.emr.it>
3051! Paolo Patruno <ppatruno@arpa.emr.it>
3052
3053! This program is free software; you can redistribute it and/or
3054! modify it under the terms of the GNU General Public License as
3055! published by the Free Software Foundation; either version 2 of
3056! the License, or (at your option) any later version.
3057
3058! This program is distributed in the hope that it will be useful,
3059! but WITHOUT ANY WARRANTY; without even the implied warranty of
3060! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3061! GNU General Public License for more details.
3062
3063! You should have received a copy of the GNU General Public License
3064! along with this program. If not, see <http://www.gnu.org/licenses/>.
3065#include "config.h"
3066
3087IMPLICIT NONE
3088
3089INTEGER, PARAMETER :: dateint=selected_int_kind(13)
3090
3093 PRIVATE
3094 INTEGER(KIND=int_ll) :: iminuti
3096
3105 PRIVATE
3106 INTEGER(KIND=int_ll) :: iminuti
3107 INTEGER :: month
3109
3110
3115 PRIVATE
3116 INTEGER :: minute
3117 INTEGER :: hour
3118 INTEGER :: day
3119 INTEGER :: tendaysp
3120 INTEGER :: month
3122
3123
3131INTEGER, PARAMETER :: datetime_utc=1
3133INTEGER, PARAMETER :: datetime_local=2
3143TYPE(cyclicdatetime), PARAMETER :: cyclicdatetime_miss=cyclicdatetime(imiss,imiss,imiss,imiss,imiss)
3144
3145
3146INTEGER(kind=dateint), PARAMETER :: &
3147 sec_in_day=86400, &
3148 sec_in_hour=3600, &
3149 sec_in_min=60, &
3150 min_in_day=1440, &
3151 min_in_hour=60, &
3152 hour_in_day=24
3153
3154INTEGER,PARAMETER :: &
3155 year0=1, & ! anno di origine per iminuti
3156 d1=365, & ! giorni/1 anno nel calendario gregoriano
3157 d4=d1*4+1, & ! giorni/4 anni nel calendario gregoriano
3158 d100=d1*100+25-1, & ! giorni/100 anni nel calendario gregoriano
3159 d400=d1*400+100-3, & ! giorni/400 anni nel calendario gregoriano
3160 ianno(13,2)=reshape((/ &
3161 0,31,59,90,120,151,181,212,243,273,304,334,365, &
3162 0,31,60,91,121,152,182,213,244,274,305,335,366/),(/13,2/))
3163
3164INTEGER(KIND=int_ll),PARAMETER :: &
3165 unsec=62135596800_int_ll ! differenza tra 01/01/1970 e 01/01/0001 (sec, per unixtime)
3166
3171 MODULE PROCEDURE datetime_init, timedelta_init
3172END INTERFACE
3173
3177 MODULE PROCEDURE datetime_delete, timedelta_delete
3178END INTERFACE
3179
3182 MODULE PROCEDURE datetime_getval, timedelta_getval
3183END INTERFACE
3184
3187 MODULE PROCEDURE datetime_to_char, timedelta_to_char, cyclicdatetime_to_char
3188END INTERFACE
3189
3190
3209 MODULE PROCEDURE trim_datetime_to_char, trim_timedelta_to_char, trim_cyclicdatetime_to_char
3210END INTERFACE
3211
3217INTERFACE OPERATOR (==)
3218 MODULE PROCEDURE datetime_eq, timedelta_eq, &
3219 cyclicdatetime_eq, cyclicdatetime_datetime_eq, datetime_cyclicdatetime_eq
3220END INTERFACE
3221
3227INTERFACE OPERATOR (/=)
3228 MODULE PROCEDURE datetime_ne, timedelta_ne
3229END INTERFACE
3230
3238INTERFACE OPERATOR (>)
3239 MODULE PROCEDURE datetime_gt, timedelta_gt
3240END INTERFACE
3241
3249INTERFACE OPERATOR (<)
3250 MODULE PROCEDURE datetime_lt, timedelta_lt
3251END INTERFACE
3252
3260INTERFACE OPERATOR (>=)
3261 MODULE PROCEDURE datetime_ge, timedelta_ge
3262END INTERFACE
3263
3271INTERFACE OPERATOR (<=)
3272 MODULE PROCEDURE datetime_le, timedelta_le
3273END INTERFACE
3274
3281INTERFACE OPERATOR (+)
3282 MODULE PROCEDURE datetime_add, timedelta_add
3283END INTERFACE
3284
3292INTERFACE OPERATOR (-)
3293 MODULE PROCEDURE datetime_subdt, datetime_subtd, timedelta_sub
3294END INTERFACE
3295
3301INTERFACE OPERATOR (*)
3302 MODULE PROCEDURE timedelta_mult, timedelta_tlum
3303END INTERFACE
3304
3311INTERFACE OPERATOR (/)
3312 MODULE PROCEDURE timedelta_divint, timedelta_divtd
3313END INTERFACE
3314
3326 MODULE PROCEDURE timedelta_mod, datetime_timedelta_mod
3327END INTERFACE
3328
3332 MODULE PROCEDURE timedelta_abs
3333END INTERFACE
3334
3338 MODULE PROCEDURE datetime_read_unit, datetime_vect_read_unit, &
3339 timedelta_read_unit, timedelta_vect_read_unit
3340END INTERFACE
3341
3345 MODULE PROCEDURE datetime_write_unit, datetime_vect_write_unit, &
3346 timedelta_write_unit, timedelta_vect_write_unit
3347END INTERFACE
3348
3351 MODULE PROCEDURE display_datetime, display_timedelta, display_cyclicdatetime
3352END INTERFACE
3353
3356 MODULE PROCEDURE c_e_datetime, c_e_timedelta, c_e_cyclicdatetime
3357END INTERFACE
3358
3359#undef VOL7D_POLY_TYPE
3360#undef VOL7D_POLY_TYPES
3361#undef ENABLE_SORT
3362#define VOL7D_POLY_TYPE TYPE(datetime)
3363#define VOL7D_POLY_TYPES _datetime
3364#define ENABLE_SORT
3365#include "array_utilities_pre.F90"
3366
3367
3368#define ARRAYOF_ORIGTYPE TYPE(datetime)
3369#define ARRAYOF_TYPE arrayof_datetime
3370#define ARRAYOF_ORIGEQ 1
3371#include "arrayof_pre.F90"
3372! from arrayof
3373
3374PRIVATE
3375
3377 datetime_min, datetime_max, &
3380 OPERATOR(==), OPERATOR(/=), OPERATOR(>), OPERATOR(<), &
3381 OPERATOR(>=), OPERATOR(<=), OPERATOR(+), OPERATOR(-), &
3383 timedelta, timedelta_miss, timedelta_new, timedelta_0, &
3384 timedelta_min, timedelta_max, timedelta_getamsec, timedelta_depop, &
3386 count_distinct, pack_distinct, &
3387 count_distinct_sorted, pack_distinct_sorted, &
3388 count_and_pack_distinct, &
3390 cyclicdatetime, cyclicdatetime_new, cyclicdatetime_miss, display_cyclicdatetime
3392PUBLIC insert_unique, append_unique
3393PUBLIC cyclicdatetime_to_conventional
3394
3395CONTAINS
3396
3397
3398! ==============
3399! == datetime ==
3400! ==============
3401
3408ELEMENTAL FUNCTION datetime_new(year, month, day, hour, minute, msec, &
3409 unixtime, isodate, simpledate) RESULT(this)
3410INTEGER,INTENT(IN),OPTIONAL :: year
3411INTEGER,INTENT(IN),OPTIONAL :: month
3412INTEGER,INTENT(IN),OPTIONAL :: day
3413INTEGER,INTENT(IN),OPTIONAL :: hour
3414INTEGER,INTENT(IN),OPTIONAL :: minute
3415INTEGER,INTENT(IN),OPTIONAL :: msec
3416INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3417CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3418CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3419
3420TYPE(datetime) :: this
3421INTEGER :: lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3422CHARACTER(len=23) :: datebuf
3423
3424IF (PRESENT(year)) THEN ! anno/mese/giorno, ecc.
3425 lyear = year
3426 IF (PRESENT(month)) THEN
3427 lmonth = month
3428 ELSE
3429 lmonth = 1
3430 ENDIF
3431 IF (PRESENT(day)) THEN
3432 lday = day
3433 ELSE
3434 lday = 1
3435 ENDIF
3436 IF (PRESENT(hour)) THEN
3437 lhour = hour
3438 ELSE
3439 lhour = 0
3440 ENDIF
3441 IF (PRESENT(minute)) THEN
3442 lminute = minute
3443 ELSE
3444 lminute = 0
3445 ENDIF
3446 IF (PRESENT(msec)) THEN
3447 lmsec = msec
3448 ELSE
3449 lmsec = 0
3450 ENDIF
3451
3454 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3455 else
3456 this=datetime_miss
3457 end if
3458
3459ELSE IF (PRESENT(unixtime)) THEN ! secondi dal 01/01/1970 (unix)
3461 this%iminuti = (unixtime + unsec)*1000
3462 else
3463 this=datetime_miss
3464 end if
3465
3466ELSE IF (PRESENT(isodate)) THEN ! formato iso YYYY-MM-DD hh:mm:ss.msc
3467
3469 datebuf(1:23) = '0001-01-01 00:00:00.000'
3470 datebuf(1:min(len_trim(isodate),23)) = isodate(1:min(len_trim(isodate),23))
3471 READ(datebuf,'(I4,1X,I2,1X,I2,1X,I2,1X,I2,1X,I2,1X,I3)', err=100) &
3472 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3473 lmsec = lmsec + lsec*1000
3474 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3475 RETURN
3476
3477100 CONTINUE ! condizione di errore in isodate
3479 RETURN
3480 ELSE
3481 this = datetime_miss
3482 ENDIF
3483
3484ELSE IF (PRESENT(simpledate)) THEN ! formato YYYYMMDDhhmmssmsc
3486 datebuf(1:17) = '00010101000000000'
3487 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
3488 READ(datebuf,'(I4.4,5I2.2,I3.3)', err=120) &
3489 lyear, lmonth, lday, lhour, lminute, lsec, lmsec
3490 lmsec = lmsec + lsec*1000
3491 CALL jeladata5_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3492 RETURN
3493
3494120 CONTINUE ! condizione di errore in simpledate
3496 RETURN
3497 ELSE
3498 this = datetime_miss
3499 ENDIF
3500
3501ELSE
3502 this = datetime_miss
3503ENDIF
3504
3505END FUNCTION datetime_new
3506
3507
3509FUNCTION datetime_new_now(now) RESULT(this)
3510INTEGER,INTENT(IN) :: now
3511TYPE(datetime) :: this
3512
3513INTEGER :: dt(8)
3514
3516 CALL date_and_time(values=dt)
3517 IF (now /= datetime_local) dt(6) = dt(6) - dt(4) ! back to UTC
3519 msec=dt(7)*1000+dt(8))
3520ELSE
3521 this = datetime_miss
3522ENDIF
3523
3524END FUNCTION datetime_new_now
3525
3526
3533SUBROUTINE datetime_init(this, year, month, day, hour, minute, msec, &
3534 unixtime, isodate, simpledate, now)
3535TYPE(datetime),INTENT(INOUT) :: this
3536INTEGER,INTENT(IN),OPTIONAL :: year
3537INTEGER,INTENT(IN),OPTIONAL :: month
3538INTEGER,INTENT(IN),OPTIONAL :: day
3539INTEGER,INTENT(IN),OPTIONAL :: hour
3540INTEGER,INTENT(IN),OPTIONAL :: minute
3541INTEGER,INTENT(IN),OPTIONAL :: msec
3542INTEGER(kind=int_ll),INTENT(IN),OPTIONAL :: unixtime
3543CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3544CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3545INTEGER,INTENT(IN),OPTIONAL :: now
3546
3547IF (PRESENT(now)) THEN
3548 this = datetime_new_now(now)
3549ELSE
3550 this = datetime_new(year, month, day, hour, minute, msec, &
3551 unixtime, isodate, simpledate)
3552ENDIF
3553
3554END SUBROUTINE datetime_init
3555
3556
3557ELEMENTAL SUBROUTINE datetime_delete(this)
3558TYPE(datetime),INTENT(INOUT) :: this
3559
3560this%iminuti = illmiss
3561
3562END SUBROUTINE datetime_delete
3563
3564
3569PURE SUBROUTINE datetime_getval(this, year, month, day, hour, minute, msec, &
3570 unixtime, isodate, simpledate, oraclesimdate)
3571TYPE(datetime),INTENT(IN) :: this
3572INTEGER,INTENT(OUT),OPTIONAL :: year
3573INTEGER,INTENT(OUT),OPTIONAL :: month
3574INTEGER,INTENT(OUT),OPTIONAL :: day
3575INTEGER,INTENT(OUT),OPTIONAL :: hour
3576INTEGER,INTENT(OUT),OPTIONAL :: minute
3577INTEGER,INTENT(OUT),OPTIONAL :: msec
3578INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: unixtime
3579CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
3580CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
3581CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
3582
3583INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3584CHARACTER(len=23) :: datebuf
3585
3586IF (PRESENT(year) .OR. PRESENT(month) .OR. PRESENT(day) .OR. PRESENT(hour) &
3587 .OR. PRESENT(minute) .OR. PRESENT(msec) .OR. PRESENT(isodate) &
3588 .OR. PRESENT(simpledate) .OR. PRESENT(oraclesimdate) .OR. PRESENT(unixtime)) THEN
3589
3590 IF (this == datetime_miss) THEN
3591
3592 IF (PRESENT(msec)) THEN
3593 msec = imiss
3594 ENDIF
3595 IF (PRESENT(minute)) THEN
3596 minute = imiss
3597 ENDIF
3598 IF (PRESENT(hour)) THEN
3599 hour = imiss
3600 ENDIF
3601 IF (PRESENT(day)) THEN
3602 day = imiss
3603 ENDIF
3604 IF (PRESENT(month)) THEN
3605 month = imiss
3606 ENDIF
3607 IF (PRESENT(year)) THEN
3608 year = imiss
3609 ENDIF
3610 IF (PRESENT(isodate)) THEN
3611 isodate = cmiss
3612 ENDIF
3613 IF (PRESENT(simpledate)) THEN
3614 simpledate = cmiss
3615 ENDIF
3616 IF (PRESENT(oraclesimdate)) THEN
3617!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3618!!$ 'obsoleto, usare piuttosto simpledate')
3619 oraclesimdate=cmiss
3620 ENDIF
3621 IF (PRESENT(unixtime)) THEN
3622 unixtime = illmiss
3623 ENDIF
3624
3625 ELSE
3626
3627 CALL jeladata6_1(lday, lmonth, lyear, lhour, lminute, lmsec, this%iminuti)
3628 IF (PRESENT(msec)) THEN
3629 msec = lmsec
3630 ENDIF
3631 IF (PRESENT(minute)) THEN
3632 minute = lminute
3633 ENDIF
3634 IF (PRESENT(hour)) THEN
3635 hour = lhour
3636 ENDIF
3637 IF (PRESENT(day)) THEN
3638 day = lday
3639 ENDIF
3640 IF (PRESENT(month)) THEN
3641 month = lmonth
3642 ENDIF
3643 IF (PRESENT(year)) THEN
3644 year = lyear
3645 ENDIF
3646 IF (PRESENT(isodate)) THEN
3647 WRITE(datebuf(1:23), '(I4.4,A1,I2.2,A1,I2.2,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
3648 lyear, '-', lmonth, '-', lday, lhour, ':', lminute, ':', lmsec/1000, &
3650 isodate = datebuf(1:min(len(isodate),23))
3651 ENDIF
3652 IF (PRESENT(simpledate)) THEN
3653 WRITE(datebuf(1:17), '(I4.4,5I2.2,I3.3)') &
3654 lyear, lmonth, lday, lhour, lminute, lmsec/1000, mod(lmsec, 1000)
3655 simpledate = datebuf(1:min(len(simpledate),17))
3656 ENDIF
3657 IF (PRESENT(oraclesimdate)) THEN
3658!!$ CALL l4f_log(L4F_WARN, 'in datetime_getval, parametro oraclesimdate '// &
3659!!$ 'obsoleto, usare piuttosto simpledate')
3660 WRITE(oraclesimdate, '(I4.4,4I2.2)') lyear, lmonth, lday, lhour, lminute
3661 ENDIF
3662 IF (PRESENT(unixtime)) THEN
3663 unixtime = this%iminuti/1000_int_ll-unsec
3664 ENDIF
3665
3666 ENDIF
3667ENDIF
3668
3669END SUBROUTINE datetime_getval
3670
3671
3674elemental FUNCTION datetime_to_char(this) RESULT(char)
3675TYPE(datetime),INTENT(IN) :: this
3676
3677CHARACTER(len=23) :: char
3678
3680
3681END FUNCTION datetime_to_char
3682
3683
3684FUNCTION trim_datetime_to_char(in) RESULT(char)
3685TYPE(datetime),INTENT(IN) :: in ! value to be represented as CHARACTER
3686
3687CHARACTER(len=len_trim(datetime_to_char(in))) :: char
3688
3689char=datetime_to_char(in)
3690
3691END FUNCTION trim_datetime_to_char
3692
3693
3694
3695SUBROUTINE display_datetime(this)
3696TYPE(datetime),INTENT(in) :: this
3697
3699
3700end subroutine display_datetime
3701
3702
3703
3704SUBROUTINE display_timedelta(this)
3705TYPE(timedelta),INTENT(in) :: this
3706
3708
3709end subroutine display_timedelta
3710
3711
3712
3713ELEMENTAL FUNCTION c_e_datetime(this) result (res)
3714TYPE(datetime),INTENT(in) :: this
3715LOGICAL :: res
3716
3717res = .not. this == datetime_miss
3718
3719end FUNCTION c_e_datetime
3720
3721
3722ELEMENTAL FUNCTION datetime_eq(this, that) RESULT(res)
3723TYPE(datetime),INTENT(IN) :: this, that
3724LOGICAL :: res
3725
3726res = this%iminuti == that%iminuti
3727
3728END FUNCTION datetime_eq
3729
3730
3731ELEMENTAL FUNCTION datetime_ne(this, that) RESULT(res)
3732TYPE(datetime),INTENT(IN) :: this, that
3733LOGICAL :: res
3734
3735res = .NOT.(this == that)
3736
3737END FUNCTION datetime_ne
3738
3739
3740ELEMENTAL FUNCTION datetime_gt(this, that) RESULT(res)
3741TYPE(datetime),INTENT(IN) :: this, that
3742LOGICAL :: res
3743
3744res = this%iminuti > that%iminuti
3745
3746END FUNCTION datetime_gt
3747
3748
3749ELEMENTAL FUNCTION datetime_lt(this, that) RESULT(res)
3750TYPE(datetime),INTENT(IN) :: this, that
3751LOGICAL :: res
3752
3753res = this%iminuti < that%iminuti
3754
3755END FUNCTION datetime_lt
3756
3757
3758ELEMENTAL FUNCTION datetime_ge(this, that) RESULT(res)
3759TYPE(datetime),INTENT(IN) :: this, that
3760LOGICAL :: res
3761
3762IF (this == that) THEN
3763 res = .true.
3764ELSE IF (this > that) THEN
3765 res = .true.
3766ELSE
3767 res = .false.
3768ENDIF
3769
3770END FUNCTION datetime_ge
3771
3772
3773ELEMENTAL FUNCTION datetime_le(this, that) RESULT(res)
3774TYPE(datetime),INTENT(IN) :: this, that
3775LOGICAL :: res
3776
3777IF (this == that) THEN
3778 res = .true.
3779ELSE IF (this < that) THEN
3780 res = .true.
3781ELSE
3782 res = .false.
3783ENDIF
3784
3785END FUNCTION datetime_le
3786
3787
3788FUNCTION datetime_add(this, that) RESULT(res)
3789TYPE(datetime),INTENT(IN) :: this
3790TYPE(timedelta),INTENT(IN) :: that
3791TYPE(datetime) :: res
3792
3793INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3794
3795IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3796 res = datetime_miss
3797ELSE
3798 res%iminuti = this%iminuti + that%iminuti
3799 IF (that%month /= 0) THEN
3801 minute=lminute, msec=lmsec)
3803 hour=lhour, minute=lminute, msec=lmsec)
3804 ENDIF
3805ENDIF
3806
3807END FUNCTION datetime_add
3808
3809
3810ELEMENTAL FUNCTION datetime_subdt(this, that) RESULT(res)
3811TYPE(datetime),INTENT(IN) :: this, that
3812TYPE(timedelta) :: res
3813
3814IF (this == datetime_miss .OR. that == datetime_miss) THEN
3815 res = timedelta_miss
3816ELSE
3817 res%iminuti = this%iminuti - that%iminuti
3818 res%month = 0
3819ENDIF
3820
3821END FUNCTION datetime_subdt
3822
3823
3824FUNCTION datetime_subtd(this, that) RESULT(res)
3825TYPE(datetime),INTENT(IN) :: this
3826TYPE(timedelta),INTENT(IN) :: that
3827TYPE(datetime) :: res
3828
3829INTEGER :: lyear, lmonth, lday, lhour, lminute, lmsec
3830
3831IF (this == datetime_miss .OR. that == timedelta_miss) THEN
3832 res = datetime_miss
3833ELSE
3834 res%iminuti = this%iminuti - that%iminuti
3835 IF (that%month /= 0) THEN
3837 minute=lminute, msec=lmsec)
3839 hour=lhour, minute=lminute, msec=lmsec)
3840 ENDIF
3841ENDIF
3842
3843END FUNCTION datetime_subtd
3844
3845
3850SUBROUTINE datetime_read_unit(this, unit)
3851TYPE(datetime),INTENT(out) :: this
3852INTEGER, INTENT(in) :: unit
3853CALL datetime_vect_read_unit((/this/), unit)
3854
3855END SUBROUTINE datetime_read_unit
3856
3857
3862SUBROUTINE datetime_vect_read_unit(this, unit)
3863TYPE(datetime) :: this(:)
3864INTEGER, INTENT(in) :: unit
3865
3866CHARACTER(len=40) :: form
3867CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3868INTEGER :: i
3869
3870ALLOCATE(dateiso(SIZE(this)))
3871INQUIRE(unit, form=form)
3872IF (form == 'FORMATTED') THEN
3873 READ(unit,'(A23,1X)')dateiso
3874ELSE
3875 READ(unit)dateiso
3876ENDIF
3877DO i = 1, SIZE(dateiso)
3879ENDDO
3880DEALLOCATE(dateiso)
3881
3882END SUBROUTINE datetime_vect_read_unit
3883
3884
3889SUBROUTINE datetime_write_unit(this, unit)
3890TYPE(datetime),INTENT(in) :: this
3891INTEGER, INTENT(in) :: unit
3892
3893CALL datetime_vect_write_unit((/this/), unit)
3894
3895END SUBROUTINE datetime_write_unit
3896
3897
3902SUBROUTINE datetime_vect_write_unit(this, unit)
3903TYPE(datetime),INTENT(in) :: this(:)
3904INTEGER, INTENT(in) :: unit
3905
3906CHARACTER(len=40) :: form
3907CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
3908INTEGER :: i
3909
3910ALLOCATE(dateiso(SIZE(this)))
3911DO i = 1, SIZE(dateiso)
3913ENDDO
3914INQUIRE(unit, form=form)
3915IF (form == 'FORMATTED') THEN
3916 WRITE(unit,'(A23,1X)')dateiso
3917ELSE
3918 WRITE(unit)dateiso
3919ENDIF
3920DEALLOCATE(dateiso)
3921
3922END SUBROUTINE datetime_vect_write_unit
3923
3924
3925#include "arrayof_post.F90"
3926
3927
3928! ===============
3929! == timedelta ==
3930! ===============
3937FUNCTION timedelta_new(year, month, day, hour, minute, sec, msec, &
3938 isodate, simpledate, oraclesimdate) RESULT (this)
3939INTEGER,INTENT(IN),OPTIONAL :: year
3940INTEGER,INTENT(IN),OPTIONAL :: month
3941INTEGER,INTENT(IN),OPTIONAL :: day
3942INTEGER,INTENT(IN),OPTIONAL :: hour
3943INTEGER,INTENT(IN),OPTIONAL :: minute
3944INTEGER,INTENT(IN),OPTIONAL :: sec
3945INTEGER,INTENT(IN),OPTIONAL :: msec
3946CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3947CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3948CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3949
3950TYPE(timedelta) :: this
3951
3952CALL timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3953 isodate, simpledate, oraclesimdate)
3954
3955END FUNCTION timedelta_new
3956
3957
3962SUBROUTINE timedelta_init(this, year, month, day, hour, minute, sec, msec, &
3963 isodate, simpledate, oraclesimdate)
3964TYPE(timedelta),INTENT(INOUT) :: this
3965INTEGER,INTENT(IN),OPTIONAL :: year
3966INTEGER,INTENT(IN),OPTIONAL :: month
3967INTEGER,INTENT(IN),OPTIONAL :: day
3968INTEGER,INTENT(IN),OPTIONAL :: hour
3969INTEGER,INTENT(IN),OPTIONAL :: minute
3970INTEGER,INTENT(IN),OPTIONAL :: sec
3971INTEGER,INTENT(IN),OPTIONAL :: msec
3972CHARACTER(len=*),INTENT(IN),OPTIONAL :: isodate
3973CHARACTER(len=*),INTENT(IN),OPTIONAL :: simpledate
3974CHARACTER(len=12),INTENT(IN),OPTIONAL :: oraclesimdate
3975
3976INTEGER :: n, l, lyear, lmonth, d, h, m, s, ms
3977CHARACTER(len=23) :: datebuf
3978
3979this%month = 0
3980
3981IF (PRESENT(isodate)) THEN
3982 datebuf(1:23) = '0000000000 00:00:00.000'
3983 l = len_trim(isodate)
3984! IF (l > 0) THEN
3986 IF (n > 0) THEN
3987 IF (n > 11 .OR. n < l - 12) GOTO 200 ! wrong format
3988 datebuf(12-n:12-n+l-1) = isodate(:l)
3989 ELSE
3990 datebuf(1:l) = isodate(1:l)
3991 ENDIF
3992! ENDIF
3993
3994! datebuf(1:MIN(LEN(isodate),23)) = isodate(1:MIN(LEN(isodate),23))
3995 READ(datebuf,'(I4,I2,I4,1X,I2,1X,I2,1X,I2,1X,I3)', err=200) lyear, lmonth, d, &
3996 h, m, s, ms
3997 this%month = lmonth + 12*lyear
3998 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
3999 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4000 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4001 RETURN
4002
4003200 CONTINUE ! condizione di errore in isodate
4005 CALL l4f_log(l4f_error, 'isodate '//trim(isodate)//' not valid')
4006 CALL raise_error()
4007
4008ELSE IF (PRESENT(simpledate)) THEN
4009 datebuf(1:17) = '00000000000000000'
4010 datebuf(1:min(len(simpledate),17)) = simpledate(1:min(len(simpledate),17))
4011 READ(datebuf,'(I8.8,3I2.2,I3.3)', err=220) d, h, m, s, ms
4012 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4013 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll) + &
4014 1000_int_ll*int(s, kind=int_ll) + int(ms, kind=int_ll)
4015
4016220 CONTINUE ! condizione di errore in simpledate
4018 CALL l4f_log(l4f_error, 'simpledate '//trim(simpledate)//' not valid')
4019 CALL raise_error()
4020 RETURN
4021
4022ELSE IF (PRESENT(oraclesimdate)) THEN
4023 CALL l4f_log(l4f_warn, 'in timedelta_init, parametro oraclesimdate '// &
4024 'obsoleto, usare piuttosto simpledate')
4025 READ(oraclesimdate, '(I8,2I2)')d, h, m
4026 this%iminuti = 86400000_int_ll*int(d, kind=int_ll) + &
4027 3600000_int_ll*int(h, kind=int_ll) + 60000_int_ll*int(m, kind=int_ll)
4028
4029ELSE IF (.not. present(year) .and. .not. present(month) .and. .not. present(day)&
4030 .and. .not. present(hour) .and. .not. present(minute) .and. .not. present(sec)&
4031 .and. .not. present(msec) .and. .not. present(isodate) &
4032 .and. .not. present(simpledate) .and. .not. present(oraclesimdate)) THEN
4033
4034 this=timedelta_miss
4035
4036ELSE
4037 this%iminuti = 0
4038 IF (PRESENT(year)) THEN
4040 this%month = this%month + year*12
4041 else
4042 this=timedelta_miss
4043 return
4044 end if
4045 ENDIF
4046 IF (PRESENT(month)) THEN
4048 this%month = this%month + month
4049 else
4050 this=timedelta_miss
4051 return
4052 end if
4053 ENDIF
4054 IF (PRESENT(day)) THEN
4056 this%iminuti = this%iminuti + 86400000_int_ll*int(day, kind=int_ll)
4057 else
4058 this=timedelta_miss
4059 return
4060 end if
4061 ENDIF
4062 IF (PRESENT(hour)) THEN
4064 this%iminuti = this%iminuti + 3600000_int_ll*int(hour, kind=int_ll)
4065 else
4066 this=timedelta_miss
4067 return
4068 end if
4069 ENDIF
4070 IF (PRESENT(minute)) THEN
4072 this%iminuti = this%iminuti + 60000_int_ll*int(minute, kind=int_ll)
4073 else
4074 this=timedelta_miss
4075 return
4076 end if
4077 ENDIF
4078 IF (PRESENT(sec)) THEN
4080 this%iminuti = this%iminuti + 1000_int_ll*int(sec, kind=int_ll)
4081 else
4082 this=timedelta_miss
4083 return
4084 end if
4085 ENDIF
4086 IF (PRESENT(msec)) THEN
4088 this%iminuti = this%iminuti + msec
4089 else
4090 this=timedelta_miss
4091 return
4092 end if
4093 ENDIF
4094ENDIF
4095
4096
4097
4098
4099END SUBROUTINE timedelta_init
4100
4101
4102SUBROUTINE timedelta_delete(this)
4103TYPE(timedelta),INTENT(INOUT) :: this
4104
4105this%iminuti = imiss
4106this%month = 0
4107
4108END SUBROUTINE timedelta_delete
4109
4110
4115PURE SUBROUTINE timedelta_getval(this, year, month, amonth, &
4116 day, hour, minute, sec, msec, &
4117 ahour, aminute, asec, amsec, isodate, simpledate, oraclesimdate)
4118TYPE(timedelta),INTENT(IN) :: this
4119INTEGER,INTENT(OUT),OPTIONAL :: year
4120INTEGER,INTENT(OUT),OPTIONAL :: month
4121INTEGER,INTENT(OUT),OPTIONAL :: amonth
4122INTEGER,INTENT(OUT),OPTIONAL :: day
4123INTEGER,INTENT(OUT),OPTIONAL :: hour
4124INTEGER,INTENT(OUT),OPTIONAL :: minute
4125INTEGER,INTENT(OUT),OPTIONAL :: sec
4126INTEGER,INTENT(OUT),OPTIONAL :: msec
4127INTEGER,INTENT(OUT),OPTIONAL :: ahour
4128INTEGER,INTENT(OUT),OPTIONAL :: aminute
4129INTEGER,INTENT(OUT),OPTIONAL :: asec
4130INTEGER(kind=int_ll),INTENT(OUT),OPTIONAL :: amsec
4131CHARACTER(len=*),INTENT(OUT),OPTIONAL :: isodate
4132CHARACTER(len=*),INTENT(OUT),OPTIONAL :: simpledate
4133CHARACTER(len=12),INTENT(OUT),OPTIONAL :: oraclesimdate
4134
4135CHARACTER(len=23) :: datebuf
4136
4137IF (PRESENT(amsec)) THEN
4138 amsec = this%iminuti
4139ENDIF
4140IF (PRESENT(asec)) THEN
4141 asec = int(this%iminuti/1000_int_ll)
4142ENDIF
4143IF (PRESENT(aminute)) THEN
4144 aminute = int(this%iminuti/60000_int_ll)
4145ENDIF
4146IF (PRESENT(ahour)) THEN
4147 ahour = int(this%iminuti/3600000_int_ll)
4148ENDIF
4149IF (PRESENT(msec)) THEN
4150 msec = int(mod(this%iminuti, 1000_int_ll))
4151ENDIF
4152IF (PRESENT(sec)) THEN
4153 sec = int(mod(this%iminuti/1000_int_ll, 60_int_ll))
4154ENDIF
4155IF (PRESENT(minute)) THEN
4156 minute = int(mod(this%iminuti/60000_int_ll, 60_int_ll))
4157ENDIF
4158IF (PRESENT(hour)) THEN
4159 hour = int(mod(this%iminuti/3600000_int_ll, 24_int_ll))
4160ENDIF
4161IF (PRESENT(day)) THEN
4162 day = int(this%iminuti/86400000_int_ll)
4163ENDIF
4164IF (PRESENT(amonth)) THEN
4165 amonth = this%month
4166ENDIF
4167IF (PRESENT(month)) THEN
4168 month = mod(this%month-1,12)+1
4169ENDIF
4170IF (PRESENT(year)) THEN
4171 year = this%month/12
4172ENDIF
4173IF (PRESENT(isodate)) THEN ! Non standard, inventato!
4174 WRITE(datebuf(1:23), '(I10.10,1X,I2.2,A1,I2.2,A1,I2.2,A1,I3.3)') &
4178 isodate = datebuf(1:min(len(isodate),23))
4179
4180ENDIF
4181IF (PRESENT(simpledate)) THEN
4182 WRITE(datebuf(1:17), '(I8.8,3I2.2,I3.3)') &
4183 this%iminuti/86400000_int_ll, mod(this%iminuti/3600000_int_ll, 24_int_ll), &
4185 mod(this%iminuti, 1000_int_ll)
4186 simpledate = datebuf(1:min(len(simpledate),17))
4187ENDIF
4188IF (PRESENT(oraclesimdate)) THEN
4189!!$ CALL l4f_log(L4F_WARN, 'in timedelta_getval, parametro oraclesimdate '// &
4190!!$ 'obsoleto, usare piuttosto simpledate')
4191 WRITE(oraclesimdate, '(I8.8,2I2.2)') this%iminuti/86400000_int_ll, &
4193ENDIF
4194
4195END SUBROUTINE timedelta_getval
4196
4197
4200elemental FUNCTION timedelta_to_char(this) RESULT(char)
4201TYPE(timedelta),INTENT(IN) :: this
4202
4203CHARACTER(len=23) :: char
4204
4206
4207END FUNCTION timedelta_to_char
4208
4209
4210FUNCTION trim_timedelta_to_char(in) RESULT(char)
4211TYPE(timedelta),INTENT(IN) :: in ! value to be represented as CHARACTER
4212
4213CHARACTER(len=len_trim(timedelta_to_char(in))) :: char
4214
4215char=timedelta_to_char(in)
4216
4217END FUNCTION trim_timedelta_to_char
4218
4219
4221elemental FUNCTION timedelta_getamsec(this)
4222TYPE(timedelta),INTENT(IN) :: this
4223INTEGER(kind=int_ll) :: timedelta_getamsec
4224
4225timedelta_getamsec = this%iminuti
4226
4227END FUNCTION timedelta_getamsec
4228
4229
4235FUNCTION timedelta_depop(this)
4236TYPE(timedelta),INTENT(IN) :: this
4237TYPE(timedelta) :: timedelta_depop
4238
4239TYPE(datetime) :: tmpdt
4240
4241IF (this%month == 0) THEN
4242 timedelta_depop = this
4243ELSE
4244 tmpdt = datetime_new(1970, 1, 1)
4245 timedelta_depop = (tmpdt + this) - tmpdt
4246ENDIF
4247
4248END FUNCTION timedelta_depop
4249
4250
4251elemental FUNCTION timedelta_eq(this, that) RESULT(res)
4252TYPE(timedelta),INTENT(IN) :: this, that
4253LOGICAL :: res
4254
4255res = (this%iminuti == that%iminuti .AND. this%month == that%month)
4256
4257END FUNCTION timedelta_eq
4258
4259
4260ELEMENTAL FUNCTION timedelta_ne(this, that) RESULT(res)
4261TYPE(timedelta),INTENT(IN) :: this, that
4262LOGICAL :: res
4263
4264res = .NOT.(this == that)
4265
4266END FUNCTION timedelta_ne
4267
4268
4269ELEMENTAL FUNCTION timedelta_gt(this, that) RESULT(res)
4270TYPE(timedelta),INTENT(IN) :: this, that
4271LOGICAL :: res
4272
4273res = this%iminuti > that%iminuti
4274
4275END FUNCTION timedelta_gt
4276
4277
4278ELEMENTAL FUNCTION timedelta_lt(this, that) RESULT(res)
4279TYPE(timedelta),INTENT(IN) :: this, that
4280LOGICAL :: res
4281
4282res = this%iminuti < that%iminuti
4283
4284END FUNCTION timedelta_lt
4285
4286
4287ELEMENTAL FUNCTION timedelta_ge(this, that) RESULT(res)
4288TYPE(timedelta),INTENT(IN) :: this, that
4289LOGICAL :: res
4290
4291IF (this == that) THEN
4292 res = .true.
4293ELSE IF (this > that) THEN
4294 res = .true.
4295ELSE
4296 res = .false.
4297ENDIF
4298
4299END FUNCTION timedelta_ge
4300
4301
4302elemental FUNCTION timedelta_le(this, that) RESULT(res)
4303TYPE(timedelta),INTENT(IN) :: this, that
4304LOGICAL :: res
4305
4306IF (this == that) THEN
4307 res = .true.
4308ELSE IF (this < that) THEN
4309 res = .true.
4310ELSE
4311 res = .false.
4312ENDIF
4313
4314END FUNCTION timedelta_le
4315
4316
4317ELEMENTAL FUNCTION timedelta_add(this, that) RESULT(res)
4318TYPE(timedelta),INTENT(IN) :: this, that
4319TYPE(timedelta) :: res
4320
4321res%iminuti = this%iminuti + that%iminuti
4322res%month = this%month + that%month
4323
4324END FUNCTION timedelta_add
4325
4326
4327ELEMENTAL FUNCTION timedelta_sub(this, that) RESULT(res)
4328TYPE(timedelta),INTENT(IN) :: this, that
4329TYPE(timedelta) :: res
4330
4331res%iminuti = this%iminuti - that%iminuti
4332res%month = this%month - that%month
4333
4334END FUNCTION timedelta_sub
4335
4336
4337ELEMENTAL FUNCTION timedelta_mult(this, n) RESULT(res)
4338TYPE(timedelta),INTENT(IN) :: this
4339INTEGER,INTENT(IN) :: n
4340TYPE(timedelta) :: res
4341
4342res%iminuti = this%iminuti*n
4343res%month = this%month*n
4344
4345END FUNCTION timedelta_mult
4346
4347
4348ELEMENTAL FUNCTION timedelta_tlum(n, this) RESULT(res)
4349INTEGER,INTENT(IN) :: n
4350TYPE(timedelta),INTENT(IN) :: this
4351TYPE(timedelta) :: res
4352
4353res%iminuti = this%iminuti*n
4354res%month = this%month*n
4355
4356END FUNCTION timedelta_tlum
4357
4358
4359ELEMENTAL FUNCTION timedelta_divint(this, n) RESULT(res)
4360TYPE(timedelta),INTENT(IN) :: this
4361INTEGER,INTENT(IN) :: n
4362TYPE(timedelta) :: res
4363
4364res%iminuti = this%iminuti/n
4365res%month = this%month/n
4366
4367END FUNCTION timedelta_divint
4368
4369
4370ELEMENTAL FUNCTION timedelta_divtd(this, that) RESULT(res)
4371TYPE(timedelta),INTENT(IN) :: this, that
4372INTEGER :: res
4373
4374res = int(this%iminuti/that%iminuti)
4375
4376END FUNCTION timedelta_divtd
4377
4378
4379elemental FUNCTION timedelta_mod(this, that) RESULT(res)
4380TYPE(timedelta),INTENT(IN) :: this, that
4381TYPE(timedelta) :: res
4382
4383res%iminuti = mod(this%iminuti, that%iminuti)
4384res%month = 0
4385
4386END FUNCTION timedelta_mod
4387
4388
4389ELEMENTAL FUNCTION datetime_timedelta_mod(this, that) RESULT(res)
4390TYPE(datetime),INTENT(IN) :: this
4391TYPE(timedelta),INTENT(IN) :: that
4392TYPE(timedelta) :: res
4393
4394IF (that%iminuti == 0) THEN ! Controllo nel caso di intervalli "umani" o nulli
4395 res = timedelta_0
4396ELSE
4397 res%iminuti = mod(this%iminuti, that%iminuti)
4398 res%month = 0
4399ENDIF
4400
4401END FUNCTION datetime_timedelta_mod
4402
4403
4404ELEMENTAL FUNCTION timedelta_abs(this) RESULT(res)
4405TYPE(timedelta),INTENT(IN) :: this
4406TYPE(timedelta) :: res
4407
4408res%iminuti = abs(this%iminuti)
4409res%month = abs(this%month)
4410
4411END FUNCTION timedelta_abs
4412
4413
4418SUBROUTINE timedelta_read_unit(this, unit)
4419TYPE(timedelta),INTENT(out) :: this
4420INTEGER, INTENT(in) :: unit
4421
4422CALL timedelta_vect_read_unit((/this/), unit)
4423
4424END SUBROUTINE timedelta_read_unit
4425
4426
4431SUBROUTINE timedelta_vect_read_unit(this, unit)
4432TYPE(timedelta) :: this(:)
4433INTEGER, INTENT(in) :: unit
4434
4435CHARACTER(len=40) :: form
4436CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4437INTEGER :: i
4438
4439ALLOCATE(dateiso(SIZE(this)))
4440INQUIRE(unit, form=form)
4441IF (form == 'FORMATTED') THEN
4442 READ(unit,'(3(A23,1X))')dateiso
4443ELSE
4444 READ(unit)dateiso
4445ENDIF
4446DO i = 1, SIZE(dateiso)
4448ENDDO
4449DEALLOCATE(dateiso)
4450
4451END SUBROUTINE timedelta_vect_read_unit
4452
4453
4458SUBROUTINE timedelta_write_unit(this, unit)
4459TYPE(timedelta),INTENT(in) :: this
4460INTEGER, INTENT(in) :: unit
4461
4462CALL timedelta_vect_write_unit((/this/), unit)
4463
4464END SUBROUTINE timedelta_write_unit
4465
4466
4471SUBROUTINE timedelta_vect_write_unit(this, unit)
4472TYPE(timedelta),INTENT(in) :: this(:)
4473INTEGER, INTENT(in) :: unit
4474
4475CHARACTER(len=40) :: form
4476CHARACTER(len=23), ALLOCATABLE :: dateiso(:)
4477INTEGER :: i
4478
4479ALLOCATE(dateiso(SIZE(this)))
4480DO i = 1, SIZE(dateiso)
4482ENDDO
4483INQUIRE(unit, form=form)
4484IF (form == 'FORMATTED') THEN
4485 WRITE(unit,'(3(A23,1X))')dateiso
4486ELSE
4487 WRITE(unit)dateiso
4488ENDIF
4489DEALLOCATE(dateiso)
4490
4491END SUBROUTINE timedelta_vect_write_unit
4492
4493
4494ELEMENTAL FUNCTION c_e_timedelta(this) result (res)
4495TYPE(timedelta),INTENT(in) :: this
4496LOGICAL :: res
4497
4498res = .not. this == timedelta_miss
4499
4500end FUNCTION c_e_timedelta
4501
4502
4503elemental SUBROUTINE jeladata5(iday,imonth,iyear,ihour,imin,iminuti)
4504
4505!!omstart JELADATA5
4506! SUBROUTINE JELADATA5(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4507! 1 IMINUTI)
4508!
4509! Calcola i minuti trascorsi tra il 1/1/1 e la data fornita
4510!
4511! variabili integer*4
4512! IN:
4513! IDAY,IMONTH,IYEAR, I*4
4514! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4515!
4516! OUT:
4517! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4518!!OMEND
4519
4520INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin
4521INTEGER,intent(out) :: iminuti
4522
4523iminuti = ndays(iday,imonth,iyear)*1440+(ihour*60)+imin
4524
4525END SUBROUTINE jeladata5
4526
4527
4528elemental SUBROUTINE jeladata5_1(iday,imonth,iyear,ihour,imin,imsec,imillisec)
4529INTEGER,intent(in) :: iday, imonth, iyear, ihour, imin, imsec
4530INTEGER(KIND=int_ll),intent(out) :: imillisec
4531
4532imillisec = int(ndays(iday,imonth,iyear)*1440+(ihour*60)+imin, kind=int_ll)*60000 &
4533 + imsec
4534
4535END SUBROUTINE jeladata5_1
4536
4537
4538
4539elemental SUBROUTINE jeladata6(iday, imonth, iyear, ihour, imin, iminuti)
4540
4541!!omstart JELADATA6
4542! SUBROUTINE JELADATA6(IDAY,IMONTH,IYEAR,IHOUR,IMIN,
4543! 1 IMINUTI)
4544!
4545! Calcola la data e l'ora corrispondente a IMINUTI dopo il
4546! 1/1/1
4547!
4548! variabili integer*4
4549! IN:
4550! IMINUTI I*4 MINUTI AD INIZIARE DALLE ORE 00 DEL 1/1/1
4551!
4552! OUT:
4553! IDAY,IMONTH,IYEAR, I*4
4554! IHOUR,IMIN GIORNO MESE ANNO ORE MINUTI
4555!!OMEND
4556
4557
4558INTEGER,intent(in) :: iminuti
4559INTEGER,intent(out) :: iday, imonth, iyear, ihour, imin
4560
4561INTEGER ::igiorno
4562
4563imin = mod(iminuti,60)
4564ihour = mod(iminuti,1440)/60
4565igiorno = iminuti/1440
4567CALL ndyin(igiorno,iday,imonth,iyear)
4568
4569END SUBROUTINE jeladata6
4570
4571
4572elemental SUBROUTINE jeladata6_1(iday, imonth, iyear, ihour, imin, imsec, imillisec)
4573INTEGER(KIND=int_ll), INTENT(IN) :: imillisec
4574INTEGER, INTENT(OUT) :: iday, imonth, iyear, ihour, imin, imsec
4575
4576INTEGER :: igiorno
4577
4579!imin = MOD(imillisec/60000_int_ll, 60)
4580!ihour = MOD(imillisec/3600000_int_ll, 24)
4581imin = int(mod(imillisec, 3600000_int_ll)/60000_int_ll)
4582ihour = int(mod(imillisec, 86400000_int_ll)/3600000_int_ll)
4583igiorno = int(imillisec/86400000_int_ll)
4584!IF (MOD(imillisec,1440) < 0) igiorno = igiorno-1 !?!?!?
4585CALL ndyin(igiorno,iday,imonth,iyear)
4586
4587END SUBROUTINE jeladata6_1
4588
4589
4590elemental SUBROUTINE ndyin(ndays,igg,imm,iaa)
4591
4592!!OMSTART NDYIN
4593! SUBROUTINE NDYIN(NDAYS,IGG,IMM,IAA)
4594! restituisce la data fornendo in input il numero di
4595! giorni dal 1/1/1
4596!
4597!!omend
4598
4599INTEGER,intent(in) :: ndays
4600INTEGER,intent(out) :: igg, imm, iaa
4601integer :: n,lndays
4602
4603lndays=ndays
4604
4605n = lndays/d400
4606lndays = lndays - n*d400
4607iaa = year0 + n*400
4608n = min(lndays/d100, 3)
4609lndays = lndays - n*d100
4610iaa = iaa + n*100
4611n = lndays/d4
4612lndays = lndays - n*d4
4613iaa = iaa + n*4
4614n = min(lndays/d1, 3)
4615lndays = lndays - n*d1
4616iaa = iaa + n
4617n = bisextilis(iaa)
4618DO imm = 1, 12
4619 IF (lndays < ianno(imm+1,n)) EXIT
4620ENDDO
4621igg = lndays+1-ianno(imm,n) ! +1 perche' il mese parte da 1
4622
4623END SUBROUTINE ndyin
4624
4625
4626integer elemental FUNCTION ndays(igg,imm,iaa)
4627
4628!!OMSTART NDAYS
4629! FUNCTION NDAYS(IGG,IMM,IAA)
4630! restituisce il numero di giorni dal 1/1/1
4631! fornendo in input la data
4632!
4633!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4634! nota bene E' SICURO !!!
4635! un anno e' bisestile se divisibile per 4
4636! un anno rimane bisestile se divisibile per 400
4637! un anno NON e' bisestile se divisibile per 100
4638!
4639!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4640!
4641!!omend
4642
4643INTEGER, intent(in) :: igg, imm, iaa
4644
4645INTEGER :: lmonth, lyear
4646
4647! Limito il mese a [1-12] e correggo l'anno coerentemente
4648lmonth = modulo(imm-1, 12) + 1 ! uso MODULO e non MOD per gestire bene i valori <0
4649lyear = iaa + (imm - lmonth)/12
4650ndays = igg+ianno(lmonth, bisextilis(lyear))
4651ndays = ndays-1 + 365*(lyear-year0) + (lyear-year0)/4 - (lyear-year0)/100 + &
4652 (lyear-year0)/400
4653
4654END FUNCTION ndays
4655
4656
4657elemental FUNCTION bisextilis(annum)
4658INTEGER,INTENT(in) :: annum
4659INTEGER :: bisextilis
4660
4662 bisextilis = 2
4663ELSE
4664 bisextilis = 1
4665ENDIF
4666END FUNCTION bisextilis
4667
4668
4669ELEMENTAL FUNCTION cyclicdatetime_eq(this, that) RESULT(res)
4670TYPE(cyclicdatetime),INTENT(IN) :: this, that
4671LOGICAL :: res
4672
4673res = .true.
4674if (this%minute /= that%minute) res=.false.
4675if (this%hour /= that%hour) res=.false.
4676if (this%day /= that%day) res=.false.
4677if (this%month /= that%month) res=.false.
4678if (this%tendaysp /= that%tendaysp) res=.false.
4679
4680END FUNCTION cyclicdatetime_eq
4681
4682
4683ELEMENTAL FUNCTION cyclicdatetime_datetime_eq(this, that) RESULT(res)
4684TYPE(cyclicdatetime),INTENT(IN) :: this
4685TYPE(datetime),INTENT(IN) :: that
4686LOGICAL :: res
4687
4688integer :: minute,hour,day,month
4689
4691
4692res = .true.
4698 if ( this%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4699end if
4700
4701END FUNCTION cyclicdatetime_datetime_eq
4702
4703
4704ELEMENTAL FUNCTION datetime_cyclicdatetime_eq(this, that) RESULT(res)
4705TYPE(datetime),INTENT(IN) :: this
4706TYPE(cyclicdatetime),INTENT(IN) :: that
4707LOGICAL :: res
4708
4709integer :: minute,hour,day,month
4710
4712
4713res = .true.
4718
4720 if ( that%tendaysp /= min(((day-1)/10) +1,3)) res=.false.
4721end if
4722
4723
4724END FUNCTION datetime_cyclicdatetime_eq
4725
4726ELEMENTAL FUNCTION c_e_cyclicdatetime(this) result (res)
4727TYPE(cyclicdatetime),INTENT(in) :: this
4728LOGICAL :: res
4729
4730res = .not. this == cyclicdatetime_miss
4731
4732end FUNCTION c_e_cyclicdatetime
4733
4734
4737FUNCTION cyclicdatetime_new(tendaysp, month, day, hour, minute, chardate) RESULT(this)
4738INTEGER,INTENT(IN),OPTIONAL :: tendaysp
4739INTEGER,INTENT(IN),OPTIONAL :: month
4740INTEGER,INTENT(IN),OPTIONAL :: day
4741INTEGER,INTENT(IN),OPTIONAL :: hour
4742INTEGER,INTENT(IN),OPTIONAL :: minute
4743CHARACTER(len=9),INTENT(IN),OPTIONAL :: chardate
4744
4745integer :: ltendaysp,lmonth,lday,lhour,lminute,ios
4746
4747
4748TYPE(cyclicdatetime) :: this
4749
4750if (present(chardate)) then
4751
4752 ltendaysp=imiss
4753 lmonth=imiss
4754 lday=imiss
4755 lhour=imiss
4756 lminute=imiss
4757
4759 ! TMMGGhhmm
4760 read(chardate(1:1),'(i1)',iostat=ios)ltendaysp
4761 !print*,chardate(1:1),ios,ltendaysp
4762 if (ios /= 0)ltendaysp=imiss
4763
4764 read(chardate(2:3),'(i2)',iostat=ios)lmonth
4765 !print*,chardate(2:3),ios,lmonth
4766 if (ios /= 0)lmonth=imiss
4767
4768 read(chardate(4:5),'(i2)',iostat=ios)lday
4769 !print*,chardate(4:5),ios,lday
4770 if (ios /= 0)lday=imiss
4771
4772 read(chardate(6:7),'(i2)',iostat=ios)lhour
4773 !print*,chardate(6:7),ios,lhour
4774 if (ios /= 0)lhour=imiss
4775
4776 read(chardate(8:9),'(i2)',iostat=ios)lminute
4777 !print*,chardate(8:9),ios,lminute
4778 if (ios /= 0)lminute=imiss
4779 end if
4780
4781 this%tendaysp=ltendaysp
4782 this%month=lmonth
4783 this%day=lday
4784 this%hour=lhour
4785 this%minute=lminute
4786else
4787 this%tendaysp=optio_l(tendaysp)
4788 this%month=optio_l(month)
4789 this%day=optio_l(day)
4790 this%hour=optio_l(hour)
4791 this%minute=optio_l(minute)
4792end if
4793
4794END FUNCTION cyclicdatetime_new
4795
4798elemental FUNCTION cyclicdatetime_to_char(this) RESULT(char)
4799TYPE(cyclicdatetime),INTENT(IN) :: this
4800
4801CHARACTER(len=80) :: char
4802
4805
4806END FUNCTION cyclicdatetime_to_char
4807
4808
4821FUNCTION cyclicdatetime_to_conventional(this) RESULT(dtc)
4822TYPE(cyclicdatetime),INTENT(IN) :: this
4823
4824TYPE(datetime) :: dtc
4825
4826integer :: year,month,day,hour
4827
4828dtc = datetime_miss
4829
4830! no cyclicdatetime present -> year=1001 : yearly values (no other time dependence)
4832 dtc=datetime_new(year=1007, month=1, day=1, hour=1, minute=1)
4833 return
4834end if
4835
4836! minute present -> not good for conventional datetime
4838! day, month and tendaysp present -> no good
4840
4842 dtc=datetime_new(year=1001, month=this%month, day=this%day, hour=1, minute=1)
4844 day=(this%tendaysp-1)*10+1
4845 dtc=datetime_new(year=1003, month=this%month, day=day, hour=1, minute=1)
4847 dtc=datetime_new(year=1005, month=this%month, day=1, hour=1, minute=1)
4849 ! only day present -> no good
4850 return
4851end if
4852
4855 dtc=datetime_new(year=year+1,month=month,day=day,hour=this%hour,minute=1)
4856end if
4857
4858
4859END FUNCTION cyclicdatetime_to_conventional
4860
4861
4862
4863FUNCTION trim_cyclicdatetime_to_char(in) RESULT(char)
4864TYPE(cyclicdatetime),INTENT(IN) :: in ! value to be represented as CHARACTER
4865
4866CHARACTER(len=len_trim(cyclicdatetime_to_char(in))) :: char
4867
4868char=cyclicdatetime_to_char(in)
4869
4870END FUNCTION trim_cyclicdatetime_to_char
4871
4872
4873
4874SUBROUTINE display_cyclicdatetime(this)
4875TYPE(cyclicdatetime),INTENT(in) :: this
4876
4878
4879end subroutine display_cyclicdatetime
4880
4881
4882#include "array_utilities_inc.F90"
4883
4885
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 |