简单改了一下,问题有既没有给出数据,不知道目的,另外这是不是你写的,你要知道这里面需要
Text1.Text,Text2.Text,Text3.Text,Text4.Text,Text5.Text几个文本框用于输入数据
Text8.Text用于输出结果
还需要一个Command
Const pi = 3.1415927
Private Sub Command1_Click()
Dim d As Double, t As Double, f1 As Double, f2 As Double, f3 As Double, gg As Double, p1 As Double, p2 As Double, x1 As Double, x2 As Double
Dim rs(0 To 2) As Double, rsp(0 To 2) As Double
d = Val(Text1.Text)
t = Val(Text2.Text)
f1 = Val(Text3.Text)
f2 = Val(Text4.Text)
f3 = Val(Text5.Text)
For I = 0 To 2
rs(I) = 0
Next I
gg = t / d
p1 = 0.02
Call f1f2f3(gg, p1, rs())
Print gg, p1, rs(0), rs(1), rs(2)
x1 = rs(0) / rs(1) - f1 / f2
Do While True
p2 = p1 + 0.001
Call f1f2f3(gg, p2, rs())
x2 = rs(0) / rs(1) - f1 / f2
If x1 * x2 > 0 Then
p1 = p2
x1 = x2
If p2 > 0.05 Then
Text8.Text = "周波数データ异常"
Exit Sub
End If
Else
rsp(0) = (p1 + p2) / 2
Exit Do
End If
Loop
Text6.Text = rsp(0)
If f3 - f2 <= 0 Then
Text8.Text = "周波数f3异常"
Exit Sub
End If
p1 = rsp(0) - 0.05
If p1 < 0.02 Then p1 = 0.02
Call f1f2f3(gg, p1, rs())
x1 = rs(0) / rs(2) - f1 / f3
Do While True
p2 = p1 + 0.001
Call f1f2f3(gg, p2, rs())
x2 = rs(0) / rs(2) - f1 / f3
If x1 * x2 > 0 Then
p1 = p2
x1 = x2
If p2 > 0.5 Then
Text8.Text = "周波数f3异常"
Exit Sub
End If
Else: rsp(1) = (p1 + p2) / 2
Exit Do
End If
Loop
Text7.Text = rsp(1)
rsp2 = (rsp(0) + rsp(1)) / 2
Text8.Text = rsp(2)
End Sub
Private Sub f1f2f3(gg As Double, p As Double, f() As Double)
Dim fl As Double, y As Double, x(0 To 2) As Double, fg(0 To 2) As Double, a(0 To 2) As Double, b(0 To 2) As Double, c(0 To 2) As Double, g(0 To 2) As Double
fl = pi / 2 * Sqr(1 - p ^ 2)
y = 1
Call r3j0j1(y, x())
For I = 0 To 2
fg(I) = x(I) * Sqr(1 - p)
g(I) = pi / 2 / x(I)
Next I
y = 1 - p
Call r3j0j1(y, x())
For I = 0 To 2
c(I) = p * (x(I) ^ 2 / fg(I) ^ 2 - 1)
a(I) = x(I) ^ 2
b(I) = (fl / gg) ^ 2
f(I) = Sqr((a(I) + b(I)) ^ 2 - 4 * (1 - c(I)) * a(I) * b(I))
f(I) = (a(I) + b(I) - f(I)) / 2 / (1 - c(I))
f(I) = Sqr(f(I))
Next I
End Sub
Private Sub r3j0j1(y As Double, x() As Double)
Dim xx1 As Double, x0 As Double
x0 = 0
xx1 = 0.1
Call xj0j1y(y, xx1, x0)
x(0) = x0
Call xj0j1y(y, xx1, x0)
x(1) = x0
Call xj0j1y(y, xx1, x0)
x(2) = x0
End Sub
Private Sub xj0j1y(y As Double, xx1 As Double, x As Double)
Dim dx As Double, xx As Double, bj0 As Double, bj1 As Double, y1 As Double, y2 As Double
dx = 0.1
bj0 = 0
bj1 = 0
Call j0j1(xx1, bj0, bj1)
y1 = xx1 * bj0 - bj1 * y
Do While True
xx = xx1 + dx
Call j0j1(xx, bj0, bj1)
y2 = xx * bj0 - bj1 * y
If y1 * y2 > 0 Then
y1 = y2
xx1 = xx
Else
If dx < 0.0001 Then Exit Do Else: dx = dx / 10
End If
Loop
x = (xx + xx1) / 2
xx1 = xx
End Sub
Private Sub j0j1(x As Double, z0 As Double, z1 As Double)
Dim z2 As Double
z2 = 1
z0 = z2
For k = 1 To 500
z2 = z2 * (-1) / k ^ 2 * x ^ 2 / 4
z0 = z0 + z2
Next k
z2 = x / 2
z1 = z2
For k = 1 To 500
z2 = z2 * (-1) / k / (k + 1) * x ^ 2 / 4
z1 = z1 + z2
Next k
End Sub
jlf629的修改可行。
楼主的代码莫非是来自日本人的?
看得出写代码的人思路清晰,但是可读性差,
没有注释。