Click here to Skip to main content
15,891,184 members
Articles / Programming Languages / Visual Basic

Mathemathics Framework

Rate me:
Please Sign up or sign in to vote.
4.76/5 (56 votes)
16 Sep 2008CPOL6 min read 75.4K   6.2K   171  
.NET Mathematical Framework
Imports ggCoreLib
Imports BV.Math
Imports System
Imports System.Drawing
Imports System.Windows.Forms
Imports System.ComponentModel

''' <summary>
''' Permite mediante diversos m�todos hallar Raices de funciones
''' que pueden ser de variable compleja
''' </summary>
''' <remarks></remarks>
Public Class FindRootUtil
    Implements IIconnable

    Const Factor As Single = 1.6
    Const Ntry As Integer = 50

    Private ErrorType As TypeOfError
    Private NroIterations As Integer
    Private intIterations As Integer    'cantidad de iteraciones realizadas para llegar a encontrar la raiz
    Private intEnableAnimation As Boolean
    Private intEnableStepping As Boolean
    Private StepGo As Boolean
    Private intAccuracy As Single
    Private intDefaultRange As RangeF
    Private intRootValue As Single
    Private intRootFound As Boolean
    Private intIcon As Icon

    Private ARanges() As RangeF          'Array de rangos donde hay al menos una singularidad
    Private intBracketIterations As Integer
    Private intBracketSteps As Integer

    Public Event RootFound(ByVal sender As Object, ByVal e As EventArgs)
    Public Event RangeChange(ByVal sender As Object, ByVal e As EventArgs)

#Region "Delegates Types"

    'dibuja un punto y un label en la coordenada especificada
    Public Delegate Sub DrawPoint(ByVal g As Graphics, ByVal x As Single, ByVal y As Single, ByVal Label As String, ByVal ptColor As Color)

    'dibuja una linea recta entre las coordenadas especificadas
    'en el grafico de funciones
    Public Delegate Sub DrawLine(ByVal g As Graphics, ByVal x1 As Single, ByVal x2 As Single, ByVal y1 As Single, ByVal y2 As Single)

    'dibuja la recta tangente a partir de la coordenada dada
    'hasta Y=0
    Public Delegate Sub DrawTangent(ByVal g As Graphics, ByVal x1 As Single, ByVal y1 As Single, ByVal Pend As Single, ByVal blnNoEnd As Boolean)


    Public DrawPointMethod As DrawPoint
    Public DrawLineMethod As DrawLine
    Public DrawTangentMethod As DrawTangent

#End Region

#Region "Constructor"

    Public Sub New()
        NroIterations = 50
        intAccuracy = 0.005
        ErrorType = TypeOfError.ENone
        intEnableAnimation = False
        StepGo = False
        intEnableStepping = False
        intDefaultRange.Min = -10
        intDefaultRange.Max = 10
        intRootValue = 0
        intRootFound = False
        Me.intIcon = New Icon([GetType], "FRFalseP.ico")

        intBracketIterations = 50
        Me.intBracketSteps = 50 'Me.Range.dx / intBracketIterations
    End Sub

#End Region

#Region "Properties"

#Region "Animation"

    'para que pueda animarse deben estar seteados todos los metodos de graficado
    '<Category("Animation")> _
    <Browsable(False)> _
    Public Property EnableAnimation() As Boolean
        Get
            Return intEnableAnimation
        End Get
        Set(ByVal Value As Boolean)
            If Value Then
                If Not DrawPointMethod Is Nothing Then
                    If Not DrawLineMethod Is Nothing Then
                        If Not DrawTangentMethod Is Nothing Then
                            intEnableAnimation = Value
                            Return
                        End If
                    End If
                End If
            End If
            intEnableAnimation = False
        End Set
    End Property

    '    <Category("Animation")> _
    <Browsable(False)> _
    Public Property EnableStepping() As Boolean
        Get
            Return intEnableStepping
        End Get
        Set(ByVal Value As Boolean)
            intEnableStepping = Value
        End Set
    End Property

#End Region

#Region "Value"

    ''' <summary>
    ''' Nivel de exactitud utilizado para el c�lculo de la ra�z
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <Category("Value"), Description("Nivel de exactitud utilizado para el c�lculo de la ra�z")> _
    Public Property Accuracy() As Single
        Get
            Return intAccuracy
        End Get
        Set(ByVal Value As Single)
            If Value > 0 Then
                intAccuracy = Value
            End If
        End Set
    End Property

    ''' <summary>
    ''' N�mero de iteraciones realizadas para obtener el valor deseado de la ra�z
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <Category("Value"), Description("N�mero de iteraciones realizadas para obtener el valor deseado de la ra�z")> _
    Public ReadOnly Property Iterations() As Integer
        Get
            Return Me.intIterations
        End Get
    End Property

    ''' <summary>
    ''' Valor encontrado de la Ra�z
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <Category("Value"), Description("Valor encontrado de la Ra�z")> _
    Public ReadOnly Property RootValue() As Single
        Get
            Return intRootValue
        End Get
    End Property

    ''' <summary>
    ''' Es True si la ra�z fue encontrada en el intervalo dado
    ''' con las condiciones dadas
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <Category("Value"), Description("Es True si la ra�z fue encontrada en el " & _
    "")> _
    Public ReadOnly Property RootFounded() As Boolean
        Get
            Return intRootFound
        End Get
    End Property

    ''' <summary>
    ''' L�mites entre los cuales se buscar� la ra�z de la funci�n especificada
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <Category("Value"), Description("L�mites entre los cuales se buscar� la" & _
    "ra�z de la funci�n especificada")> _
    Public Property Range() As RangeF
        Get
            Return intDefaultRange
        End Get
        Set(ByVal Value As RangeF)
            intDefaultRange = Value
            RaiseEvent RangeChange(Me, New EventArgs)
        End Set
    End Property

#End Region

#Region "Ranges"

    ''' <summary>
    ''' Intervalos conocidos donde al menos hay una ra�z
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <Category("Ranges"), Description("Intervalos conocidos donde al menos hay una ra�z")> _
    Public ReadOnly Property KnownRanges() As RangeF()
        Get
            Return Me.ARanges
        End Get
    End Property

    ''' <summary>
    ''' N�mero de intervalos conocidos donde al menos hay una ra�z
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <Category("Ranges"), Description("N�mero de intervalos conocidos donde al menos hay una ra�z")> _
       Public ReadOnly Property KnownRangesCount() As Integer
        Get
            If ARanges Is Nothing Then
                Return 0
            End If
            Return Me.ARanges.GetUpperBound(0) + 1
        End Get
    End Property

    ''' <summary>
    ''' M�ximo numero de iteraciones permitidas en la b�squeda de intervalos con raices
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <Category("Ranges"), Description("M�ximo numero de iteraciones permitidas en la" & _
    " b�squeda de intervalos con raices")> _
    Public Property BracketIterations() As Integer
        Get
            Return Me.intBracketIterations
        End Get
        Set(ByVal Value As Integer)
            If Value > 0 Then
                intBracketIterations = Value
            Else
                MessageManager.Send(Me, New MessageEventArgs("Bracket Iteration number " & _
                    "must be greater than 0", MessageEventArgs.EMessageType.Warning))
            End If
        End Set
    End Property

    ''' <summary>
    ''' N�mero de intervalos con ra�ces a buscar
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <Category("Ranges"), Description("N�mero de intervalos con ra�ces a buscar")> _
    Public Property BracketsNumber() As Integer
        Get
            Return Me.intBracketSteps
        End Get
        Set(ByVal Value As Integer)
            If Value < Me.Range.dx AndAlso intBracketSteps > 0 Then
                Me.intBracketSteps = Value
            Else
                MessageManager.Send(Me, New MessageEventArgs("Bracket Step must be lower than finding Range", MessageEventArgs.EMessageType.Warning))
            End If
        End Set
    End Property

    ''' <summary>
    ''' Paso utilizado en la determinaci�n de los intervalos que contienen raices
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <Category("Ranges"), Description("Paso utilizado en la determinaci�n de los intervalos que contienen raices")> _
     Public ReadOnly Property BracketStep() As Single
        Get
            Return Me.intDefaultRange.dx / Me.intBracketSteps
        End Get
    End Property

#End Region

#Region "Browsable(False)"

    <Browsable(False)> _
    Public Property Min() As Single
        Get
            Return intDefaultRange.Min
        End Get
        Set(ByVal Value As Single)
            intDefaultRange.Min = Value
            RaiseEvent RangeChange(Me, New EventArgs)
        End Set
    End Property

    <Browsable(False)> _
    Public Property Max() As Single
        Get
            Return intDefaultRange.Max
        End Get
        Set(ByVal Value As Single)
            intDefaultRange.Max = Value
            RaiseEvent RangeChange(Me, New EventArgs)
        End Set
    End Property

    <Browsable(False)> _
    Public Property Icon() As System.Drawing.Icon Implements IIconnable.Icon
        Get
            Return intIcon
        End Get
        Set(ByVal Value As System.Drawing.Icon)
            If Not Value Is Nothing Then
                intIcon = Value
            End If
        End Set
    End Property

#End Region

#End Region

#Region "Steps methods"

    Public Sub NextStep()
        StepGo = True
    End Sub

    Private Sub WaitStepping()
        Do While intEnableStepping
            'se queda esperando hasta el proximo stepgo
            If StepGo Then
                StepGo = False
                Exit Do
            End If
            System.Windows.Forms.Application.DoEvents()
        Loop
    End Sub

#End Region

#Region "Find Roots methods"

