[交流] [已应助，谢谢kill]vb

Option Explicit

Private Sub Command1_Click()
    Dim m As Integer, n As Integer
    Dim s As String, i As Integer
    m = 1
    ReDim x(m) As Double
    '求解
    n = NLBisectRoot(m, 1.61, 4.68, 1, x, 0.000001)
    s = " "
    For i = 0 To n
        If x(i) <> 0 Then s = s + "x(" & i & " = " & x(i) & Chr$(13)
    Next i
    MsgBox "共求得 " & n & " 个实根，分别为：" & Chr$(13) & Chr$(13) & s
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：NLModule.bas
'  函数名：NLBisectRoot
'  功能：  使用对分法求解非线性方程的实根，本函数需要调用计算方程左端函数f(x)值的函数Func，其形式为：
'          Function Func(x As Double) As Double
'  参数    m    - Integer型变量，在[a, b]内实根个数的预估值
'          a    - Double型变量，求根区间的左端点
'          b    - Double型变量，求根区间的右端点
'          h    - Double型变量，搜索求根时采用的步长
'          x    - Double型一维数组，长度为m。返回在区间[a, b]内搜索到的实根，实根个数由函数值返回
'         eps   - Double型变量，精度控制参数
'  返回值：Integer型，求得的实根的个数
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 待求解的方程的函数
Private Function Func(x As Double) As Double
    Dim bi As Double
    bi = 80
    Func = Tan(x) + 2 / (bi - 2) * x
End Function

Public Function NLBisectRoot(m As Integer, a As Double, b As Double, h As Double, x() As Double, eps As Double) As Integer
    Dim n As Integer, js As Integer
    Dim z As Double, y As Double, z1 As Double, y1 As Double, z0 As Double, y0 As Double
    ' 根的个数清0
    n = 0

    ' 左边界函数值
    z = a
    y = Func(z)

    ' 迭代求解，直到到达右边界
    While ((z <= b) And (n <> m))
        ' 如果精度满足要求，则求得一个实根，继续计算下一步
        If (Abs(y) <= eps) Then
            n = n + 1
            x(n) = z
            z = z + h / 2#
            y = Func(z)
        Else
            z1 = z + h
            y1 = Func(z1)
            If (Abs(y1) < eps) Then
                n = n + 1
                x(n) = z1
                z = z1 + h / 2#
                y = Func(z)
            Else
                If (y * y1 > 0#) Then
                    y = y1
                    z = z1
                Else
                    js = 0
                    While (js = 0)
                        If (Abs(z1 - z) < eps) Then
                            n = n + 1
                            x(n) = (z1 + z) / 2#
                            z = z1 + h / 2#
                            y = Func(z)
                            js = 1
                        Else
                            z0 = (z1 + z) / 2#
                            y0 = Func(z0)
                            If (Abs(y0) < eps) Then
                                x(n) = z0
                                n = n + 1
                                js = 1
                                z = z0 + h / 2#
                                y = Func(z)
                            Else
                                If ((y * y0) < 0#) Then
                                    z1 = z0
                                    y1 = y0
                                Else
                                    z = z0
                                    y = y0
                                End If
                            End If
                        End If
                    Wend
                End If
            End If
        End If
    Wend
    ' 返回求得的根的个数
    NLBisectRoot = n
End Function

---------------------------
工程1
---------------------------
共求得 1 个实根，分别为：

x(0) = 3.06320892333984

---------------------------
确定   
---------------------------