nimodule.bas

科学与工程数值计算算法（Visual Basic版） 附赠的光盘包含了本书中全部的源代码

        g = t2
        l = 0
        j = 2
        
        While ((l = 0) And (j <= m))
            s = g - bb(j - 1)
            
            If (Abs(s) + 1# = 1#) Then
                l = 1
            Else
                g = (h(m) - h(j - 1)) / s
            End If
            
            j = j + 1
        Wend
        
        bb(m) = g
        
        If (l <> 0) Then bb(m) = 1E+35
        
        g = bb(m)
        
        For j = m To 2 Step -1
           g = bb(j - 1) - h(j - 1) / g
        Next j
        
        ep = Abs(g - s1)
        s1 = g
        t1 = t2
        hh = hh / 2#
        n = n + n
    Wend
    
    ' 结果返回
    NIPq = g
    
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：NIModule.bas
'  函数名：NIPart
'  功能：  用分步积分法计算高振荡函数的积分
'  参数：  a     - Double型变量，积分下限
'          b     - Double型变量，积分上限，要求 b>a
'          m    - Double型变量，被积函数中振荡函数的角频率
'          n     - 给定积分区间两端点上的导数最高阶数＋1
'          fa     - Double型一维数组，长度为n，存放f(x)在积分区间端点x=a处的各阶导数值
'          fb     - Double型一维数组，长度为n，存放f(x)在积分区间端点x=b处的各阶导数值
'          s     - Double型一维数组，长度为2，其中s(1)返回f(x)cos(mx)在积分区间的积分值，
'                     s(2) 返回f(x)sin(mx)在积分区间的积分值
'  返回值：无
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub NIPart(a As Double, b As Double, m As Integer, n As Integer, fa() As Double, fb() As Double, s() As Double)
    Dim mm As Long, k As Integer, j As Integer
    Dim sa(4) As Double, sb(4) As Double, ca(4) As Double, cb(4) As Double, sma As Double, smb As Double, cma As Double, cmb As Double
    
    ' 初值
    sma = Sin(m * a)
    smb = Sin(m * b)
    cma = Cos(m * a)
    cmb = Cos(m * b)
    
    sa(1) = sma
    sa(2) = cma
    sa(3) = -sma
    sa(4) = -cma
    sb(1) = smb
    sb(2) = cmb
    sb(3) = -smb
    sb(4) = -cmb
    ca(1) = cma
    ca(2) = -sma
    ca(3) = -cma
    ca(4) = sma
    cb(1) = cmb
    cb(2) = -smb
    cb(3) = -cmb
    cb(4) = smb
    
    s(1) = 0#
    s(2) = 0#
    
    mm = 1
    
    ' 循环计算
    For k = 0 To n - 1
        j = k
        While (j >= 4)
            j = j - 4
        Wend
        
        mm = mm * m
        s(1) = s(1) + (fb(k + 1) * sb(j + 1) - fa(k + 1) * sa(j + 1)) / (1# * mm)
        s(2) = s(2) + (fb(k + 1) * cb(j + 1) - fa(k + 1) * ca(j + 1)) / (1# * mm)
    Next k
    
    s(2) = -s(2)

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：NIModule.bas
'  函数名：NILgdGauss
'  功能：  用勒让德－高斯求积法计算一维积分，本函数需要调用计算函数f(x)值的函数Func，其形式为：
'          Function Func(x As Double) As Double
'  参数：  a     - Double型变量，积分下限
'          b     - Double型变量，积分上限，要求 b>a
'          eps   - Double型变量，积分精度要求
'  返回值：Double型，积分值
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function NILgdGauss(a As Double, b As Double, eps As Double) As Double
    Dim m As Long, i As Integer, j As Integer
    Dim s As Double, p As Double, ep As Double, h As Double, aa As Double, bb As Double, w As Double, x As Double, g As Double
    Dim t(5) As Double, c(5) As Double
    
    ' 勒让德－高斯求积系数
    t(1) = -0.9061798459
    t(2) = -0.5384693101
    t(3) = 0#
    t(4) = 0.5384693101
    t(5) = 0.9061798459
    
    c(1) = 0.2369268851
    c(2) = 0.4786286705
    c(3) = 0.5688888889
    c(4) = 0.4786286705
    c(5) = 0.2369268851
    
    ' 初值
    m = 1
    h = b - a
    s = Abs(0.001 * h)
    p = 1E+35
    ep = eps + 1#
    
    ' 循环计算
    While ((ep >= eps) And (Abs(h) > s))
        g = 0#
        
        For i = 1 To m
            aa = a + (i - 1#) * h
            bb = a + i * h
            w = 0#
            
            For j = 1 To 5
                x = ((bb - aa) * t(j) + (bb + aa)) / 2#
                w = w + Func(x) * c(j)
            Next j
            
            g = g + w
        Next i
        
        g = g * h / 2#
        ep = Abs(g - p) / (1# + Abs(g))
        p = g
        m = m + 1
        h = (b - a) / m
    Wend
      
    ' 返回结果
    NILgdGauss = g
    
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：NIModule.bas
'  函数名：NILgreGauss
'  功能：  用拉盖尔－高斯求积法计算一维积分，本函数需要调用计算函数f(x)值的函数Func，其形式为：
'          Function Func(x As Double) As Double
'  参数： 无
'  返回值：Double型，积分值
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function NILgreGauss() As Double
    Dim i As Integer
    Dim x As Double, g As Double
    Dim t(5) As Double, c(5) As Double
    
    ' 拉盖尔－高斯求积系数
    t(1) = 0.2635599
    t(2) = 1.4134029
    t(3) = 3.596426
    t(4) = 7.0858099
    t(5) = 12.6408
    
    c(1) = 0.6790941054
    c(2) = 1.638487956
    c(3) = 2.769426772
    c(4) = 4.315944
    c(5) = 7.10489623
    
    ' 循环计算
    g = 0#
    For i = 1 To 5
        x = t(i)
        g = g + c(i) * Func(x)
    Next i
    
    ' 返回结果
    NILgreGauss = g

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：NIModule.bas
'  函数名：NIHermiteGauss
'  功能：  用埃尔米特－高斯求积法计算一维积分，本函数需要调用计算函数f(x)值的函数Func，其形式为：
'          Function Func(x As Double) As Double
'  参数： 无
'  返回值：Double型，积分值
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function NIHermiteGauss() As Double
    Dim i As Integer
    Dim x As Double, g As Double
    Dim t(5) As Double, c(5) As Double
    
    ' 埃尔米特－高斯求积系数
    t(1) = -2.020182
    t(2) = -0.9585719
    t(3) = 0#
    t(4) = 0.9585719
    t(5) = 2.020182
    
    c(1) = 1.181469599
    c(2) = 0.9865791417
    c(3) = 0.9453089237
    c(4) = 0.9865791417
    c(5) = 1.181469599
    
    g = 0#
    
    ' 循环计算
    For i = 1 To 5
        x = t(i)
        g = g + c(i) * Func(x)
    Next i
    
    ' 返回结果
    NIHermiteGauss = g

End Function