libmathfuncs.bas

本系统是给大庆油田做的一个示例程序

Attribute VB_Name = "LibMathFuncs"
Option Explicit
Rem 产生随机数
Sub SubRandomDigits(A As Single, B As Single, RandomDigits As Single)
    Randomize
    RandomDigits = A + (B - A) * Rnd
End Sub
Rem 音乐
Sub Sound()
    Dim ki As Integer
    For ki = 1 To 5
        Beep
    Next ki
End Sub
Rem 暂停
Sub Pause(ByVal tt As Integer)
    Dim times As Integer, TimeN As Integer, dtT As Integer
    times = Second(Time)
    Do
        TimeN = Second(Time)
        dtT = TimeN - times
        If dtT < 0 Then dtT = 60 + dtT
    Loop Until dtT < tt
End Sub
Rem 错误处理
Sub ErrorHandle()
    Dim msg As String
    Call Sound
    If Err.Number <> 0 Then
        msg = "运行时产生了" & Err.Description & "错误号是：" & Trim(str(Err.Number)) & _
              Chr(13) & Chr(13) & "             请检查有关内容 ！ "
              
        MsgBox msg, , "Error", Err.HelpFile, Err.HelpContext
    End If
End Sub
Rem 字符串处理
Function Str_To_Arr(ss As String, arr() As Single) As Integer
    Dim arrTmp() As String, i As Integer
    arrTmp = Split(ss, ",")
    Str_To_Arr = UBound(arrTmp) + 1
    For i = 0 To UBound(arrTmp)
       arr(i) = Val(arrTmp(i))
    Next
End Function
'math functions dont have a clue about these
'Derived math functions from language reference Appendix D

' Secant
Function Sec(x As Single) As Double
    Sec = 1 / Cos(x)
End Function

' Cosecant
Function CoSec(x As Single) As Double
    CoSec = 1 / Sin(x)
End Function

' Cotangent
Function CoTan(x As Single) As Double
CoTan = 1 / Tan(x)
End Function

' Inverse Sine
Function ArcSin(x As Single) As Double
    If x = 1 Then ArcSin = Atn(1) * 2 Else ArcSin = Atn(x / Sqr(-x * x + 1))
End Function

' Inverse Cosine
Function ArcCos(x As Single) As Double
    ArcCos = Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)
End Function

' Inverse Secant
Function ArcSec(x As Single) As Double
    ArcSec = Atn(x / Sqr(x * x - 1)) + Sgn(x - 1) * (2 * Atn(1))
End Function

' Inverse Cosecant
Function ArcCoSec(x As Single) As Double
    ArcCoSec = Atn(x / Sqr(x * x - 1)) + (Sgn(x) - 1) * (2 * Atn(1))
End Function

' Inverse Cotangent
Function ArcCoTan(x As Single) As Double
    ArcCoTan = Atn(x) + 2 * Atn(1)
End Function

' Hyperbolic Sine
Function HSin(x As Single) As Double
    HSin = (Exp(x) - Exp(-x)) / 2
End Function

' Hyperbolic Cosine
Function HCos(x As Single) As Double
    HCos = (Exp(x) + Exp(-x)) / 2
End Function

' Hyperbolic Tangent
Function HTan(x As Single) As Double
    HTan = (Exp(x) - Exp(-x)) / (Exp(x) + Exp(-x))
End Function

' Hyperbolic Secant
Function HSec(x As Single) As Double
    HSec = 2 / (Exp(x) + Exp(-x))
End Function

' Hyperbolic Cosecant
Function HCoSec(x As Single) As Double
    HCoSec = 2 / (Exp(x) - Exp(-x))
End Function
' Hyperbolic Cotangent
Function HCotan(x As Single) As Double
    HCotan = (Exp(x) + Exp(-x)) / (Exp(x) - Exp(-x))
End Function

' Inverse Hyperbolic Sine
Function HArcSin(x As Single) As Double
    HArcSin = Log(x + Sqr(x * x + 1))
End Function

' Inverse Hyperbolic Cosine
Function HArcCos(x As Single) As Double
    HArcCos = Log(x + Sqr(x * x - 1))
End Function

' Inverse Hyperbolic Tangent
Function HArcTan(x As Single) As Double
    HArcTan = Log((1 + x) / (1 - x)) / 2
End Function

' Inverse Hyperbolic Secant
Function HArcSec(x As Single) As Double
    HArcSec = Log((Sqr(-x * x + 1) + 1) / x)
End Function

' Inverse Hyperbolic Cosecant
Function HArcCoSec(x As Single) As Double
    HArcCoSec = Log((Sgn(x) * Sqr(x * x + 1) + 1) / x)
End Function

' Inverse Hyperbolic Cotangent
Function HArcCoTan(x As Single) As Double
    HArcCoTan = Log((x + 1) / (x - 1)) / 2
End Function

' Logarithm to base N
Function LogN(x As Single, n As Single) As Double
    LogN = Log(x) / Log(n)
End Function
Rem 多项式插值
Sub ChZh(n As Integer, x() As Single, Y() As Single, M As Integer, T() As Single, F() As Single, _
         F1() As Single, F2() As Single)
    Dim N1 As Integer, N2 As Integer, ii As Integer, I1 As Integer, Z
    Dim J1 As Integer, k1 As Integer, H1, H2, H3, H4
    Dim h(2500), Dy(2500), s2(2500), s(2500), e(2500)
    
    N1 = n - 1
    N2 = n - 2
    For ii = 1 To N1
        h(ii) = x(ii + 1) - x(ii)
        If h(ii) = 0 Then h(ii) = 0.00001
        Dy(ii) = (Y(ii + 1) - Y(ii)) / h(ii)
    Next ii
    s2(1) = 0#
    s2(n) = 0#
    For ii = 2 To N1
        s2(ii) = 6# * (Dy(ii) - Dy(ii - 1))
    Next ii
    Z = 0.5 / (h(1) + h(2))
    s(1) = -h(2) * Z
    e(1) = s2(2) * Z
    For ii = 2 To N2
        Z = 1# / (2# * (h(ii) + h(ii + 1)) + h(ii) * s(ii - 1))
        s(ii) = -h(ii + 1) * Z
        e(ii) = (s2(ii + 1) - h(ii) * e(ii - 1)) * Z
    Next ii
    s2(N1) = e(N2)
    For I1 = 2 To N2
        ii = N2 + 2 - I1
        s2(ii) = s(ii - 1) * s2(ii + 1) + e(ii - 1)
    Next I1
    For ii = 1 To N1
        s(ii) = (s2(ii + 1) - s2(ii)) / h(ii)
    Next ii
    ii = 2: k1 = 1
    For J1 = 1 To M
        Do
           If (T(J1) <= x(ii)) Then Exit Do
           k1 = ii
           ii = ii + 1
        Loop
        H1 = T(J1) - x(k1)
        H2 = T(J1) - x(ii)
        H3 = H1 * H2
        H4 = s2(k1) + H1 * s(k1)
        Z = (s2(ii) + s2(k1) + H4) / 6#
        F(J1) = Y(k1) + H1 * Dy(k1) + H3 * Z
        F1(J1) = Dy(k1) + Z * (H1 + H2) + H3 * s(k1) / 6
        F2(J1) = H4
    Next J1
End Sub
Rem 五点三次平滑
    '文件名： 五点三次平滑.bas
    '模块名： 五点三次平滑
    '函数名： WudianSanci_Pinghua(n,y(),yy())
    '功  能： 用高斯-约旦消去法求解A[XY]=[BI]，其中A为n×n”非奇异矩阵，B为n×m矩阵，均已知；
    '         X(n×m),Y(n×n)未知.由于消去过程是在全矩阵中选主元(绝对值最大的元素)来进行的，
    '         故可使舍入误差对结果的影响减到最小
    '参  数： n —— 整型变量，输入参数。给定等距观测点的个数。
    '         y() —— 实型数组，输入参数。长度为n，等距观测点上的数据。
    '         yy() —— 实型数组，输出参数。长度为n，存放n个等距观测点上的平滑结果。