#Region "False Position methods"

    'Utiliza el rango predeterminado de la clase para buscar la raiz
    Public Function FRFalsePosition(ByVal Calc As OperSingleDelegate) As Single
        Return FRFalsePosition(Me.intDefaultRange.Min, intDefaultRange.Max, Calc)
    End Function

    Public Function FRFalsePosition(ByVal g As Graphics, ByVal Calc As OperSingleDelegate) As Single
        Return FRFalsePosition(g, Me.intDefaultRange.Min, intDefaultRange.Max, Calc)
    End Function

    'solo busca la raiz. pero no dibuja nada
    Public Function FRFalsePosition(ByVal X1 As Single, ByVal X2 As Single, ByVal Calc As OperSingleDelegate) As Single
        Dim xl As Single, f As Single, fl As Single
        Dim xh As Single, fh As Single, del As Single
        Dim Swap As Single, dx As Single

        Me.intRootFound = False
        fl = Calc(X1)
        fh = Calc(X2)
        If fl * fh > 0 Then
            MessageManager.Send(Me, New MessageEventArgs("Roots must be bracketed for bisection in rtbis", MessageEventArgs.EMessageType.[Error]))
            Exit Function
        End If
        If fl < 0 Then
            xl = X1     'xl al contiene al f(x) negativo
            xh = X2
        Else
            xl = X2
            xh = X1
            Swap = fl
            fl = fh
            fh = Swap
        End If
        dx = xh - xl
        For intIterations = 1 To NroIterations
            intRootValue = xl + dx * fl / (fl - fh) 'pendiente de la secante
            f = Calc(intRootValue)

            If f < 0 Then
                del = xl - intRootValue
                xl = intRootValue
                fl = f
            Else
                del = xh - intRootValue
                xh = intRootValue
                fh = f
            End If
            dx = xh - xl
            If Math.Abs(del) < intAccuracy Or f = 0 Then
                FRFalsePosition = intRootValue
                Me.intRootFound = True
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            End If
        Next
        MessageManager.Send(Me, New MessageEventArgs("Roots must be bracketed for bisection in rtbis", MessageEventArgs.EMessageType.[Error]))
    End Function

    'False Position method
    '1/8/03
    Public Function FRFalsePosition(ByVal g As Graphics, ByVal X1 As Single, ByVal X2 As Single, ByVal Calc As OperSingleDelegate) As Single
        Dim xl As Single, f As Single, fl As Single
        Dim xh As Single, fh As Single, del As Single
        Dim Swap As Single, dx As Single

        Me.intRootFound = False
        fl = Calc(X1)
        fh = Calc(X2)
        If fl * fh > 0 Then
            MessageManager.Send(Me, New MessageEventArgs("Roots must be bracketed for bisection in rtbis", MessageEventArgs.EMessageType.[Error]))
            Exit Function
        End If
        If fl < 0 Then
            xl = X1     'xl al contiene al f(x) negativo
            xh = X2
        Else
            xl = X2
            xh = X1
            Swap = fl
            fl = fh
            fh = Swap
        End If
        dx = xh - xl
        If intEnableAnimation Then
            DrawPointMethod(g, xl, fl, intIterations, Color.Green)
        End If
        For intIterations = 1 To NroIterations
            WaitStepping()

            intRootValue = xl + dx * fl / (fl - fh) 'pendiente de la secante
            f = Calc(intRootValue)

            If f < 0 Then
                If intEnableAnimation Then 'ahora cambia de pivot si los dos f tienen el mismo signo
                    DrawPointMethod(g, xl, fl, intIterations, Color.GreenYellow)
                    DrawPointMethod(g, xh, fh, "", Color.Red)
                    DrawLineMethod(g, xl, xh, fl, fh)
                End If
                del = xl - intRootValue
                xl = intRootValue
                fl = f
            Else
                If intEnableAnimation Then
                    DrawPointMethod(g, xl, fl, intIterations, Color.Green)
                    DrawPointMethod(g, xh, fh, intIterations, Color.Green)
                    DrawLineMethod(g, xh, xl, fh, fl)
                End If
                del = xh - intRootValue
                xh = intRootValue
                fh = f
            End If
            dx = xh - xl
            If Math.Abs(del) < intAccuracy Or f = 0 Then
                FRFalsePosition = intRootValue
                intRootFound = True
                If intEnableAnimation Then
                    DrawPointMethod(g, intRootValue, f, intIterations, Color.Blue)
                End If
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            End If
        Next
        MessageManager.Send(Me, New MessageEventArgs("Roots must be bracketed for bisection in rtbis", MessageEventArgs.EMessageType.[Error]))
    End Function

#End Region

#Region "Secant methods"

    Public Function FRSecant(ByVal Calc As OperSingleDelegate) As Single
        Return FRSecant(Me.intDefaultRange.Min, intDefaultRange.Max, Calc)
    End Function

    Public Function FRSecant(ByVal X1 As Single, ByVal X2 As Single, ByVal Calc As OperSingleDelegate) As Single
        Dim xl, f, fl As Single
        Dim Swap, dx As Single

        Me.intRootFound = False
        f = Calc(X1)
        fl = Calc(X2)
        If Math.Abs(fl) < Math.Abs(f) Then        'intRootValue guarda el x con f de mayor modulo
            intRootValue = X1
            xl = X2
            Swap = fl
            fl = f
            f = Swap                    'f guarda el menor
        ElseIf Math.Abs(fl) > Math.Abs(f) Then
            intRootValue = X2
            xl = X1
        Else
            MessageManager.Send(Me, New MessageEventArgs("Secant was to the infinite" & vbCr & "Change the limits and try again", MessageEventArgs.EMessageType.[Error]))
            Exit Function
        End If

        For intIterations = 1 To NroIterations
            WaitStepping()
            If f = fl Then
                MessageManager.Send(Me, New MessageEventArgs("Secant was to the infinite" & vbCr & "Change the limits and try again", MessageEventArgs.EMessageType.[Error]))
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            End If
            dx = (xl - intRootValue) * f / (f - fl)
            xl = intRootValue
            fl = f
            intRootValue = intRootValue + dx
            f = Calc(intRootValue)
            If Math.Abs(dx) < intAccuracy Or f = 0 Then
                FRSecant = intRootValue
                Me.intRootFound = True
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            End If
        Next
        MessageManager.Send(Me, New MessageEventArgs("Maximun number of iterations exceeded", MessageEventArgs.EMessageType.[Error]))
    End Function

    Public Function FRSecant(ByVal g As Graphics, ByVal Calc As OperSingleDelegate) As Single
        Return Me.FRSecant(g, Me.intDefaultRange.Min, intDefaultRange.Max, Calc)
    End Function
    'FRSecant method
    '1/8/03
    Public Function FRSecant(ByVal g As Graphics, ByVal X1 As Single, ByVal X2 As Single, ByVal Calc As OperSingleDelegate) As Single
        Dim xl As Single, f As Single, fl As Single
        Dim Swap As Single, dx As Single

        Me.intRootFound = False
        f = Calc(X1)
        fl = Calc(X2)
        If Math.Abs(fl) < Math.Abs(f) Then        'intRootValue guarda el x con f de mayor modulo
            intRootValue = X1
            xl = X2
            Swap = fl
            fl = f
            f = Swap                    'f guarda el menor
        ElseIf Math.Abs(fl) > Math.Abs(f) Then
            intRootValue = X2
            xl = X1
        Else
            MessageManager.Send(Me, New MessageEventArgs("Secant was to the infinite" & vbCr & "Change the limits and try again", MessageEventArgs.EMessageType.[Error]))
            Exit Function
        End If

        For intIterations = 1 To NroIterations
            WaitStepping()
            If intEnableAnimation Then
                DrawPointMethod(g, intRootValue, f, intIterations, Color.GreenYellow)
                DrawPointMethod(g, xl, fl, "", Color.Blue)
                DrawLineMethod(g, intRootValue, xl, f, fl)
            End If
            If f = fl Then
                MsgBox("Secant go to infinite", vbCritical, "Error")
                Exit Function
            End If
            dx = (xl - intRootValue) * f / (f - fl)
            xl = intRootValue
            fl = f
            intRootValue = intRootValue + dx
            f = Calc(intRootValue)
            If Math.Abs(dx) < intAccuracy Or f = 0 Then
                FRSecant = intRootValue
                Me.intRootFound = True
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            End If
        Next
        MessageManager.Send(Me, New MessageEventArgs("Maximun number of iterations exceeded", MessageEventArgs.EMessageType.[Error]))
    End Function

