📄 非线性方程组.frm
字号:
VERSION 5.00
Begin VB.Form Form1
Caption = "牛顿迭代法解三元非线性方程组"
ClientHeight = 3735
ClientLeft = 60
ClientTop = 450
ClientWidth = 5700
LinkTopic = "Form1"
ScaleHeight = 3735
ScaleWidth = 5700
StartUpPosition = 2 '屏幕中心
Begin VB.TextBox Text3
Height = 375
Left = 4080
TabIndex = 6
Text = "100"
Top = 1920
Width = 1095
End
Begin VB.TextBox Text2
Height = 375
Left = 2400
TabIndex = 4
Text = "50"
Top = 1920
Width = 1095
End
Begin VB.TextBox Text1
Height = 375
Left = 720
TabIndex = 0
Text = "10"
Top = 1920
Width = 1095
End
Begin VB.CommandButton Command2
Caption = "END"
Height = 615
Left = 2880
TabIndex = 2
Top = 2760
Width = 1935
End
Begin VB.CommandButton Command1
Caption = "OK"
Height = 615
Left = 720
TabIndex = 1
Top = 2760
Width = 1935
End
Begin VB.Label Label3
Caption = "x3"
Height = 255
Left = 3720
TabIndex = 7
Top = 2040
Width = 255
End
Begin VB.Label Label2
Caption = "x2"
Height = 255
Left = 2040
TabIndex = 5
Top = 2040
Width = 255
End
Begin VB.Label Label1
Caption = "x1"
Height = 255
Left = 360
TabIndex = 3
Top = 2040
Width = 255
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public x1 As Double, x2 As Double, x3 As Double, Jingdu As Double, x0 As Double, x0p As Double
Private Sub Command1_Click()
'PROGRAM D10R13
'Driver for routine MNEWT
Cls
Dim fso: Dim File1 '--------------------------------------------------------创建*.txt文件
Dim Mytxt As String, j As Long
Mytxt = "C:\Documents and Settings\pht\Desktop\Random.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set File1 = fso.CreateTextFile(Mytxt, True)
File1.Close
Open Mytxt For Append As #1 '---------------------------------------打开txt文件
Dim NTRIAL As Long
NTRIAL = 100000 '最大迭代次数
TOLX = 0.0001 '迭代收敛的最小量
FunN = 3 '方程个数
TOLF = 0.0001 '迭代收敛的最小量
'NP = 15 '
Dim x(15), ALPHA(15, 15), BETA(15)
Print #1, "Starting vector number"; Format$(K, "#") ' OK
Print Tab(5), "Starting vector number"; Format$(K, "#") ' OK
x1 = Val(Text1)
x2 = Val(Text2)
x3 = Val(Text3)
x(1) = x1
x(2) = x2
x(3) = x3
For i = 1 To 3
Print #1, " X("; Format$(i, "#"); ")= "; Format$(x(i), "0.#0") ' OK
Print Tab(5), "X("; Format$(i, "#"); ")= "; Format$(x(i), "0.#0") ' OK
Next i
For j = 1 To NTRIAL
Call MNEWT(1, x(), FunN, TOLX, TOLF)
Call USRFUN(x(), ALPHA(), BETA())
Jingdu = 0.001
If (Abs(BETA(1)) <= Jingdu) And (Abs(BETA(2)) <= Jingdu) And (Abs(BETA(3)) <= Jingdu) And (Abs(BETA(4)) <= Jingdu) Then
Print Tab(5), "----------------------------------------" ' OK
Print #1, "I X(I) F" & Str(j) ' OK
Print Tab(5), "I X(I) F" & Str(j) ' OK
For i = 1 To FunN
Print #1, Format$(i, "#"), Format$(x(i), "0.####00E+00"), Format$(-BETA(i), "0.#####0E+00") ' OK
Print Tab(5), Format$(i, "#"), Format$(x(i), "0.####00E+00"), Format$(-BETA(i), "0.#####0E+00") ' OK
Next i
Exit For
End If
Next j
Close #1
End Sub
Sub USRFUN(x(), ALPHA(), BETA())
'NP = 15
x0p = 0.0001
'---------------------对各个未知数求X0处的偏导数
x0 = x(1)
ALPHA(1, 1) = (Function1((x0 + x0p), x2, x3) - Function1((x0 - x0p), x2, x3)) / (2 * x0p)
x0 = x(2)
ALPHA(1, 2) = (Function1(x1, (x0 + x0p), x3) - Function1(x1, (x0 - x0p), x3)) / (2 * x0p)
x0 = x(3)
ALPHA(1, 3) = (Function1(x1, x2, (x0 + x0p)) - Function1(x1, x2, (x0 - x0p))) / (2 * x0p)
x0 = x(1)
ALPHA(2, 1) = (Function2((x0 + x0p), x2, x3) - Function2((x0 - x0p), x2, x3)) / (2 * x0p)
x0 = x(2)
ALPHA(2, 2) = (Function2(x1, (x0 + x0p), x3) - Function2(x1, (x0 - x0p), x3)) / (2 * x0p)
x0 = x(3)
ALPHA(2, 3) = (Function2(x1, x2, (x0 + x0p)) - Function2(x1, x2, (x0 - x0p))) / (2 * x0p)
x0 = x(1)
ALPHA(3, 1) = (Function3((x0 + x0p), x2, x3) - Function3((x0 - x0p), x2, x3)) / (2 * x0p)
x0 = x(2)
ALPHA(3, 2) = (Function3(x1, (x0 + x0p), x3) - Function3(x1, (x0 - x0p), x3)) / (2 * x0p)
x0 = x(3)
ALPHA(3, 3) = (Function3(x1, x2, (x0 + x0p)) - Function3(x1, x2, (x0 - x0p))) / (2 * x0p)
x1 = x(1)
x2 = x(2)
x3 = x(3)
BETA(1) = -Function1(x1, x2, x3)
BETA(2) = -Function2(x1, x2, x3)
BETA(3) = -Function3(x1, x2, x3)
End Sub
Public Function Function1(x1, x2, x3)
Function1 = x1 ^ 3 + x2 ^ 2 - 1 / x3 - 589
End Function
Public Function Function2(x1, x2, x3)
Function2 = 3 * x1 + x2 - 3 * x3 ^ 3 + 25
End Function
Public Function Function3(x1, x2, x3)
Function3 = 2 / x1 ^ 2 + 2 * x2 - x3 * 20
End Function
Sub MNEWT(NTRIAL, x(), FunN, TOLX, TOLF)
Dim ALPHA(15, 15), BETA(15), INDX(15)
For K = 1 To NTRIAL
Call USRFUN(x(), ALPHA(), BETA())
ERRF = 0#
For i = 1 To FunN
ERRF = ERRF + Abs(BETA(i))
Next i
If ERRF <= TOLF Then Exit Sub
Call LUDCMP(ALPHA(), FunN, INDX(), D)
Call LUBKSB(ALPHA(), FunN, INDX(), BETA())
ERRX = 0#
For i = 1 To FunN
ERRX = ERRX + Abs(BETA(i))
x(i) = x(i) + BETA(i)
Next i
If ERRX <= TOLX Then Exit Sub
Next K
End Sub
Sub LUDCMP(A(), FunN, INDX(), D)
NMAX = 100
TINY = 1E-20
Dim VV(100)
D = 1#
For i = 1 To FunN
AAMAX = 0#
For j = 1 To FunN
If Abs(A(i, j)) > AAMAX Then AAMAX = Abs(A(i, j))
Next j
If AAMAX = 0# Then Print "Singular matrix."
VV(i) = 1# / AAMAX
Next i
For j = 1 To FunN
If j > 1 Then
For i = 1 To j - 1
Sum = A(i, j)
If i > 1 Then
For K = 1 To i - 1
Sum = Sum - A(i, K) * A(K, j)
Next K
A(i, j) = Sum
End If
Next i
End If
AAMAX = 0#
For i = j To FunN
Sum = A(i, j)
If j > 1 Then
For K = 1 To j - 1
Sum = Sum - A(i, K) * A(K, j)
Next K
A(i, j) = Sum
End If
DUM = VV(i) * Abs(Sum)
If DUM >= AAMAX Then
IMAX = i
AAMAX = DUM
End If
Next i
If j <> IMAX Then
For K = 1 To FunN
DUM = A(IMAX, K)
A(IMAX, K) = A(j, K)
A(j, K) = DUM
Next K
D = -D
VV(IMAX) = VV(j)
End If
INDX(j) = IMAX
If j <> FunN Then
If A(j, j) = 0# Then A(j, j) = TINY
DUM = 1# / A(j, j)
For i = j + 1 To FunN
A(i, j) = A(i, j) * DUM
Next i
End If
Next j
If A(FunN, FunN) = 0# Then A(FunN, FunN) = TINY
End Sub
Sub LUBKSB(A(), FunN, INDX(), B())
II = 0
For i = 1 To FunN
LL = INDX(i)
Sum = B(LL)
B(LL) = B(i)
If II <> 0 Then
For j = II To i - 1
Sum = Sum - A(i, j) * B(j)
Next j
ElseIf Sum <> 0# Then
II = i
End If
B(i) = Sum
Next i
For i = FunN To 1 Step -1
Sum = B(i)
If i < FunN Then
For j = i + 1 To FunN
Sum = Sum - A(i, j) * B(j)
Next j
End If
B(i) = Sum / A(i, i)
Next i
End Sub
Private Sub Command2_Click()
End
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -