实验一
1.
Private Function f(x!)
f=x^3-2*x^2-4*x-7
End Function
Private Sub form_click()
Dim a!, b!, x!, c!
a = 3: b = 4
Do While Abs(b - a) > 0.00001
c = (a + b) / 2
If f(c) = 0 Then
Exit Do
Else
If f(a) * f(c) < 0 Then
b = c
Else
a = c
End If
End If
Loop
Print c
End Sub
1.(对1
进行修改后,要求输入隔根区间的上下界就能求出根的程序)
Private Function f(x!)
f = x ^ 3 - 2 * x ^ 2 - 4 * x - 7
End Function
Private Function g(a!, b!)
Dim y!
Do While Abs(b - a) > 0.00001
y = (a + b) / 2
If f(y) = 0 Then
Exit Do
Else
If f(a) * f(y) < 0 Then
b = y
Else
a = y
End If
End If
Loop
g = y
End Function
Private Sub form_click()
Dim a!, b!
a = InputBox("输入隔根区间上界")
b = InputBox("输入隔根区间下界")
c = g(a, b)
Print c
End Sub
2.
Private Function f(x!)
f = x ^ 4 - 5 * x ^ 2 + x + 2
End Function
Private Sub form_click()
Dim a!, b!, c!, h!, x!, i%, j%, p(0 To 4) As Single, q(0 To 4) As Single
a = -6: b = 6: h = 0.3
x = a
i = 0
For j = 0 To 100
If f(x) * f(x + h) <= 0 Then
p(i) = x
q(i) = x + h
Print "["; p(i); ","; q(i); "]"
i = i + 1
End If
j = j + 1
x = x + h
Next
Print "实根分别为:"
For i = 0 To 3
a = p(i)
b = q(i)
Do While Abs(b - a) > 0.00001
c = (a + b) / 2
If f(c) = 0 Then
Exit Do
Else
If f(a) * f(c) < 0 Then
b = c
Else
a = c
End If
End If
Loop
Print "root="; c
Next
End Sub
(h 取值 使得划分的隔根区间避开根所在得区间上下界)
3.
Private Sub form_click()
Dim a(0 To 20) As Single, y As Single, x As Single
Dim i As Integer, n As Integer
n = InputBox("输入多项式的次数")
For i = 0 To n
a(i) = InputBox("输入a(" & Str(i) & ")")
Next i
x = InputBox("输入x")
y = a(n)
For i = 1 To n
y = y * x + a(n - i)
Next i
Print y
End Sub
实验二
1.(1)
Private Sub form_click()
Dim x0 As Single, x1 As Single
Dim M As Integer
x1 = 2: M = 5: k = 1
Do
x0 = x1
x1 = x0 - (x0 ^ 3 - x0 ^ 2 - 2 * x0 - 3) / (3 * x0 ^ 2 - 2 * x0 - 2)
k = k + 1
Loop While k < M And Abs(x1 - x0) > 0.00001
Print x1
End Sub
(2)
Private Sub form_click()
Dim x0 As Single, x1 As Single
Dim M As Integer
x1 = 1: M = 6: k = 1
Do
x0 = x1
x1 = x0 - (x0 - Sin(x0) - 0.5) / (1 - Cos(x0))
k = k + 1
Loop While k < M And Abs(x1 - x0) > 0.00001
Print x1
End Sub
2
Private Sub form_click()
Dim x0 As Single, x1 As Single
Dim a As Integer
a = InputBox("输入a")
If a = 0 Then
Print "a的立方根=0"
End
End If
x1 = a
Do
x0 = x1
x1 = x0 - (x0 ^ 3 - a) / (3 * x0 ^ 2)
Loop While Abs(x1 - x0) > 0.000005
Print "a的立方根为:"; x1
End Sub
3.
Private Sub form_click()
Dim x0 As Single, x1 As Single, x2 As Single
Dim M As Integer
x1 = 0: x2 = 1: M = 6: k = 1
Do
x0 = x1
x1 = x2
x2 = x1 - (f(x1) * (x1 - x0) / (f(x1) - f(x0)))
k = k + 1
Loop While k < M And Abs(x1 - x0) > 0.0001
Print x1
End Sub
Private Function f(x!)
f = x + Sin(x) - 1
End Function
4.
Private Sub form_click()
Dim x#, x1#
x1 = 1
Do
x = x1
x1 = x - (x - Exp(-x)) / (1 + Exp(-x))
Loop While Abs(x1 - x) >= 10 ^ (-5)
Print "a的立方根为:"; x1
End Sub
实验三
1.按列选主元德高斯消去法解线性方程组的通用程序
Option Base 1
Private Sub Form_Click()
Dim a(1 To 3, 1 To 4) As Single, t#, i!, j!, k!, r!, l#, x(1 To 3) As Single
For i = 1 To 3
For j = 1 To 4
a(i, j) = InputBox("输入一个数")
Print a(i, j);
Next j
Print
Next i
For k = 1 To 2
r = k
For i = k + 1 To 3
If Abs(a(i, k)) > Abs(a(r, k)) Then r = i
Next i
If r <> k Then
For i = 1 To 4
t = a(k, i)
a(k, i) = a(r, i)
a(r, i) = t
Next i
End If
For i = k + 1 To 3
l = a(i, k) / a(k, k)
For j = k + 1 To 4
a(i, j) = a(i, j) - l * a(k, j)
Next j
Next i
Next k
For k = 3 To 1 Step -1
s = 0
For j = k + 1 To 3
s = s + a(k, j) * x(j)
Next j
x(k) = (a(k, 4) - s) / a(k, k)
Next k
For i = 1 To 3
Print x(i),
Next i
End Sub
3.用LU分解法解线性方程组
Private Sub form_click()
Const n = 4
Dim a(1 To n, 1 To n) As Single, l(1 To n, 1 To n) As Single, u(1 To n, 1 To n) As Single
Dim x(1 To n) As Single, y(1 To n) As Single, b(1 To n) As Single, s#, i!, j!, k!, r!
For i = 1 To n
For j = 1 To n
a(i, j) = InputBox("输入a数组")
Print a(i, j),
Next j
Print
Next i
For i = 1 To n
b(i) = InputBox("输入b数组")
Print b(i),
Next i
Print
For k = 1 To n
For j = k To n
s = 0
For r = 1 To k - 1
s = s + l(k, r) * u(r, j)
Next r
u(k, j) = a(k, j) - s
Next j
For i = k + 1 To n
s = 0
For r = 1 To k - 1
s = s + l(i, r) * u(r, k)
Next r
l(i, k) = (a(i, k) - s) / u(k, k)
Next i
Next k
For i = 1 To n
s = 0
For k = 1 To i - 1
s = s + l(i, k) * y(k)
Next k
y(i) = b(i) - s
Next i
For i = n To 1 Step -1
s = 0
For k = i + 1 To n
s = s + (u(i, k) * x(k))
Next k
x(i) = (y(i) - s) / u(i, i)
Next i
For i = 1 To n
Print x(i)
Next i
End Sub
实验四
5.
雅克比迭代
Option Base 1
Function cha(x!(), y!()) As Single
Dim z As Single, i As Single, k As Integer
n = 3
z = Abs(x(1) - y(1))
For i = 2 To n
If z < Abs(x(i) - y(i)) Then z = Abs(x(i) - y(i))
Next i
cha = z
End Function
Private Sub form_click()
Dim a1, x(3) As Single, y(3) As Single
Dim t As Single, s As Single, a(3, 3) As Single
Dim i As Integer, j As Integer, k As Integer, n As Integer
n = 3
a1 = Array(10, -2, -1, -2, 10, -1, -1, -2, 5)
b = Array(3, 15, 10)
For i = 1 To n: y(i) = 0: Next i
k = 1
For i = 1 To 3
For j = 1 To 3
a(i, j) = a1(k)
k = k + 1
Next j, i
For k = 1 To 30
For i = 1 To n
x(i) = y(i)
Next i
For i = 1 To n
t = 0
For j = 1 To n
If i <> j Then t = t + a(i, j) * x(j)
Next j
y(i) = (b(i) - t) / a(i, i)
Next i
If cha(x, y) < 0.000000000001 Then
Print k;
For i = 1 To n
Print y(i);
Next i
Exit For
End If
Next k
If k > 30 Then Print "发散"
End Sub
运行结果“19 1 2 3”
Function函数是用来求(max|y(i)-x(i)|)
高斯—赛德尔迭代
Option Base 1
Function cha(x!(), y!()) As Single
Dim z As Single, i As Single, k As Integer
n = 3
z = Abs(x(1) - y(1))
For i = 2 To n
If z < Abs(x(i) - y(i)) Then z = Abs(x(i) - y(i))
Next i
cha = z
End Function
Private Sub form_click()
Dim a1, x(3) As Single, y(3) As Single
Dim t As Single, s As Single, a(3, 3) As Single
Dim i As Integer, j As Integer, k As Integer, n As Integer
n = 3
a1 = Array(10, -2, -1, -2, 10, -1, -1, -2, 5)
b = Array(3, 15, 10)
For i = 1 To n: x(i) = 0: Next i
k = 1
For i = 1 To 3
For j = 1 To 3
a(i, j) = a1(k)
k = k + 1
Next j, i
For k = 1 To 30
For i = 1 To n
y(i) = x(i)
Next i
For i = 1 To n
t = 0
For j = 1 To n
If i <> j Then t = t + a(i, j) * x(j)
Next j
x(i) = (b(i) - t) / a(i, i)
Next i
If cha(x, y) < 0.000000000001 Then
Print k;
For i = 1 To n
Print x(i);
Next i
Exit For
End If
Next k
If k > 30 Then Print "发散"
End Sub
运行结果“11 1 2 3”
注意比较雅克比迭代、高斯—赛德尔迭代程序中“涂灰部分的区别”
实验五
3.拉格朗日插值多项式
Private Sub Form_click()
Const n = 3
Dim p#, s!
Dim x, y As Variant
x = Array(1, 2, 3, 4)
y = Array(4, 5, 14, 37)
t = InputBox("input t")
p = 0
For k = 0 To n
s = 1
For i = 0 To n
If i <> k Then
s = s * ((t - x(i)) / (x(k) - x(i)))
End If
Next i
p = p + y(k) * s
Next k
Print p
End Sub
运行结果(t=3.5):23.375
Vb牛顿基本插值公式程序
Private Sub Form_click()
Const n = 5
Dim x(n) As Single, y(n) As Single, t#, p#, s#
For i = 0 To n
x(i) = InputBox("input x" & Trim(Str(i)))
y(i) = InputBox("input y" & Trim(Str(i)))
Next i
t = InputBox("input t")
For k = 1 To n
For i = n To k Step -1
y(i) = (y(i) - y(i - 1)) / (x(i) - x(i - k))
Next i
Next k
p = y(0)
h = 1
For i = 1 To n
h = h * (t - x(i - 1))
p = p + h * y(i)
Next i
Print "p="; p
End Sub
i
1
2
3
4
5
6
x(i)
1
3
4
5
2
6
Y(i)
2
10
17
26
5
37
运行结果(t=3.5):13.25
实验六
曲线拟合
Private Sub form_click()
Dim l#, m#, n#, i%, j%, k%, t1#
Dim x As Variant, y As Variant
n = 7
m = 2
x = Array(0, 1, 2, 3, 4, 5, 6, 7)
y = Array(0, 5, 3, 2, 1, 2, 4, 7)
ReDim a(0 To m, 0 To m + 1) As Single, t(n) As Single
For i = 0 To m
s = 0
For k = 1 To n
s = s + (x(k) ^ i) * y(k)
Next k
a(i, m + 1) = s
For j = 0 To m
s = 0
For k = 1 To n
s = s + (x(k)) ^ (i + j)
Next k
a(i, j) = s
Next j
Next i
For i = 0 To m
For j = 0 To m + 1
Print a(i, j),
Next j
Print
Next i
For k = 0 To m
r = k
For i = k + 1 To m
If Abs(a(i, k)) > Abs(a(r, k)) Then
r = i
End If
Next i
If r <> k Then
For i = 0 To m + 1
t1 = a(k, i)
a(k, i) = a(r, i)
a(r, i) = t1
Next i
End If
l = 1
For i = k + 1 To m
l = a(i, k) / a(k, k)
For j = k + 1 To m + 1
a(i, j) = a(i, j) - l * a(k, j)
Next j
Next i
Next k
For k = m To 0 Step -1
s = 0
For j = k + 1 To m
s = s + a(k, j) * t(j) 注意此处
Next j
t(k) = (a(k, m + 1) - s) / a(k, k)
Next k
Print "y="; t(0);
For i = 1 To m
If t(i) >= 0 Then Print "+";
Print t(i); "*x^"; i;
Next i
End Sub
运行结果
实验七
1.编制变步长的梯形公式求数值积分的通用程序,试算积分为【积分下限为0,积分上限为1,被积函数为:1/(1+x*x)】当精度要求为0.00001时,计算结果为0.7853956.
Private Sub form_click()
Dim a As Single, b As Single, eps As Single, s As Single
Dim x As Single, h As Single, t1 As Single, t As Single
a = InputBox("输入积分下限a")
b = InputBox("输入积分上限b")
eps = InputBox("输入精度要求eps")
h = b - a
t2 = (h / 2) * (f(a) + f(b))
Do
t1 = t2
s = 0
For x = a + h / 2 To b Step h
s = s + f(x)
Next x
t2 = t1 / 2 + (h / 2) * s
h = h / 2
Loop While Abs(t1 - t2) > eps
Print "积分的近似值:"; t2
End Sub
Function f(x As Single) As Single
f = 1 / (1 + x * x)
End Function
2.
复合Simpson公式求积分的通用程序,设N=8,试算例题为
积分下限为0,积分上限为1,被积函数为:1/(1+x*x),运行结果为0.785398
Private Sub form_click()
Dim a As Single, b As Single, eps As Single, s As Single
Dim x As Single, h As Single, N As Single
a = InputBox("输入积分下限a")
b = InputBox("输入积分上限b")
N = 8
h = (b - a) / (2 * N)
s = f(a)
x = a
For i = 1 To N
x = x + h
s = s + 4 * f(x)
x = x + h
s = s + 2 * f(x)
Next i
s = (h / 3) * (s - f(b))
Print s
End Sub
Function f(x As Single) As Single
f = 1 / (1 + x * x)
End Function
3.编制龙贝格积分公式求数值积分的通用程序,试算积分为【积分下限为0,积分上限为1,被积函数为:x * x * Exp(x)】当精度要求为0.00001时,计算结果为0.7182818
Function f!(x!)
f = x * x * Exp(x)
End Function
Private Sub form_click()
Dim a!, b!, h!, eps!, s!, t!(10, 10)
Dim i%, j%, k%
a = InputBox("输入积分下限")
b = InputBox("输入积分上限")
eps = InputBox("输入精度要求")
k = 0
h = b - a
t(0, 0) = (h / 2) * (f(a) + f(b))
Do
k = k + 1
h = h / 2
s = 0
For j = 1 To 2 ^ (k - 1)
s = s + f(a + (2 * j - 1) * h)
Next j
t(k, 0) = t(k - 1, 0) / 2 + h * s
For i = 1 To k
j = k - i
t(j, i) = (4 ^ i * t(j + 1, i - 1) - t(j, i - 1)) / (4 ^ i - 1)
Next i
Loop Until Abs(t(0, k) - t(0, k - 1)) < eps
Print "I="; t(0, k)
End Sub
PAGE
1