#End Region

#Region "Newton Raphson methods"

    Public Function FRNewtonRaphson(ByVal Calc As OperSingleDelegate, ByVal Derivade As OperBinDelegate) As Single
        Return FRNewtonRaphson(Me.intDefaultRange.Min, Me.intDefaultRange.Max, Calc, Derivade)
    End Function

    Public Function FRNewtonRaphson(ByVal X1 As Single, ByVal X2 As Single, ByVal Calc As OperSingleDelegate, ByVal Derivade As OperBinDelegate) As Single
        Dim f As Single
        Dim df, dx As Single

        Me.intRootFound = False
        intRootValue = 0.5 * (X1 + X2)
        For intIterations = 1 To NroIterations
            df = Derivade(intRootValue, intAccuracy)
            If df = 0 Then
                MessageManager.Send(Me, New MessageEventArgs("A point have 0 as derivade" & vbCr & "The tangent line go to infinite" & _
                        vbCr & "Change the limits and try again", MessageEventArgs.EMessageType.Warning))
                Exit Function
            End If
            WaitStepping()

            f = Calc(intRootValue)

            dx = f / df
            intRootValue = intRootValue - dx
            If (X1 - intRootValue) * (intRootValue - X2) < 0 Then
                MessageManager.Send(Me, New MessageEventArgs("Jumped out of brackets in rtnewt", MessageEventArgs.EMessageType.Warning))
                Exit Function
            End If

            If Math.Abs(dx) < intAccuracy Then
                Me.intRootFound = True
                FRNewtonRaphson = intRootValue
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            End If
        Next
        MessageManager.Send(Me, New MessageEventArgs("Maximun number of iterations exceeded", MessageEventArgs.EMessageType.Warning))
    End Function

    Public Function FRNewtonRaphson(ByVal g As Graphics, ByVal Calc As OperSingleDelegate, ByVal Derivade As OperBinDelegate) As Single
        Return FRNewtonRaphson(g, Me.intDefaultRange.Min, Me.intDefaultRange.Max, Calc, Derivade)
    End Function

    'Newton Raphson method
    '1/8/03
    Public Function FRNewtonRaphson(ByVal g As Graphics, ByVal X1 As Single, ByVal X2 As Single, ByVal Calc As OperSingleDelegate, ByVal Derivade As OperBinDelegate) As Single
        Dim f As Single
        Dim df, dx As Single

        Me.intRootFound = False
        intRootValue = 0.5 * (X1 + X2)
        For intIterations = 1 To NroIterations
            df = Derivade(intRootValue, intAccuracy)
            If df = 0 Then
                MessageManager.Send(Me, New MessageEventArgs("A point have 0 as derivade" & vbCr & "The tangent line go to infinite" & _
                        vbCr & "Change the limits and try again", MessageEventArgs.EMessageType.Warning))
                Exit Function
            End If
            WaitStepping()

            f = Calc(intRootValue)

            If intEnableAnimation Then
                DrawTangentMethod(g, intRootValue, f, df, False)
                DrawPointMethod(g, intRootValue, f, intIterations, Color.GreenYellow)
            End If
            dx = f / df
            intRootValue = intRootValue - dx
            If (X1 - intRootValue) * (intRootValue - X2) < 0 Then
                MessageManager.Send(Me, New MessageEventArgs("Jumped out of brackets in rtnewt", MessageEventArgs.EMessageType.Warning))
                Exit Function
            End If

            If Math.Abs(dx) < intAccuracy Then
                Me.intRootFound = True
                FRNewtonRaphson = intRootValue
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            End If
        Next
        MessageManager.Send(Me, New MessageEventArgs("Maximun number of iterations exceeded", MessageEventArgs.EMessageType.Warning))
    End Function

#End Region

#Region "Newton Raphson Safe Method"

    Public Function FRNewtonRaphsonSafe(ByVal Calc As OperSingleDelegate, _
                                        ByVal Derivade As OperBinDelegate) As Single
        Return FRNewtonRaphsonSafe(Me.intDefaultRange.Min, Me.intDefaultRange.Max, Calc, Derivade)
    End Function

    Public Function FRNewtonRaphsonSafe(ByVal X1 As Single, _
                                        ByVal X2 As Single, _
                                        ByVal Calc As OperSingleDelegate, _
                                        ByVal Derivade As OperBinDelegate) As Single
        Dim f As Single, fl As Single, fh As Single
        Dim temp As Single, xl As Single, xh As Single
        Dim df As Single, dx As Single, dXOld As Single

        intIterations = 0
        Me.intRootFound = False
        fl = Calc(X1)
        fh = Calc(X2)
        If (fl > 0 And fh > 0) Or (fl < 0 And fh < 0) Then
            MessageManager.Send(Me, New MessageEventArgs("Jumped out of brackets in rtnewt", MessageEventArgs.EMessageType.Warning))
            Exit Function
        End If
        If fl = 0 Then
            FRNewtonRaphsonSafe = X1
            Exit Function
        End If
        If fh = 0 Then
            FRNewtonRaphsonSafe = X2
            Exit Function
        End If
        If fl < 0 Then
            xl = X1
            xh = X2
        Else
            xh = X1
            xl = X2
        End If

        intRootValue = 0.5 * (X1 + X2)
        dXOld = Math.Abs(X2 - X1)
        dx = dXOld
        df = Derivade(intRootValue, intAccuracy)
        f = Calc(intRootValue)
        For intIterations = 1 To NroIterations

            If ((intRootValue - xh) * df - f) * ((intRootValue - xl) * df - f) > 0 Or Math.Abs(2 * f) > Math.Abs(dXOld * df) Then
                dXOld = dx
                dx = 0.5 * (xh - xl)
                intRootValue = xl + dx
                If xl = intRootValue Then
                    FRNewtonRaphsonSafe = intRootValue
                    Me.intRootFound = True
                    RaiseEvent RootFound(Me, New EventArgs)
                    Exit Function
                End If
            ElseIf df = 0 Then
                MessageManager.Send(Me, New MessageEventArgs("A point have 0 as derivade" & vbCr & "The tangent line go to infinite" & _
                        vbCr & "Change the limits and try again", MessageEventArgs.EMessageType.Info))
                Exit Function
            Else
                dXOld = dx
                dx = f / df
                temp = intRootValue
                intRootValue = intRootValue - dx
                If temp = intRootValue Then
                    FRNewtonRaphsonSafe = intRootValue
                    Me.intRootFound = True
                    RaiseEvent RootFound(Me, New EventArgs)
                    Exit Function
                End If
            End If

            If Math.Abs(dx) < intAccuracy Then
                FRNewtonRaphsonSafe = intRootValue
                Me.intRootFound = True
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            End If

            df = Derivade(intRootValue, intAccuracy)
            f = Calc(intRootValue)
            If f < 0 Then
                xl = intRootValue
            Else
                xh = intRootValue
            End If
        Next
        MessageManager.Send(Me, New MessageEventArgs("Maximun number of iterations exceeded", MessageEventArgs.EMessageType.Warning))
    End Function

    Public Function FRNewtonRaphsonSafe(ByVal g As Graphics, _
                                            ByVal Calc As OperSingleDelegate, _
                                            ByVal Derivade As OperBinDelegate) As Single
        Return FRNewtonRaphsonSafe(g, Me.intDefaultRange.Min, Me.intDefaultRange.Max, Calc, Derivade)
    End Function

    'Newton Raphson and bisection Safe method
    '1/8/03
    '2/8/03
    Public Function FRNewtonRaphsonSafe(ByVal g As Graphics, _
                                        ByVal X1 As Single, _
                                        ByVal X2 As Single, _
                                        ByVal Calc As OperSingleDelegate, _
                                        ByVal Derivade As OperBinDelegate) As Single
        Dim f As Single, fl As Single, fh As Single
        Dim temp As Single, xl As Single, xh As Single
        Dim df As Single, dx As Single, dXOld As Single

        intIterations = 0
        Me.intRootFound = False
        fl = Calc(X1)
        fh = Calc(X2)
        If (fl > 0 And fh > 0) Or (fl < 0 And fh < 0) Then
            MessageManager.Send(Me, New MessageEventArgs("Jumped out of brackets in rtnewt", MessageEventArgs.EMessageType.Warning))
            Exit Function
        End If
        If fl = 0 Then
            FRNewtonRaphsonSafe = X1
            Me.intRootFound = True
            RaiseEvent RootFound(Me, New EventArgs)
            Exit Function
        End If
        If fh = 0 Then
            FRNewtonRaphsonSafe = X2
            Me.intRootFound = True
            RaiseEvent RootFound(Me, New EventArgs)
            Exit Function
        End If
        If fl < 0 Then
            xl = X1
            xh = X2
        Else
            xh = X1
            xl = X2
        End If

        intRootValue = 0.5 * (X1 + X2)
        dXOld = Math.Abs(X2 - X1)
        dx = dXOld
        df = Derivade(intRootValue, intAccuracy)
        f = Calc(intRootValue)
        For intIterations = 1 To NroIterations
            WaitStepping()
            If intEnableAnimation Then
                DrawPointMethod(g, intRootValue, f, intIterations, Color.Green)
                DrawTangentMethod(g, intRootValue, f, df, False)
            End If

            If ((intRootValue - xh) * df - f) * ((intRootValue - xl) * df - f) > 0 Or Math.Abs(2 * f) > Math.Abs(dXOld * df) Then
                dXOld = dx
                dx = 0.5 * (xh - xl)
                intRootValue = xl + dx
                If xl = intRootValue Then
                    FRNewtonRaphsonSafe = intRootValue
                    Me.intRootFound = True
                    If EnableAnimation Then
                        DrawPointMethod(g, xl, fl, intIterations, Color.Blue)
                    End If
                    RaiseEvent RootFound(Me, New EventArgs)
                    Exit Function
                End If
            ElseIf df = 0 Then
                MessageManager.Send(Me, New MessageEventArgs("A point have 0 as derivade" & vbCr & "The tangent line go to infinite" & _
                        vbCr & "Change the limits and try again", MessageEventArgs.EMessageType.Info))
                Exit Function
            Else
                dXOld = dx
                dx = f / df
                temp = intRootValue
                intRootValue = intRootValue - dx
                If temp = intRootValue Then
                    FRNewtonRaphsonSafe = intRootValue
                    Me.intRootFound = True
                    If intEnableAnimation Then
                        DrawPointMethod(g, xl, fl, intIterations, Color.Blue)
                    End If
                    RaiseEvent RootFound(Me, New EventArgs)
                    Exit Function
                End If
            End If

            If Math.Abs(dx) < intAccuracy Then
                FRNewtonRaphsonSafe = intRootValue
                Me.intRootFound = True
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            End If

            df = Derivade(intRootValue, intAccuracy)
            f = Calc(intRootValue)
            If f < 0 Then
                xl = intRootValue
            Else
                xh = intRootValue
            End If
        Next
        MessageManager.Send(Me, New MessageEventArgs("Maximun number of iterations exceeded", MessageEventArgs.EMessageType.Warning))
    End Function

