Function PINTERP(xtab As Range, ytab As Range, x, Optional Linear)

' PINTERP Version 1.0.0: Original OpenOffice Macro

' PINTERP Version 1.0.1: Excel VBA conversion
'
' Excel VBA Spreadsheet Interpolation Macro
'
' Copyright (C) 2010, 2012 Eric J. Geyer
'
' This PINTERP function is free software: you can redistribute it
' and/or modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation, either
' version 3 of the License, or (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
' GNU Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public License
' along with this program. If not, see <http://www.gnu.org/licenses/>.
'
' Eric J. Geyer
' geyerej@gmail.com
' 405 Lippershey Ct.
' Cary, NC 27513
'
' Input:
' xtab: array of n x values
' ytab: array of n y values
' x: interpolant
' Linear: optional boolean; forces linear interpolation if >0
'
' Output:
' y: interpolated y at x
'
' Interpolation method:
' n=2: linear
' n=3: quadratic
' n>3: average of two possible quadratics through nearest 4 local points
' Linear: linear if optional Linear argument is true
'
' Cubic spline not used due to spreadsheet macro run time issues.
' Calculation time is prohibitive if calls to such a macro were copied to a
' very large number of spreadsheet cells with potential for different table
' input on each call, because this would require solving the spline matrix
' for every call. A simple average of the two possible quadratics through
' the nearest 4 local points (excepting single quadratic for end intervals)
' is nearly as good (i.e., cubic for equal spaced interior points), without
' this run time penalty.
'
Dim descending As Boolean
Dim nx, lo, hi, mid, nquad As Long
Dim quad, b1, b2 As Double
Dim delhilo, dellolo1, delhilo1, delhi1hi, delhi1lo As Double
'
' Default is more accurate quadratic interpolation
' Linear interpolation is for exceptional cases only
'
If IsMissing(Linear) Then Linear = 0
'
' Check Input Data
' Avoid loop counting data as it is inefficient for large tables
'
nx = xtab.Count
If (nx < 2) Then
PINTERP = "Error: nX<2"
Exit Function
End If
'
If (nx <> ytab.Count) Then
PINTERP = "Error: nX<>nY"
Exit Function
End If
'
' Allow limited extrapolation
'
If (((xtab(1) - x) / (xtab(2) - xtab(1))) > 0.2 Or _
((x - xtab(nx)) / (xtab(nx) - xtab(nx - 1))) > 0.2) Then
PINTERP = "Error: >20% extrapolation"
Exit Function
End If
'
 ' Locate interval containing x with bisection
' Run time is very important for huge spreadsheet tables:
' a) Do not test for table order(via descending Xor...) inside Loop
' b) Do not check equality inside Loop
' Run time is not important at all for small tables:
' a) Accept 1 extra iteration to avoid equality check in loop
'
descending = (xtab(1) > xtab(nx))
lo = 1
hi = nx
If (descending) Then
Do While (lo < hi)
'do not use average to avoid addition overflow; note backslash integer divide
mid = lo + (hi - lo) \ 2
If (x < xtab(mid)) Then
lo = mid + 1
Else
hi = mid
End If
Loop
Else
Do While (lo < hi)
'note no averaging to prevent addition overflow; and backslash integer divide
mid = lo + (hi - lo) \ 2
If (x > xtab(mid)) Then
lo = mid + 1
Else
hi = mid
End If
Loop
End If
If (descending Xor (x > xtab(1))) Then
lo = hi - 1
Else
hi = lo + 1
End If
'
' Check for divide by zero and save result for re-use.
'
delhilo = (xtab(hi) - xtab(lo))
If (delhilo = 0) Then
PINTERP = "Error: Equal X values"
Exit Function
End If
'
' Linear for 2 points
'
If nx < 3 Or Linear Then
PINTERP = ytab(lo) + (x - xtab(lo)) / delhilo * (ytab(hi) - ytab(lo))
Exit Function
End If
'
' Compute possible Newton quadratic polynomials
'
nquad = 0
quad = 0
If lo > 1 Then
'
dellolo1 = (xtab(lo) - xtab(lo - 1))
If (dellolo1 = 0) Then
PINTERP = "Error: Equal X values"
Exit Function
End If
'
delhilo1 = (xtab(hi) - xtab(lo - 1))
If (delhilo1 = 0) Then
PINTERP = "Error: Equal X values"
Exit Function
End If
'
b1 = (ytab(lo) - ytab(lo - 1)) / dellolo1
b2 = ((ytab(hi) - ytab(lo)) / delhilo - b1) / delhilo1
quad = ytab(lo - 1) + b1 * (x - xtab(lo - 1)) + b2 * (x - xtab(lo - 1)) * (x - xtab(lo))
nquad = nquad + 1
End If
If hi < nx Then
'
delhi1hi = (xtab(hi + 1) - xtab(hi))
If (delhi1hi = 0) Then
PINTERP = "Error: Equal X values"
Exit Function
End If
 '
delhi1lo = (xtab(hi + 1) - xtab(lo))
If (delhi1lo = 0) Then
PINTERP = "Error: Equal X values"
Exit Function
End If
'
b1 = (ytab(hi) - ytab(lo)) / delhilo
b2 = ((ytab(hi + 1) - ytab(hi)) / delhi1hi - b1) / delhi1lo
quad = quad + ytab(lo) + b1 * (x - xtab(lo)) + b2 * (x - xtab(lo)) * (x - xtab(hi))
nquad = nquad + 1
End If
'
PINTERP = quad / nquad
End Function