蒙特卡罗模拟,包括使用VBA进行高斯消除

时间:2019-03-26 10:21:20

标签: excel vba performance optimization linear-algebra

我编写了一个代码,该代码在蒙特卡洛模拟过程中连续求解线性方程组服务时间。

对于每次运行,输入都会略有变化,并且必须再次计算解。目的是获得结果的概率分布函数(线性系统的解)。

所以我的问题是:
有没有办法只解决一次线性方程组并保存泛型解,以便每次蒙特卡洛运行都可以直接计算出解?

这将非常节省时间,因为要进行正确的仿真,我至少需要运行20k,即使对于三个未知数的小型系统,也要花费很长时间。我的代码每次更新时都会求解此线性方程式,因为在其原始版本中,变量的数量是多少,因此输入量的数量应该是可封闭的,因此通用解是未知的。

这是我的高斯消去算法。

Function gaussian_elimination(w As Variant, mm As Variant, R As Variant, rb As Variant, n_iso As Integer) As Variant()

'initializing running indexes
    Dim i As Integer
    Dim j As Integer
    Dim h As Integer
    Dim n As Integer

    n = n_iso

'runing variables for Gauss elimination
    Dim ip As Integer
    Dim q As Integer
    Dim p As Integer
    Dim z As Double
    Dim temp1(1, 1) As Variant
    Dim temp2(1, 1) As Variant
    Dim sum As Variant


'initializing b vector
    Dim b() As Variant
    ReDim b(1 To n - 1, 0 To 1)

'initializing k vector
    Dim k() As Variant
    ReDim k(1 To n - 1, 0 To 1)

'initializing A matrix
    Dim a() As Variant
    ReDim a(1 To n - 1, 1 To n - 1)

'initializing X matrix
    Dim x() As Variant
    ReDim x(1 To n - 1, 1 To n)


' calculating b vector

    For i = 1 To (n - 1) Step 1
        b(i, 0) = mm(1, 0) / (w(i + n - 1, 0) * (rb(i, 0) - R(i * n, 0))) - mm(1, 0) / (w(i, 0) * (R(i, 0) - rb(i, 0)))
    Next i

'calculating A matrix
    For i = 1 To (n - 1) Step 1
        For j = 1 To (n - 1) Step 1
            a(i, j) = mm(j + 1, 0) * ((R(j + i * (n - 1), 0) / (w(i + n - 1, 0) * (rb(i, 0) - R(i * n, 0)))) - (R(j, 0) / (w(i, 0) * (R(i, 0) - rb(i, 0)))))
        Next j
    Next i



    'using on board solving routine

    Dim A_Inv As Variant
    Dim k_vec As Variant
    Dim b_dummy As Variant





'filling X matrix
    For i = 1 To n - 1 Step 1
        For j = 1 To n Step 1
                If j = (n) Then
                    x(i, j) = b(i, 0)
                Else: x(i, j) = a(i, j)
                End If
        Next j
    Next i

   'Gaussian elimination
    For i = 1 To (n - 2) Step 1
        For j = i + 1 To (n - 1) Step 1
            If (Abs(x(j, i)) > Abs(x(i, i))) Then
                For h = 1 To n
                    temp1(1, 1) = x(i, h)
                    temp2(1, 1) = x(j, h)
                    x(i, h) = temp2(1, 1)
                    x(j, h) = temp1(1, 1)
                Next h
            End If
        Next

        For p = i + 1 To n - 1
            z = x(p, i) / x(i, i)
            For q = i + 1 To n
                x(p, q) = x(p, q) - z * x(i, q)
            Next q
            x(p, i) = 0
        Next p
    Next i






'calculatiing k factors backwards
    If Abs(x(UBound(x, 1), UBound(x, 2) - 1)) <= 0 Then
        MsgBox "Equation system can not be solved! Solving for k factors faild", vbExclamation, "Warning!"
        Exit Function
    End If

    k((UBound(x, 1)), 0) = x((UBound(x, 1)), UBound(x, 2)) / x((UBound(x, 1)), (UBound(x, 2) - 1))

    For i = ((UBound(x, 1) - 1)) To (LBound(x, 1)) Step -1
        sum = x(i, UBound(x, 2))
        For j = i + 1 To (UBound(x, 2) - 1) Step 1
            sum = sum - x(i, j) * k(j, 0)
        Next j
        k(i, 0) = sum / x(i, i)
    Next i

    For i = 1 To n - 1
        k(i, 0) = (-1) * k(i, 0)
    Next i

    gaussian_elimination = k



End Function

0 个答案:

没有答案