Visual Basic Forum for Visual Basic Programmers VB

[mt_reilly]

This nonlinear least squares algorithm is specifically used to fit a data sample to the 5-parameter equation f(a)=A-Bexp(-a(1+bx)(x-x0)^2). The function and it's derivatives will be noticable in the software. The function can obviously be replaced by any other function. Good fiurst guesses are essential. The matrix equation is solved by the previously posted Guassain elimination routine.
Good luck...

[vb:1:b63c981e4e]Sub KinLevMar(BigA As Double, b As Double, alpha As Double, beta As Double, xbar As Double, n As Integer, kk As Integer)

Dim Lam, AbsErr As Double 'Used as LevMar parameters
Dim i, j, z, k, L, p, Q, Iters As Integer 'Mostly obvious
Dim Dela(), tempa(), mij, VecTemp() As Double
Dim Aa(), Be(), f, DelX, temp, m(), t() As Double 'LevMar matrix and vector values. a(5) will become the charcerization constants for each SPR curve.
Dim Chi2, Chi2p, sum As Double 'The Chi^2 values, using a weighting value "sigma" of 1.0. The first couple of Chi^2 values
'can exceed 10^100, therefore justifying the double data type to avoid errors.
'Error handling could be another means of addressing this problem.
Dim test As Single
Q = 5
ReDim Dela(Q)
ReDim tempa(Q)
ReDim VecTemp(Q + 1)
ReDim Aa(Q)
ReDim Be(Q)
ReDim m(Q, Q + 1)
ReDim t(Q)

'Const tol = 0.00000001
'Const M = 1 '?

On Error GoTo Errorcheck
Iters = 0
Aa(1) = BigA
Aa(2) = b
Aa(3) = alpha
Aa(4) = beta
Aa(5) = xbar
Chi2 = 0
For i = 0 To (RightMax(kk) - LeftMax(kk)) / n
j = LeftMax(kk) + i * n
temp = Aa(1) - Aa(2) * Exp(-Aa(3) * (1 + Aa(4) * j) * (j - Aa(5)) ^ 2)
Chi2 = Chi2 + (ArrayTemp(kk, j) - temp) ^ 2
Next i
'test = Chi2
Lam = 0.01
AbsErr = 1
While AbsErr > LMTol
For i = 1 To Q
For j = 1 To Q + 1
m(i, j) = 0
Next j
Be(i) = 0
Next i
For i = 0 To (RightMax(kk) - LeftMax(kk)) / n
j = LeftMax(kk) + i * n
DelX = j - Aa(5)
temp = Exp(-Aa(3) * (1 + Aa(4) * j) * DelX ^ 2)
t(1) = 1
t(2) = -temp
t(3) = Aa(2) * temp * (1 + Aa(4) * j) * DelX ^ 2
t(4) = Aa(2) * temp * Aa(3) * j * DelX ^ 2
t(5) = -2 * Aa(2) * temp * (1 + Aa(4) * j) * Aa(3) * DelX
For z = 1 To Q
For k = z To Q
m(z, k) = m(z, k) + t(z) * t(k)
Next k
Be(z) = Be(z) + (ArrayTemp(kk, j) - (Aa(1) - Aa(2) * temp)) * t(z)
Next z
Next i
'The matrix of differentials, M, is symmetric
For i = 2 To Q
For j = 1 To i - 1
m(i, j) = m(j, i)
'test = m(i, j)
Next j
Next i
'The weighting "trick" of the LevMar algorithm plus tacking on the RHS to create an augmented matrix.
For i = 1 To Q
m(i, i) = m(i, i) * (1 + Lam)
m(i, Q + 1) = Be(i)
Next i
'For i = 1 To Q
' For j = i To Q + 1
' test = m(i, j)
' Next j
'Next i
'The following algorithm is Gaussian elimination with backward substitution used to solve the matrrix equation M*dela=b
'{-------------------------------------------------------
'Creates an upper diagonal matrix.
For i = 1 To Q - 1
k = 1
While k <= Q
'test = m(i, k)
If m(i, k) = 0 Then
p = k
k = Q + 1
Else
k = k + 1
End If
Wend
If p = i Then
For L = 1 To Q + 1
VecTemp(L) = m(p, L)
m(p, L) = m(p + 1, L)
m(p + 1, L) = VecTemp(L)
'test = L
Next L
End If
For j = i + 1 To Q
mij = m(j, i) / m(i, i)
'test = mij
For L = 1 To Q + 1
m(j, L) = m(j, L) - mij * m(i, L)
Next L
Next j
Next i
'Beginning of backward substitution
Dela(Q) = m(Q, Q + 1) / m(Q, Q)
For i = 1 To Q - 1
j = Q - i
sum = 0
For L = j + 1 To Q
sum = sum + m(j, L) * Dela(L)
Next L
Dela(j) = (m(j, Q + 1) - sum) / m(j, j)
'test = Dela(j)
Next i
'The vector "Dela" is now known.
For i = 1 To Q
tempa(i) = Dela(i) + Aa(i)
Next i
Chi2p = 0
For i = 0 To (RightMax(kk) - LeftMax(kk)) / n
j = LeftMax(kk) + i * n
temp = tempa(1) - tempa(2) * Exp(-tempa(3) * (1 + tempa(4) * j) * (j - tempa(5)) ^ 2)
Chi2p = Chi2p + (ArrayTemp(kk, j) - temp) ^ 2
Next i
'test = Chi2p
If Chi2p < Chi2 Then
AbsErr = (Chi2 - Chi2p) / Chi2
For i = 1 To Q
Aa(i) = tempa(i)
'test = aa(i)
Next i
Lam = Lam / 10
Chi2 = Chi2p
Else
Lam = Lam * 10
End If
'Chi2 = Chi2p
Iters = Iters + 1
If Iters > 300 Then
Form5.Visible = True
Stop_The_Run = True
GoTo 10
End If
Wend
'Dumps the "aa" vector out into the global variable "A" used elsewhere.
A(1, kk) = Aa(1)
A(2, kk) = Aa(2)
A(3, kk) = Aa(3)
'test = Aa(3)
A(4, kk) = Aa(4)
'test = Aa(4)
A(5, kk) = Aa(5)
XValue(kk) = -(-Aa(5) + CentralSpot) * ScaleFactor

Errorcheck:
If Err.Number = 6 Then
A(1, kk) = A(1, kk)
A(2, kk) = A(2, kk)
A(3, kk) = A(3, kk)
A(4, kk) = A(4, kk)
A(5, kk) = A(5, kk)
XValue(kk) = -(CentralSpot - A(5, kk)) * ScaleFactor
End If[/vb:1:b63c981e4e]

[Andir]

:shock: Heck, I'll comment on it even thought it's gonna make me sound retarded.

Nice code. I'm not sure if I'll ever use it, but it's cool nonetheless. I used to do things with QB like this just for the fun(?) of it.

One suggestion though, can you drop a [vb ] tag in front and a [/vb ] tag behind the code?
_________________
If you happen to see little people sitting on your desk...don't tell anyone or they might think your crazy too.