#End Region

#Region "Ridders methods"

    Public Function FRRidders(ByVal Calc As OperSingleDelegate) As Single
        Return Me.FRRidders(Me.intDefaultRange.Min, Me.intDefaultRange.Max, Calc)
    End Function

    Public Function FRRidders(ByVal X1 As Single, ByVal X2 As Single, ByVal Calc As OperSingleDelegate) As Single
        Dim xl, fl As Single
        Dim xh, fh As Single
        Dim xm, xnew As Single
        Dim s, fm, fnew As Single
        Const Unused As Single = -1.11E+30

        Me.intRootFound = False
        fl = Calc(X1)
        fh = Calc(X2)
        intIterations = 0
        If ((fl > 0 And fh < 0) Or (fl < 0 And fh > 0)) Then
            xl = X1
            xh = X2
            intRootValue = Unused
            For intIterations = 1 To NroIterations
                xm = 0.5 * (xl + xh)
                fm = Calc(xm)
                s = fm * fm - fl * fh
                If s < 0 Then
                    s = -s
                End If
                s = Math.Sqrt(s)
                If s = 0 Then
                    FRRidders = intRootValue
                    Me.intRootFound = True
                    RaiseEvent RootFound(Me, New EventArgs)
                    Exit Function
                End If
                If fl >= fh Then
                    xnew = xm + (xm - xl) * fm / s
                Else
                    xnew = xm - (xm - xl) * fm / s
                End If

                If Math.Abs(xnew - intRootValue) <= intAccuracy Then
                    FRRidders = intRootValue
                    Me.intRootFound = True
                    RaiseEvent RootFound(Me, New EventArgs)
                    Exit Function
                End If

                intRootValue = xnew
                fnew = Calc(intRootValue)
                If fnew = 0 Then
                    FRRidders = intRootValue
                    Me.intRootFound = True
                    Exit Function
                End If
                If Math.Sign(fnew) <> Math.Sign(fm) Then
                    xl = xm
                    fl = fm
                    xh = intRootValue
                    fh = fnew
                ElseIf Math.Sign(fnew) <> Math.Sign(fl) Then
                    xh = intRootValue
                    fh = fnew
                ElseIf Math.Sign(fnew) <> Math.Sign(fh) Then
                    xl = intRootValue
                    fl = fnew
                Else
                    MessageManager.Send(Me, New MessageEventArgs("Never get here", MessageEventArgs.EMessageType.[Error]))
                    Exit Function
                End If
                If Math.Abs(xh - xl) <= intAccuracy Then
                    FRRidders = intRootValue
                    Me.intRootFound = True
                    RaiseEvent RootFound(Me, New EventArgs)
                    Exit Function
                End If
            Next
            MessageManager.Send(Me, New MessageEventArgs("Maximun number of iterations exceeded", MessageEventArgs.EMessageType.Warning))
        Else
            If fl = 0 Then
                FRRidders = X1
                Me.intRootFound = True
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            ElseIf fh = 0 Then
                FRRidders = X2
                Me.intRootFound = True
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            Else
                MessageManager.Send(Me, New MessageEventArgs("Roots must be bracketed", MessageEventArgs.EMessageType.[Error]))
                Exit Function
            End If
        End If
    End Function


    Public Function FRRidders(ByVal g As Graphics, ByVal Calc As OperSingleDelegate) As Single
        Return FRRidders(g, Me.intDefaultRange.Min, Me.intDefaultRange.Max, Calc)
    End Function

    'Ridders method
    '1/8/03
    Public Function FRRidders(ByVal g As Graphics, ByVal X1 As Single, ByVal X2 As Single, ByVal Calc As OperSingleDelegate) As Single
        Dim xl, fl As Single
        Dim xh, fh As Single
        Dim xm, xnew As Single
        Dim s, fm, fnew As Single
        Const Unused As Single = -1.11E+30

        intIterations = 0
        Me.intRootFound = False
        fl = Calc(X1)
        fh = Calc(X2)
        If ((fl > 0 And fh < 0) Or (fl < 0 And fh > 0)) Then
            xl = X1
            xh = X2
            intRootValue = Unused
            For intIterations = 1 To NroIterations
                WaitStepping()

                xm = 0.5 * (xl + xh)
                fm = Calc(xm)
                s = fm * fm - fl * fh
                If s < 0 Then
                    s = -s
                End If
                s = Math.Sqrt(s)
                If s = 0 Then
                    FRRidders = intRootValue
                    Me.intRootFound = True
                    If intEnableAnimation Then
                        DrawPointMethod(g, xl, fl, intIterations, Color.Blue)
                    End If
                    RaiseEvent RootFound(Me, New EventArgs)
                    Exit Function
                End If
                If fl >= fh Then
                    xnew = xm + (xm - xl) * fm / s
                Else
                    xnew = xm - (xm - xl) * fm / s
                End If

                If Math.Abs(xnew - intRootValue) <= intAccuracy Then
                    FRRidders = intRootValue
                    Me.intRootFound = True
                    RaiseEvent RootFound(Me, New EventArgs)
                    Exit Function
                End If

                intRootValue = xnew
                fnew = Calc(intRootValue)
                If intEnableAnimation Then
                    DrawPointMethod(g, xnew, fnew, intIterations, Color.Green)
                End If
                If fnew = 0 Then
                    FRRidders = intRootValue
                    Me.intRootFound = True
                    RaiseEvent RootFound(Me, New EventArgs)
                    Exit Function
                End If
                If Math.Sign(fnew) <> Math.Sign(fm) Then
                    xl = xm
                    fl = fm
                    xh = intRootValue
                    fh = fnew
                ElseIf Math.Sign(fnew) <> Math.Sign(fl) Then
                    xh = intRootValue
                    fh = fnew
                ElseIf Math.Sign(fnew) <> Math.Sign(fh) Then
                    xl = intRootValue
                    fl = fnew
                Else
                    MessageManager.Send(Me, New MessageEventArgs("Never get here", MessageEventArgs.EMessageType.[Error]))
                    Exit Function
                End If
                If Math.Abs(xh - xl) <= intAccuracy Then
                    FRRidders = intRootValue
                    Me.intRootFound = True
                    RaiseEvent RootFound(Me, New EventArgs)
                    Exit Function
                End If
            Next
            MessageManager.Send(Me, New MessageEventArgs("Maximun number of iterations exceeded", MessageEventArgs.EMessageType.Warning))
        Else
            If fl = 0 Then
                FRRidders = X1
                Me.intRootFound = True
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            ElseIf fh = 0 Then
                FRRidders = X2
                Me.intRootFound = True
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            Else
                MessageManager.Send(Me, New MessageEventArgs("Roots must be bracketed", MessageEventArgs.EMessageType.[Error]))
                Exit Function
            End If
        End If
    End Function