Sub Curve_Smoothing(n As Integer, Y() As Single)
    Dim i As Integer
    Dim yy(1500) As Single
    
    If n < 5 Then
        For i = 1 To n:
           yy(i) = Y(i)
        Next i
        Exit Sub
    End If
    
    yy(1) = (69# * Y(1) + 4# * Y(2) - 6# * Y(3) + 4# * Y(4) - Y(5)) / 70#
    yy(2) = (2# * Y(1) + 27# * Y(2) + 12# * Y(3) - 8# * Y(4) + 2# * Y(5)) / 35#
    For i = 3 To n - 2
        yy(i) = (-3# * Y(i - 2) + 12# * Y(i - 1) + 17# * Y(i) + 12# * Y(i + 1) - 3# * Y(i + 2)) / 35#
    Next
    yy(n - 1) = (2# * Y(n - 4) - 8# * Y(n - 3) + 12# * Y(n - 2) + 27# * Y(n - 1) + 2# * Y(n)) / 35#
    yy(n) = (-Y(n - 4) + 4# * Y(n - 3) - 6# * Y(n - 2) + 4# * Y(n - 1) + 69# * Y(n)) / 70#
    For i = 1 To n
        Y(i) = yy(i)
    Next i
End Sub

Rem  二次抛物性回归
   '文件名： 二次抛物性回归'
   '函数名： Regression_Parabola( K , X(), F(), A())
   '参  数：K —— 整型变量，输入参数。观测点数。
   '        x() —— 实型1维数组，输入参数。自变量因子的k次观测值
   '        F() —— 实型1维数组，输入参数。因变量因子的k次观测值
Sub Regression_Parabola(k As Integer, x() As Single, F() As Single, A() As Single)
    
    Dim a1 As Single, a2 As Single, a3 As Single
    Dim b1 As Single, b2 As Single, b3 As Single
    Dim c1 As Single, c2 As Single, c3 As Single
    Dim d1 As Single, d2 As Single, d3 As Single
    Dim j As Integer
    Dim Delt As Single, deltx As Single, Delty As Single, Deltz As Single
    
    a1 = 0
    a2 = 0
    a3 = 0
    b1 = 0
    b2 = 0
    b3 = 0
    c1 = 0
    c2 = 0
    c3 = 0
    d1 = 0
    d2 = 0
    d3 = 0
    For j = 1 To k
        a1 = a1 + 1
        a2 = a2 + x(j)
        a3 = a3 + x(j) ^ 2
        b1 = b1 + x(j)
        b2 = b2 + x(j) ^ 2
        b3 = b3 + x(j) ^ 3
        c1 = c1 + x(j) ^ 2
        c2 = c2 + x(j) ^ 3
        c3 = c3 + x(j) ^ 4
        d1 = d1 + F(j)
        d2 = d2 + x(j) * F(j)
        d3 = d3 + x(j) ^ 2 * F(j)
    Next j
    
    Delt = a1 * b2 * c3 + a2 * b3 * c1 + a3 * b1 * c2 - a3 * b2 * c1 - a1 * b3 * c2 - a2 * b1 * c3
    
    deltx = d1 * b2 * c3 + d2 * b3 * c1 + d3 * b1 * c2 - d3 * b2 * c1 - d1 * b3 * c2 - d2 * b1 * c3
    Delty = a1 * d2 * c3 + a2 * d3 * c1 + a3 * d1 * c2 - a3 * d2 * c1 - a1 * d3 * c2 - a2 * d1 * c3
    Deltz = a1 * b2 * d3 + a2 * b3 * d1 + a3 * b1 * d2 - a3 * b2 * d1 - a1 * b3 * d2 - a2 * b1 * d3
    
    A(0) = deltx / Delt
    A(1) = Delty / Delt
    A(2) = Deltz / Delt
End Sub
Rem 利用线性回归对数据系列进行线性光滑（在计算点前后各选择两个计算点）
Sub LinearSmoothing(M As Integer, x() As Single, Y() As Single)
    Dim i As Integer, j As Integer
    Dim k As Integer