library.bas

小型的数学计算,求非线性方程的根

Attribute VB_Name = "Module1"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：Library.bas
'  函数名：NLBisectRoot使用对分法求解非线性方程的实根，本函数需要调用计算方程左端函数f(x)值的函数Func，其形式为：Function Func(x As Double) As Double
'  函数名：Func(x As Double) As Double设定需求解的三次方方程，配合NLBisectRoot使用
'  函数名： DoubleX(a As Double, b As Double, c As Double, x As Double) As Double求解一元二次方程的根，无解返回0
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  计算参数数组定义开始
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'计算三次方程解的常数
Public ParaD As Double, ParaC As Double, ParaB As Double, ParaA As Double
'混凝土强度、钢筋强度、钢绞线强度
Public Cfck(14) As Double, Cftk(14) As Double, Cfcd(14) As Double, Cftd(14) As Double, CEc(14) As Double, Sfsk(4) As Double, Sfsd(4) As Double, Pfpk As Double, Pfpd As Double, PEp As Double
'初始化材料参数(单位Pa)
Function initP()
'混凝土标准抗压强度
Cfck(1) = 10000000#: Cfck(2) = 13400000#: Cfck(3) = 16700000#: Cfck(4) = 20100000#: Cfck(5) = 23400000#: Cfck(6) = 26800000#: Cfck(7) = 29600000#
Cfck(8) = 32400000#: Cfck(9) = 35500000#: Cfck(10) = 38500000#: Cfck(11) = 41500000#: Cfck(12) = 44500000#: Cfck(13) = 47400000#: Cfck(14) = 50200000#
'混凝土标准抗拉强度
Cftk(1) = 1270000#: Cftk(2) = 1540000#: Cftk(3) = 1780000#: Cftk(4) = 2010000#: Cftk(5) = 2200000#: Cftk(6) = 2400000#: Cftk(7) = 2510000#
Cftk(8) = 2650000#: Cftk(9) = 2740000#: Cftk(10) = 2850000#: Cftk(11) = 2930000#: Cftk(12) = 3000000#: Cftk(13) = 3050000#: Cftk(14) = 3100000#
'混凝土设计抗压强度
Cfcd(1) = 6900000#: Cfcd(2) = 9200000#: Cfcd(3) = 11500000#: Cfcd(4) = 13800000#: Cfcd(5) = 16100000#: Cfcd(6) = 18400000#: Cfcd(7) = 20500000#
Cfcd(8) = 22400000#: Cfcd(9) = 24400000#: Cfcd(10) = 26500000#: Cfcd(11) = 28500000#: Cfcd(12) = 30500000#: Cfcd(13) = 32400000#: Cfcd(14) = 34600000#
'混凝土设计抗拉强度
Cftd(1) = 880000#: Cftd(2) = 1060000#: Cftd(3) = 1230000#: Cftd(4) = 1390000#: Cftd(5) = 1520000#: Cftd(6) = 1650000#: Cftd(7) = 1740000#
Cftd(8) = 1830000#: Cftd(9) = 1890000#: Cftd(10) = 1960000#: Cftd(11) = 2020000#: Cftd(12) = 2070000#: Cftd(13) = 2100000#: Cftd(14) = 2140000#
'混凝土弹性模量
CEc(1) = 22000000000#: CEc(2) = 25500000000#: CEc(3) = 28000000000#: CEc(4) = 30000000000#: CEc(5) = 31500000000#: CEc(6) = 32500000000#: CEc(7) = 33500000000#
CEc(8) = 34500000000#: CEc(9) = 35500000000#: CEc(10) = 36000000000#: CEc(11) = 36500000000#: CEc(12) = 37000000000#: CEc(13) = 37500000000#: CEc(14) = 38000000000#
'普通钢筋抗拉压强度标准值
Sfsk(1) = 235000000#: Sfsk(2) = 335000000#: Sfsk(3) = 400000000#: Sfsk(4) = 400000000#
'普通钢筋抗拉压强度设计值
Sfsd(1) = 195000000#: Sfsd(2) = 280000000#: Sfsd(3) = 330000000#: Sfsd(4) = 330000000#
'预应力钢筋标准、设计拉压强度及弹性模量
Pfpk = 1860000000#: Pfpd = 1260000000#: PEp = 195000000000#
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  计算参数数组定义结束
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：Library.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型，求得的实根的个数
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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 + h / 2#) 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


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：Library.bas
'  函数名：Func(x As Double) As Double
'  功能：  设定需求解的三次方方程，配合NLBisectRoot使用
'  参数    ParaA  - Double型变量，三次方常数
'          ParaB  - Double型变量，二次方常数
'          ParaC  - Double型变量，一次方常数
'          ParaD  - Double型变量，常数
'          x    - Double型变量，为方程中自变量的当前取值
'  返回值：Double型，三次方程的函数值
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function Func(x As Double) As Double
    Func = ParaD + ParaC * x + ParaB * x * x + ParaA * x * x * x
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：Library.bas
'  函数名： DoubleX(a As Double, b As Double, c As Double, x As Double) As Double
'  功能：  求解一元二次方程的根，无解返回0
'  参数    a  - Double型变量，二次方常数
'          b  - Double型变量，一次方常数
'          c  - Double型变量，方程常数
'          x  - Double型一维数组，二个参数，返回方程中自变量的解
'  返回值：Double型，二次方程有解为1，无解为0
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DoubleX(a As Double, b As Double, c As Double, x() As Double) As Double
    If b ^ 2 - 4 * a * c < 0 Then DoubleX = 0: Exit Function
    x(1) = (-b + Sqrt(b ^ 2 - 4 * a * c)) / (2 * a)
    x(2) = (-b - Sqrt(b ^ 2 - 4 * a * c)) / (2 * a)
    DoubleX = 1
End Function