#End Region

#Region "Bisection methods"

    Public Function FRbisection(ByVal Calc As OperSingleDelegate) As Single
        Return FRbisection(Me.intDefaultRange.Min, intDefaultRange.Max, Calc)
    End Function

    Public Function FRbisection(ByVal X1 As Single, ByVal X2 As Single, ByVal Calc As OperSingleDelegate) As Single
        Dim dx, f, fmid As Single
        Dim xmid As Single

        Me.intRootFound = False
        intIterations = 0
        f = Calc(X1)
        fmid = Calc(X2)
        If f * fmid >= 0 Then
            MessageManager.Send(Me, New MessageEventArgs("Roots must be bracketed for bisection Method", MessageEventArgs.EMessageType.[Error]))
            Exit Function
        End If
        If f < 0 Then
            dx = X2 - X1
            intRootValue = X1
        Else
            dx = X1 - X2
            intRootValue = X2
        End If

        For intIterations = 0 To NroIterations
            WaitStepping()

            dx = dx * 0.5
            xmid = intRootValue + dx
            fmid = Calc(xmid)

            If fmid <= 0 Then intRootValue = xmid
            If Math.Abs(dx) < intAccuracy Or fmid = 0 Then
                FRbisection = intRootValue
                Me.intRootFound = True
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            End If
        Next
    End Function

    Public Function FRbisection(ByVal g As Graphics, ByVal Calc As OperSingleDelegate) As Single
        Return FRbisection(g, Me.intDefaultRange.Min, intDefaultRange.Max, Calc)
    End Function

    'bisection method
    '1/8/03
    Public Function FRbisection(ByVal g As Graphics, ByVal X1 As Single, ByVal X2 As Single, ByVal Calc As OperSingleDelegate) As Single
        Dim dx, f, fmid As Single
        Dim xmid As Single

        Me.intRootFound = False
        intIterations = 0
        f = Calc(X1)
        fmid = Calc(X2)
        If f * fmid >= 0 Then
            MessageManager.Send(Me, New MessageEventArgs("Roots must be bracketed for bisection Method", MessageEventArgs.EMessageType.[Error]))
            Exit Function
        End If
        If f < 0 Then
            dx = X2 - X1
            intRootValue = X1
        Else
            dx = X1 - X2
            intRootValue = X2
        End If

        For intIterations = 0 To NroIterations
            WaitStepping()

            dx = dx * 0.5
            xmid = intRootValue + dx
            fmid = Calc(xmid)
            If intEnableAnimation Then
                DrawPointMethod(g, xmid, fmid, intIterations, Color.Green)
            End If

            If fmid <= 0 Then intRootValue = xmid
            If Math.Abs(dx) < intAccuracy Or fmid = 0 Then
                FRbisection = intRootValue
                Me.intRootFound = True
                If EnableAnimation Then
                    DrawPointMethod(g, intRootValue, fmid, intIterations, Color.Green)
                End If
                RaiseEvent RootFound(Me, New EventArgs)
                Exit Function
            End If
        Next
    End Function

