frmmain.frm

一次仿真课上作的一个关于龙格库塔法解微分方程的一个VB程序

                    mm = mm + xs(j) / (xs(num)) * (xa(j) + hh(k) * kk(j, k - 1))
                Next
                kk(num - 1, k) = b / (xs(num)) - mm
            Next
            X1 = xa(0) + dh / 6 * (kk(0, 1) + 2 * kk(0, 2) + 2 * kk(0, 3) + kk(0, 4)) '没改变xa
            
            dh = dh / 2: hh(1) = 0: hh(2) = dh / 2: hh(3) = dh / 2: hh(4) = dh
            For k = 1 To 4
                i = 0
                While i <= num - 2
                    kk(i, k) = xa(i + 1) + hh(k) * kk(i + 1, k - 1)
                    i = i + 1
                Wend
                j = 0: mm = 0
                For j = 0 To (num - 1)
                    mm = mm + xs(j) / (xs(num)) * (xa(j) + hh(k) * kk(j, k - 1))
                Next
                kk(num - 1, k) = b / (xs(num)) - mm
            Next
                
            For i = 0 To num - 1
                xa(i) = xa(i) + dh / 6 * (kk(i, 1) + 2 * kk(i, 2) + 2 * kk(i, 3) + kk(i, 4)) '改变了xa  h/2处值
            Next
            
            For k = 1 To 4
                i = 0
                While i <= num - 2
                    kk(i, k) = xa(i + 1) + hh(k) * kk(i + 1, k - 1)
                    i = i + 1
                Wend
                j = 0: mm = 0
                For j = 0 To (num - 1)
                    mm = mm + xs(j) / (xs(num)) * (xa(j) + hh(k) * kk(j, k - 1))
                Next
                kk(num - 1, k) = b / (xs(num)) - mm
            Next
            X2 = xa(0) + dh / 6 * (kk(0, 1) + 2 * kk(0, 2) + 2 * kk(0, 3) + kk(0, 4)) '为什麼x1=x2
            If Abs(X2 - X1) <= 0.8 * iJD Or Log(h / dh) / Log(2) >= 6 Then    '认为如将h分为8份
                'need to think
                    j = 0: dh = dh * 2: hh(1) = 0: hh(2) = dh / 2: hh(3) = dh / 2: hh(4) = dh
                    While j <= num - 1
                        xa(j) = aa(j)
                        j = j + 1
                    Wend
                For j = 1 To (h / dh) '在此区间内进行求值
                    cnt = cnt + 1
                            For k = 1 To 4
                                i = 0
                                While i <= num - 2
                                    kk(i, k) = xa(i + 1) + hh(k) * kk(i + 1, k - 1)
                                    i = i + 1
                                Wend
                                jk = 0: mm = 0
                                For jk = 0 To (num - 1)
                                    mm = mm + xs(jk) / (xs(num)) * (xa(jk) + hh(k) * kk(jk, k - 1))
                                Next
                                kk(num - 1, k) = b / (xs(num)) - mm
                            Next
                            For ih = 0 To num - 1
                                xa(ih) = xa(ih) + dh / 6 * (kk(ih, 1) + 2 * kk(ih, 2) + 2 * kk(ih, 3) + kk(ih, 4)) 'xa改变了
                            Next
                            t = t + dh
                        With lsvRST.ListItems.Add()
                                .Text = t
                                .SubItems(1) = Left(xa(0), Abs(Log(iJD) / Log(10)) + 10)
                                .SubItems(2) = "----"
                                .SubItems(3) = "----" ' +
                                .SubItems(4) = "----"
                        End With
                        
                       
                Next
                j = 0: dh = h
                While j <= num - 1
                        aa(j) = xa(j)
                        j = j + 1
                Wend
            Else: GoTo reselh
            End If
        Wend
        sbStatusBar.Panels(1).Text = "共进行了" & cnt & "次计算；" & "可能的精度为：" & Abs(Log(iJD) / Log(10)) & "位"
End Sub
Private Sub Form_Load()
        Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000)
        Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000)
        Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 6500)
        Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)
End Sub
Private Sub Form_Unload(Cancel As Integer)
        Dim i As Integer
        'close all sub forms
        For i = Forms.Count - 1 To 1 Step -1
            Unload Forms(i)
        Next
        If Me.WindowState <> vbMinimized Then
            SaveSetting App.Title, "Settings", "MainLeft", Me.Left
            SaveSetting App.Title, "Settings", "MainTop", Me.Top
            SaveSetting App.Title, "Settings", "MainWidth", Me.Width
            SaveSetting App.Title, "Settings", "MainHeight", Me.Height
        End If
End Sub
Private Sub jieshu_LostFocus()
        iBc = jieshu.Text
        If iBc = "" Then
        MsgBox "输入的阶数不能为空！", vbInformation, "警告"
        jieshu.Text = 1
        Exit Sub
        End If
        
        If IsNumeric(iBc) = False Then
        MsgBox "输入的阶数必须为数字！", vbInformation, "警告"
        jieshu.Text = 1
        Exit Sub
        End If
End Sub

Private Sub jieshucmd_Click()
        iJS = jieshu.Text
        If iJS = "" Then
            MsgBox "输入的阶数不能为空！", vbInformation, "警告"
            Exit Sub
        End If
        If IsNumeric(iJS) = False Then
            MsgBox "输入的阶数必须为数字！", vbInformation, "警告"
            Exit Sub
        End If
        If CInt(iJS) <= 0 Then
            MsgBox "输入的阶数必须大于1！", vbInformation, "警告"
            Exit Sub
        End If
            
        qujianc.Enabled = True
        qujiand.Enabled = True
        xishu.Enabled = True
        chuzhi.Enabled = True
        txtbxishu.Enabled = True
        cmdOK.Enabled = True
        txtBC.Enabled = True
        txtJD.Enabled = True
         zhc = "1 ": num = CInt(iJS)
         For i = 1 To num - 1
                zhc = zhc & "1 "
         Next
         chuzhi.Text = zhc
         xishu.Text = zhc & "1 "
