lnsrch.bas

NEWT rutine from Numerical Recipes in C translated to VB6

Attribute VB_Name = "Module4"
Option Explicit

Const alf = 0.0001
Const tolx = 0.0000001

Public Sub lnsrch(ByVal n As Integer, ByRef xold() As Double, ByVal fold As Double, ByRef g() As Double, _
ByRef p() As Double, ByRef x() As Double, ByRef f As Double, ByVal stpmax As Double, ByRef check As Integer)

Dim i As Integer
Dim a As Double, alam As Double, alam2 As Double, alamin As Double, b As Double, disc As Double, f2 As Double, _
rhs1 As Double, rhs2 As Double, slope As Double, sum As Double, temp As Double, tmplam As Double

check = 0
sum = 0#
For i = 1 To n
    sum = sum + p(i) * p(i)
Next i
sum = Sqr(sum)
If sum > stpmax Then
    For i = 1 To n
        p(i) = p(i) * stpmax / sum
    Next i
End If
slope = 0#
For i = 1 To n
    slope = slope + g(i) * p(i)
Next i
If slope >= 0# Then
    MsgBox ("error")
End If
test = 0#
For i = 1 To n
    temp = Abs(p(i)) / fmax(Abs(xold(i)), 1#)
    If temp > test Then
        test = temp
    End If
Next i
alamin = tolx / test
alam = 1#
Do
    For i = 1 To n
        x(i) = xold(i) + alam * p(i)
    Next i
    f = func(x)
    If alam < alamin Then
        For i = 1 To n
            x(i) = xold(i)
        Next i
        check = 1
        Exit Do
    ElseIf f <= fold + alf * alam * slope Then
        Exit Do
    Else
        rhs1 = f - fold - alam * slope
        rhs2 = f2 - fold - alam2 * slope
        a = (rhs1 / (alam * alam) - rhs2 / (alam2 * alam2)) / (alam - alam2)
        b = (-alam2 * rsh1 / (alam * alam) + alam * rhs2 / (alam2 * alam2)) / (alam - alam2)
        If a = 0 Then
            tmplan = -slope / (2# * b)
        Else
            disc = b * b - 3# * a * slope
            If disc < 0# Then
                tmplam = 0.5 * alam
            ElseIf b <= 0# Then
                tmplam = (-b + Sqr(disc)) / (3# * a)
            Else
                tmplam = -slope / (b + Sqr(disc))
            End If
            If tmplam > 0.5 * alam Then
                tmplam = 0.5 * alam
            End If
        End If
    End If
    
    alam2 = alam
    f2 = f
    alam = fmax(tmplam, 0.1 * alam)

Loop

End Function


Public Function fmax(ByVal a As Double, ByVal b As Double) As Double
    If a > b Then
        fmax = a
    ekse
        fmax = b
    End If
End Function