FIXME : Add documentation
Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
real, | intent(in) | :: | t | |||
real, | intent(in), | dimension(n) | :: | x | ||
integer, | intent(in) | :: | n | |||
real, | intent(in) | :: | p | |||
real, | intent(out) | :: | tp |
integer function fitp_intrvp (t,x,n,p,tp)
implicit none
integer, intent(in) :: n
real, intent(in) :: t, p
real, intent(out) :: tp
real, dimension(n), intent(in) :: x
!
! coded by alan kaylor cline
! from fitpack -- january 26, 1987
! a curve and surface fitting package
! a product of pleasant valley software
! 8603 altus cove, austin, texas 78759, usa
!
! this function determines the index of the interval
! (determined by a given increasing sequence) in which a
! given value lies, after translating the value to within
! the correct period. it also returns this translated value.
!
! on input--
!
! t is the given value.
!
! x is a vector of strictly increasing values.
!
! n is the length of x (n .ge. 2).
!
! and
!
! p contains the period.
!
! on output--
!
! tp contains a translated value of t (i. e. x(1) .le. tp,
! tp .lt. x(1)+p, and tp = t + k*p for some integer k).
!
! intrvl returns an integer i such that
!
! i = 1 if tp .lt. x(2) ,
! i = n if x(n) .le. tp ,
! otherwise x(i) .le. tp .lt. x(i+1),
!
! none of the input parameters are altered.
!
!-----------------------------------------------------------
integer :: il, ih, i, nper
real :: tt
save i
data i /1/
nper = int((t-x(1))/p)
tp = t-real(nper)*p
if (tp .lt. x(1)) tp = tp+p
tt = tp
!
! check for illegal i
!
if (i .ge. n) i = n/2
!
! check old interval and extremes
!
if (tt .lt. x(i)) then
if (tt .le. x(2)) then
i = 1
fitp_intrvp = 1
return
else
il = 2
ih = i
end if
else if (tt .le. x(i+1)) then
fitp_intrvp = i
return
else if (tt .ge. x(n)) then
i = n
fitp_intrvp = n
return
else
il = i+1
ih = n
end if
!
! binary search loop
!
1 i = (il+ih)/2
if (tt .lt. x(i)) then
ih = i
else if (tt .gt. x(i+1)) then
il = i+1
else
fitp_intrvp = i
return
end if
go to 1
end function fitp_intrvp