simu.frm

该系统分为数学公式编译器和数值计算两大块,数学公式编译器的实现比较复杂,计算系统的实现是利用编译器调用数学公式进行的

VERSION 5.00
Begin VB.Form simu 
   Caption         =   "数值积分"
   ClientHeight    =   6105
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   8505
   LinkTopic       =   "Form1"
   ScaleHeight     =   6105
   ScaleWidth      =   8505
   StartUpPosition =   3  'Windows Default
   WindowState     =   2  'Maximized
   Begin VB.Menu 插值方法 
      Caption         =   "插值方法"
      Index           =   5
      Begin VB.Menu 拉格朗日 
         Caption         =   "拉格朗日"
         Index           =   6
      End
      Begin VB.Menu 牛顿 
         Caption         =   "牛顿"
         Index           =   7
      End
      Begin VB.Menu 埃特金 
         Caption         =   "埃特金"
         Index           =   21
      End
   End
   Begin VB.Menu 公式选择 
      Caption         =   "数值积分系统"
      Index           =   0
      Begin VB.Menu 牛顿柯特斯公式 
         Caption         =   "牛顿-柯特斯公式"
         Index           =   1
      End
      Begin VB.Menu 龙贝格算法 
         Caption         =   "龙贝格算法"
         Index           =   2
      End
      Begin VB.Menu 高斯公式 
         Caption         =   "高斯公式"
         Index           =   3
      End
   End
   Begin VB.Menu 线性代数方程组求解 
      Caption         =   "线性代数方程组求解"
      Index           =   8
      Begin VB.Menu 高斯消元法 
         Caption         =   "高斯消元法"
         Index           =   9
      End
      Begin VB.Menu 矩阵LU分解 
         Caption         =   "矩阵LU分解"
         Index           =   10
      End
      Begin VB.Menu 高斯塞德尔迭代 
         Caption         =   "高斯塞德尔迭代"
         Index           =   13
      End
   End
   Begin VB.Menu 常微分方程数值解法 
      Caption         =   "常微分方程数值解法"
      Index           =   17
      Begin VB.Menu 欧拉方程 
         Caption         =   "欧拉方程"
         Index           =   18
      End
      Begin VB.Menu 龙格库塔方法 
         Caption         =   "龙格库塔方法"
         Index           =   19
      End
   End
   Begin VB.Menu 帮助 
      Caption         =   "帮助"
   End
End
Attribute VB_Name = "simu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'拉格朗日插值函数
Public Function LagrangeInterpolation(x() As Single, f() As Single, dx As Single) As Single
     Dim i As Long, j As Long, n As Single, m As Single
     For i = 1 To UBound(x)
          m = x(i): n = 1
          For j = 1 To UBound(x)
               If i <> j Then n = n * (dx - x(j)) / (m - x(j))
          Next
          LagrangeInterpolation = LagrangeInterpolation + n * f(i)
     Next
End Function

Public Function SepStrToNumArray(TreatStr As String, SepChr As String, ArrayBase As Long, ReturnValue() As Single) As Boolean '将字串拆解成阵列
     Dim i As Long, j As Long, temp As String, no As Long
     TreatStr = Trim(TreatStr)
     no = ArrayBase - 1
     Do
          i = InStr(j + 1, TreatStr, SepChr, vbBinaryCompare)
          If i <> j + 1 Then
               no = no + 1
               If i <> 0 Or (i = 0 And j < Len(TreatStr)) Then
                    If i <> 0 Then temp = Mid(TreatStr, j + 1, i - j - 1) Else temp = Mid(TreatStr, j + 1)
                    If Not IsNumeric(temp) Or InStr(temp, ",") > 0 Then Exit Function
                    ReDim Preserve ReturnValue(ArrayBase To no)
                    ReturnValue(no) = temp
               End If
          End If
          j = i
     Loop Until i = 0
     SepStrToNumArray = True
End Function
Public Sub RungeKuttaSF(Problem As Long, ix As Single, tx As Single, dx As Single, _
ic() As Single, ReturnValue() As Single)
     Dim i As Long, j As Long, k As Long, EqNo As Long, no As Long, x As Single
     Dim f() As Single, iy() As Single, tempY() As Single, y() As Single
     EqNo = UBound(ic)
     no = CInt((tx - ix) / dx) + 1
     ReDim f(1 To EqNo, 1 To 4), iy(1 To EqNo), y(1 To EqNo)
     ReDim ReturnValue(1 To EqNo, 1 To no), tempY(1 To EqNo)
     For i = 1 To EqNo
          y(i) = ic(i)
          ReturnValue(i, 1) = y(i)
     Next
     For i = 2 To no
          x = ix + (i - 2) * dx
          For k = 1 To 3
               For j = 1 To EqNo
                    If k = 1 Then f(j, 1) = fx(Problem, x, y, j) Else f(j, k) = _
                    fx(Problem, x + (dx / 2), tempY, j)
                    If k = 3 Then iy(j) = y(j) + dx * f(j, 3) Else iy(j) = y(j) + (dx / 2) * f(j, k)
               Next
               For j = 1 To EqNo: tempY(j) = iy(j): Next
          Next
          For j = 1 To EqNo: f(j, 4) = fx(Problem, x + dx, tempY, j): Next
          For j = 1 To EqNo
               y(j) = y(j) + dx * (f(j, 1) / 6 + f(j, 2) / 3 + f(j, 3) / 3 + f(j, 4) / 6)
               ReturnValue(j, i) = y(j)
          Next
     Next