End Sub
Private Sub mnuHelpAbout_Click()
        frmAbout.Show vbModal, Me
End Sub

Private Sub mnuFileExit_Click()
        '卸载窗体
        Unload Me

End Sub

Private Sub mnuFilemnuSimulate_Click()
        lsvRST.ListItems.Clear   '清空ListView控件
End Sub


Private Sub qujianc_LostFocus()
        iBc = qujianc.Text
        iBD = qujiand.Text
        If iBc = "" Then
        MsgBox "输入的区间左端值不能为空！", vbInformation, "警告"
        qujiand.Text = iBc + 1
        Exit Sub
        End If
        If IsNumeric(iBc) = False Then
        MsgBox "输入的区间左端值必须为数字！", vbInformation, "警告"
        qujiand.Text = iBc + 1
        Exit Sub
        End If
End Sub
Private Sub qujiand_GotFocus()
        iBc = qujianc.Text
        iBD = qujiand.Text
        If iBc = "" Then
        MsgBox "输入的区间右端值不能为空！", vbInformation, "警告"
        qujiand.Text = iBc + 1
        Exit Sub
        End If
        
        If iBc > iBD Then
        MsgBox "输入的区间左端值必须小于区间右端值！", vbInformation, "警告"
        qujiand.Text = iBc + 1
        Exit Sub
        End If
                
        If IsNumeric(iBc) = False Then
        MsgBox "输入的区间右端值必须为数字！", vbInformation, "警告"
        qujiand.Text = iBc + 1
        Exit Sub
        End If
End Sub

Private Sub resetcmd_Click()
    jieshucmd.Enabled = True
    jieshu.Enabled = True
End Sub
Private Sub suanfacom_Click()
Select Case suanfacom.ListIndex
      Case 0
       MsgBox "欢迎使用四阶龙格库塔法！", vbInformation, "提醒"
      Case 1
       MsgBox "抱歉，梯形法尚未实现！", vbInformation, "提醒"
      suanfacom.ListIndex = 0 'suanfacom.Text = "四阶龙格库塔法"
      Case Else
      MsgBox "抱歉，欧拉法尚未实现！", vbInformation, "提醒"
      suanfacom.ListIndex = 0 'suanfacom.Text = "四阶龙格库塔法"
      End Select
End Sub

Private Sub txtBC_LostFocus()
        iBc = txtBC.Text
        iC = qujianc.Text
        iD = qujiand.Text
        If iBc = "" Then
        MsgBox "输入的步长不能为空！", vbInformation, "警告"
        txtBC.Text = (iD - iC) / 10
        Exit Sub
        End If
        If IsNumeric(iBc) = False Then
        MsgBox "输入的步长必须为数字！", vbInformation, "警告"
        txtBC.Text = (iD - iC) / 10
        Exit Sub
        End If
        If CDbl(iBc) > CDbl(iD - iC) Then
        MsgBox "输入的步长必须在区间右端值与区间左端值差之间！", vbInformation, "警告"
        txtBC.Text = (iD - iC) / 10
        Exit Sub
        End If
End Sub
Private Sub txtbxishu_LostFocus()
        iBc = txtbxishu.Text
        If iBc = "" Then
        MsgBox "输入的b系数不能为空！", vbInformation, "警告"
        txtbxishu.Text = 1
        Exit Sub
        End If
        
        If IsNumeric(iBc) = False Then
        MsgBox "输入的b系数必须为数字！", vbInformation, "警告"
        txtbxishu.Text = 1
        Exit Sub
        End If
End Sub

Private Sub xishu_LostFocus()
        num = CInt(jieshu.Text)
        ReDim xs(num)
              sstr = LTrim(xishu.Text)
        '判断初值个数是否吻合
         Dim inum As Integer
             inum = 0
         Do While sstr <> ""
             ino = getSpaceIndex(sstr)
             If ino <> 0 Then inum = inum + 1
             sstr = LTrim(Mid(sstr, ino + 1, Len(sstr) - ino))
         Loop
         
            If inum <> (num + 1) Then
            MsgBox "输入的初值应只有" & num + 1 & "个", vbInformation, "警告"
                zhc = "1 "
            For i = 1 To num
                zhc = zhc & "1 "
            Next
            xishu.Text = zhc
            Exit Sub
            End If
        '判断是否为数值
            sstr = LTrim(xishu.Text)
        For i = 0 To num
            ino = getSpaceIndex(sstr)
            xs(i) = Left(sstr, ino)
            If IsNumeric(xs(i)) = False Then
                MsgBox "输入的系数值必须为数字！", vbInformation, "警告"
                    zhc = "1 "
            For j = 1 To num
                zhc = zhc & "1 "
            Next
            xishu.Text = zhc
                Exit Sub
            End If
           
            sstr = LTrim(Mid(sstr, ino + 1, Len(sstr) - ino))
        Next
        If xs(num) = 0 Then
            MsgBox "输入的高阶系数值必须非零！", vbInformation, "警告"
                    zhc = "1 "
            For j = 1 To num
                zhc = zhc & "1 "
            Next
            xishu.Text = zhc
                Exit Sub
            End If
End Sub