View Single Post
  #4  
Old 05-27-2008, 09:43 PM
DocM DocM is offline
Registered User
 
Join Date: 27 May 2008
Posts: 3
DocM is becoming part of the community
The code for the bracket function is below.

Code:
'---------------------------------------------------------------------------------------
'
' P U R P O S E
'
' The function bracket find x1=x(i1) and x2=x(i2) from a table x
' so that x1 <= x_value <= x2.
'
' I N P U T
'
' x         = a range of cells representing x.
' x_value   = the x value to be bracketed.
' active    = an array of x.count elements.
'           = 0 if the corresponding x is to be ignored.
'
' O U T P U T
'
' i1        = the x index which will enclose x_value.
' i2        = the x index which will enclose x_value.
'           x(i1) <= x_value <= x(i2)
'           If x_value is out-of-bound, the two closest x values to x_value
'           will be returned.
'           If there are identical values of x(i1) or x(i2) in x, the first one
'           encountered will be used.
'
'---------------------------------------------------------------------------------------
Sub bracket(x As Object, x_value, i1, i2, active() As Boolean)

Dim i As Integer           ' counter.
Dim x1, xi, x2 As Single   ' = x(i1), x(i), x(i2), respectively.
Dim nactive As Integer
Dim usable As Boolean

nactive = UBound(active)

' If dx of first pair of x times number of points matches the last x,
' the program assumes x is equally spaced.

If x.count >= 2 And nactive <= 1 Then
   If Abs((x(x.count) - x(1)) / (x.count - 1) - (x(2) - x(1))) <= 0.01 * Abs(x(2) - x(1)) Then
      If x(x.count) >= x(1) Then
         i1 = Int((x_value - x(1)) / (x(2) - x(1))) + 1
         If x_value < x(i1) Then          ' Minor adjustment in case of round-off error.
            i1 = i1 - 1
         End If
         If i1 < 1 Then
            i1 = 1
         ElseIf i1 > x.count - 1 Then
            i1 = x.count - 1
         End If
         i2 = i1 + 1
      Else
         i1 = x.count - Int((x_value - x(x.count)) / (x(1) - x(2)))
         If x_value < x(i1) Then          ' Minor adjustment in case of round-off error.
            i1 = i1 + 1
         End If
         If i1 < 2 Then
            i1 = 2
         ElseIf i1 > x.count Then
            i1 = x.count
         End If
         i2 = i1 - 1
      End If
      If x_value >= x(i1) And x_value <= x(i2) Then
         Exit Sub
      ElseIf x_value < x(i1) And (i1 = 1 Or i1 = x.count) Then
         Exit Sub
      ElseIf x_value > x(i2) And (i2 = 1 Or i2 = x.count) Then
         Exit Sub
      End If
   End If
End If

' If the above fails, a more thorough search is performed.

i1 = 0
i2 = 0
For i = 1 To x.count
   xi = x(i)
   If nactive <= 1 Then
      usable = True
   Else
      usable = active(i)
   End If
   
   If Not usable Or Not IsNumeric(xi) Or VarType(xi) = vbEmpty Then
      
      ' Do nothing.
      
   ElseIf i1 = i2 Then
      If i1 = 0 Then
         i1 = i
         i2 = i
         x1 = xi
         x2 = xi
      ElseIf xi > x2 Then
         i2 = i
         x2 = xi
      ElseIf xi < x1 Then
         i1 = i
         x1 = xi
      End If
   ElseIf x1 <= x_value And x2 >= x_value Then
      If xi <= x1 Or xi >= x2 Then
         ' Do nothing.
      ElseIf xi < x_value Then
         i1 = i
         x1 = xi
      Else
         i2 = i
         x2 = xi
      End If
   ElseIf x1 >= x_value Then
      If xi < x1 Then
         i2 = i1
         x2 = x1
         i1 = i
         x1 = xi
      ElseIf xi <> x1 And xi < x2 Then
         i2 = i
         x2 = xi
      End If
   ElseIf x2 <= x_value Then
      If xi > x2 Then
         i1 = i2
         x1 = x2
         i2 = i
         x2 = xi
      ElseIf xi <> x2 And xi > x1 Then
         i1 = i
         x1 = xi
      End If
   End If
Next i

End Sub
Reply With Quote