End Sub

Private Sub Form_Load()
  Me.Icon = LoadPicture("")
 
End Sub

Private Sub 埃特金_Click(Index As Integer)
Dim ic(1 To 3) As Single, dx As Single, ix As Single, tx As Single
     Dim i As Long, j As Long, Result() As Single
     ix = 1
     tx = 3
     dx = 0.2
     ic(1) = 0
     Call RungeKuttaSF(1, ix, tx, dx, ic, Result)
     For i = 1 To UBound(Result, 2)
          Debug.Print Result(1, i)
     Next

End Sub

Private Sub 拉格朗日_Click(Index As Integer)

'参数说明:

'x：x值的阵列，阵列基底为 1。

'f：f(x)值的阵列，阵列基底为 1。

'dx: 欲内插的x值。

Dim Keyin As String, x() As Single, f() As Single, dx As Single
Keyin = InputBox("请输入x值，以空白来区隔。")
  If Not SepStrToNumArray(Keyin, " ", 1, x) Then MsgBox "输入了非数值": Exit Sub
Keyin = InputBox("请输入f(x)值，以空白来区隔。")
  If Not SepStrToNumArray(Keyin, " ", 1, f) Then MsgBox "输入了非数值": Exit Sub
  dx = Val(InputBox("请输入欲内插的x值"))
   Debug.Print "f(x)在x=" & dx & "的内插值为 " & LagrangeInterpolation(x, f, dx)

End Sub
Public Function fx(Problem As Long, x As Single, v() As Single, EqNo As Long) As Single
     Select Case Problem
          Case 1
                    fx = 1 + v(1) / x + (v(1) / x) ^ 2
          Case 2
               Select Case EqNo
                    Case 1
                         fx = 4 * v(1) - v(2) + v(3) - (x + 2) ^ 2
                    Case 2
                         fx = -v(1) + 3 * v(2) - 2 * v(3) + 2 * x ^ 2 + x + 15
                    Case 3
                         fx = v(1) - 2 * v(2) + 3 * v(3) - 3 * x ^ 2 + x - 10
               End Select
     End Select
End Function

Public Function Romberg(Problem As Long, a As Single, b As Single, tol As Single) As Single
     'Dim i As Long, j As Long, T() As Single, L As Long
     'Dim x As Single, dx As Single, n As Long, sum As Single
     'ReDim T(1 To 3)
     'T(1) = (b - a) * (fx(Problem, a) + fx(Problem, b)) / 2
      '  T(2) = T(1) / 2 + (b - a) * (fx(Problem, (a + b) / 2)) / 2
     'T(3) = (4 * T(2) - T(1)) / 3
     'j = 3
     'Do While Abs(T(UBound(T)) - T(UBound(T) - 2)) > tol
      '    dx = (b - a) / (2 ^ (j - 1))
      '    x = a - dx
       '   n = 2 ^ (j - 2)
        '  sum = 0
         ' For i = 1 To n
 '              x = x + 2 * dx
  '             sum = sum + fx(Problem, x)
   '       Next
    '      For i = 2 To UBound(T) Step 2
     '          T(i - 1) = T(i)
      '    Next
       '   T(2) = T(1) / 2 + dx * sum
        '  ReDim Preserve T(1 To UBound(T) + 2)
         ' For L = 2 To j
          '     If L <> j Then
           '         T(L * 2) = ((4 ^ (L - 1)) * T(L * 2 - 2) - T(L * 2 - 3)) / ((4 ^ (L - 1)) - 1)
            '   Else
             '       T(UBound(T)) = ((4 ^ (L - 1)) * T(UBound(T) - 1) - _
              '      T(UBound(T) - 2)) / ((4 ^ (L - 1)) - 1)
               'End If
       '   Next
        '  j = j + 1
    ' Loop
     'Romberg = T(UBound(T))
End Function

Private Sub 龙贝格算法_Click(Index As Integer)
'Debug.Print Romberg(1, 1, 10, 0.000001)
     
End Sub

Private Sub 牛顿_Click(Index As Integer)
Dim newton
newton = Shell(App.Path + "\newton.exe", vbNormalFocus)



End Sub