#End Region

#End Region

#Region "Brackets Methods"

    ''' <summary>
    ''' Busca intervalos que contienen ra�ces en la funci�n dada, utilizando 
    ''' el rango y especificaciones internas de la instancia
    ''' </summary>
    ''' <param name="Ranges"></param>
    ''' <param name="Calc"></param>
    ''' <remarks></remarks>
    Public Sub BrackedIn(ByVal Ranges() As RangeF, ByVal Calc As OperSingleDelegate)
        Me.BrackedIn(Ranges, Me.intBracketSteps, Me.intBracketIterations, Calc)
    End Sub

    ''' <summary>
    ''' Given a function fx defined on the interval from x1-x2 subdivide the interval into n equally
    ''' spaced segments, and search for zero crossings of the function. nb is input as the maximum number
    ''' of roots sought, and is reset to the number of bracketing pairs xb1[1..nb], xb2[1..nb]
    ''' that are found.
    ''' retorna 1 si acota a la singularidad  
    ''' </summary>
    ''' <param name="Ranges"></param>
    ''' <param name="Steps"></param>
    ''' <param name="MaxIterations"></param>
    ''' <param name="Calc"></param>
    ''' <remarks></remarks>
    Public Sub BrackedIn(ByVal Ranges() As RangeF, _
                            ByVal Steps As Integer, _
                            ByVal MaxIterations As Integer, _
                            ByVal Calc As OperSingleDelegate)
        Dim j As Integer, dx As Single, nbb As Integer
        Dim x As Single, fp As Single, fc As Single

        nbb = 0
        dx = Ranges(0).dx / Steps
        x = Ranges(0).Min
        fp = Calc(x)
        For j = 1 To Steps
            x = x + dx
            fc = Calc(x)
            If fc * fp <= 0 Then
                ReDim Preserve ARanges(nbb)
                ARanges(nbb).Min = x - dx
                ARanges(nbb).Max = x
                nbb = nbb + 1
                If MaxIterations = nbb Then
                    Ranges = ARanges
                    Exit Sub
                End If
            End If
            fp = fc
        Next j
        Ranges = ARanges
        MaxIterations = nbb
    End Sub

    Public Function BrackedOut(ByVal R As RangeF, ByVal Calc As OperSingleDelegate) As Boolean
        Return BrackedOut(R.Min, R.Max, Calc)
    End Function

    ''' <summary>
    ''' Given a function func and an initial guessed range x1 to x2, the routine expands the range
    ''' geometrically until a root is bracketed by the returned values x1 and x2 (in which case zbrac
    ''' returns 1) or until the range becomes unacceptably large (in which case zbrac returns 0).
    ''' false si hay un error
    ''' </summary>
    ''' <param name="X1"></param>
    ''' <param name="X2"></param>
    ''' <param name="Calc"></param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function BrackedOut(ByVal X1 As Single, ByVal X2 As Single, ByVal Calc As OperSingleDelegate) As Boolean
        If X1 = X2 Then
            MessageManager.Send(Me, New MessageEventArgs("Bad Initial Range, Correct and try Again", MessageEventArgs.EMessageType.[Error]))
            Return False
        End If

        Dim j As Integer, f1 As Single, f2 As Single

        f1 = Calc(X1)
        f2 = Calc(X2)
        For j = 1 To Ntry
            If f1 * f2 < 0 Then
                ReDim ARanges(0)
                ARanges(0) = New RangeF(X1, X2)
                Return True
            End If
            If Math.Abs(f1) < Math.Abs(f2) Then
                X1 = X1 + Factor * (X1 - X2)
                f1 = Calc(X1)
            Else
                X2 = X2 + Factor * (X2 - X1)
                f2 = Calc(X2)
            End If
        Next j
        Return False
    End Function

#End Region

End Class

By viewing downloads associated with this article you agree to the Terms of Service and the article's licence.

If a file you wish to view isn't highlighted, and is a text file (not binary), please let us know and we'll add colourisation support for it.

License

This article, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)


Written By
Engineer Universidad Tecnológica Nacional
Argentina Argentina
This member has not yet provided a Biography. Assume it's interesting and varied, and probably something to do with programming.

Comments and Discussions