qiuni.frm

采用vb程序语言编写

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3090
   ClientLeft      =   165
   ClientTop       =   855
   ClientWidth     =   4680
   FillColor       =   &H000000FF&
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   ScaleHeight     =   3090
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command2 
      BackColor       =   &H80000005&
      Caption         =   "矩阵相乘"
      Height          =   375
      Left            =   2760
      TabIndex        =   1
      Top             =   2040
      Width           =   1215
   End
   Begin VB.CommandButton Command1 
      Caption         =   "求  逆"
      Height          =   375
      Left            =   480
      TabIndex        =   0
      Top             =   2040
      Width           =   1095
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   4080
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Menu file 
      Caption         =   "文件"
      Begin VB.Menu OpenFile 
         Caption         =   "打开"
      End
      Begin VB.Menu Output 
         Caption         =   "输出"
      End
      Begin VB.Menu eixt 
         Caption         =   "退出"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim InpMatrix1() As Double
Dim InpMatrix2() As Double   '定义输入矩阵
Dim OutMatrixMul() As Double '定义用于存储AB的矩阵
Dim Mline1 As Integer, Mlie1 As Integer
Dim Mline2 As Integer, Mlie2 As Integer

Private Sub Command1_Click()
  MRinv 3, InpMatrix1()
  ' Mchange 3, 3, InpMatrix2, InpMatrix1()
End Sub

Private Sub Command2_Click()
   Mmultiply 4, 3, 3, 4, OutMatrixMul(), InpMatrix1(), InpMatrix2()
   
    
End Sub

Private Sub eixt_Click()
    End
    
End Sub

Private Sub OpenFile_Click()
    Dim linedata As String
    'Dim InpMatrix1() As Dou
    'Dim InpMatrix2() As Double   '定义输入矩阵
    Dim sLen As Long     '每行字符个数
   ' Dim Mline As Integer, Mlie As Integer
    Dim g(10) As Integer, j As Integer
    Dim i As Integer, k As Integer
    Dim j2 As Integer, k0 As Integer
    Static j1 As Integer
    Static jj1 As Integer
    jj1 = 1 '11.21xiugaide
    '*****************************
   ' Dim ii As Integer, kk As Integer
    'Dim jj2 As Integer, kk0 As Integer
    Dim panduan1 As Boolean, panduan2 As Boolean   'panduan1,panduan2用于判断
    
    ReDim InpMatrix1(1 To 4, 1 To 3)
    ReDim InpMatrix2(1 To 3, 1 To 4)
    ReDim OutMatrixMul(1 To 4, 1 To 4) '动态数组
    CommonDialog1.ShowOpen
  '  filename = CommonDialog1.filename
    j = 0: k0 = 0: k = 1: j1 = 1
    panduan1 = True: panduan2 = True
    
   ' g(0) = 1
    If CommonDialog1.FileName = "" And CommonDialog1.FileName <> "*.txt" Then
        MsgBox "请选择文本文件", vbOKOnly + vbYesNo + vbApplicationModal, "警告"
    Else
        Open CommonDialog1.FileName For Input As #1
        Do While Not EOF(1)
            Line Input #1, linedata
        sLen = Len(linedata)
        If Mid(linedata, 1, 11) = "IputMatrix1" Then
            Mline1 = Val(Mid(linedata, 18, 1))
            Mlie1 = Val(Mid(linedata, 23, 1))
            
            
        ElseIf Mid(linedata, 1, 11) <> "IputMatrix2" And panduan2 Then
            'ReDim g(Mlie)
           '  g(0) = 0
            
            For i = 1 To sLen
                If Mid(linedata, i, 1) = "," Then
                  g(k) = i
                  k = k + 1
                  
                End If
                
             Next i
        
            
           ' For j1 = j1 - 1 To Mline
                For j2 = 1 To Mlie1
                    g(0) = 0
                    If k0 = 0 Then
                        InpMatrix1(j1, j2) = Val(Mid(linedata, 1, g(1) - 1))
                        k0 = k0 + 1
                    ElseIf k0 > 0 And k0 < Mlie1 Then
                    
                    InpMatrix1(j1, j2) = Val(Mid(linedata, g(k0) + 1, g(k0 + 1) - 1))
                    k0 = k0 + 1
                    End If
                    
                    Next j2
                  '  Next j1
                    
            'For j2 = 1 To Mlie
               ' g(0) = 0
                
               ' If k0 = 0 Then
               ' InpMatrix1((j1 - 1) * Mlie + j2 - 1) = Val(Mid(linedata, 1, g(1) - 1))
               ' k0 = k0 + 1
               ' ElseIf k0 > 0 And k0 < Mlie Then
                
                
               ' InpMatrix1((j1 - 1) * Mlie + j2 - 1) = Val(Mid(linedata, g(k0) + 1, g(k0 + 1) - 1))
               ' k0 = k0 + 1
               ' Else
               ' InpMatrix1(j1 * (j2 - 1) + j2 - 1) = Val(Mid(linedata, g(k0 - 1) + 1, sLen - g(k0) - 1))
               ' k0 = k0 + 1
              ' End If
                
           ' Next j2
           j1 = j1 + 1
           For j = 0 To 10
            g(j) = 0
           Next j
           k = 1
           'j2 = 1
           k0 = 0
           
         End If
        
     
       If Mid(linedata, 1, 11) = "IputMatrix2" Then
             Mline2 = Val(Mid(linedata, 18, 1))
             Mlie2 = Val(Mid(linedata, 23, 1))
             panduan2 = False
            
        ElseIf Not panduan2 Then
        
            'ReDim g(Mlie)
           '  g(0) = 0
            
            For i = 1 To sLen
                If Mid(linedata, i, 1) = "," Then
                  g(k) = i
                  k = k + 1
                  
                End If
                
             Next i
        
            
          
                For j2 = 1 To Mlie2
                    g(0) = 0
                    If k0 = 0 Then
                        InpMatrix2(jj1, j2) = Val(Mid(linedata, 1, g(1) - 1))
                        k0 = k0 + 1
                    ElseIf k0 > 0 And k0 < Mlie2 Then
                    
                    InpMatrix2(jj1, j2) = Val(Mid(linedata, g(k0) + 1, g(k0 + 1) - 1))
                    k0 = k0 + 1
                    End If
                    
                    Next j2
                
           jj1 = jj1 + 1
           For j = 0 To 10
            g(j) = 0
           Next j
           k = 1
           'j2 = 1
           k0 = 0
        End If
        
        
        
        sLen = 0#
        Loop
        Close #1
     
    
    End If
    
End Sub


'****************************
Private Function MRinv(N As Integer, mtxA() As Double) As Boolean

'****************************************************************************************
'  功能：  实矩阵求逆的全选主元高斯－约当法
'  参数：  n      - Integer型变量，矩阵的阶数
'          mtxA   - Double型二维数组，体积为n x n。存放原矩阵A；返回时存放其逆矩阵A-1。
'  返回值：Boolean型，失败为False，成功为True
'****************************************************************************************

ReDim nIs(N) As Integer, nJs(N) As Integer
Dim i As Integer, j As Integer, k As Integer
Dim D As Double, p As Double

' 全选主元，消元
For k = 1 To N
    D = 0#
    For i = k To N
        For j = k To N
            p = Abs(mtxA(i, j))
            If (p > D) Then
                D = p
                nIs(k) = i
                nJs(k) = j
            End If
        Next j
    Next i
    
    ' 求解失败
    If (D + 1# = 1#) Then
        MRinv = False
        Exit Function
    End If

    If (nIs(k) <> k) Then
        For j = 1 To N
            p = mtxA(k, j)
            mtxA(k, j) = mtxA(nIs(k), j)
            mtxA(nIs(k), j) = p
        Next j
    End If

    If (nJs(k) <> k) Then
        For i = 1 To N
            p = mtxA(i, k)
            mtxA(i, k) = mtxA(i, nJs(k))
            mtxA(i, nJs(k)) = p
        Next i
    End If

    mtxA(k, k) = 1# / mtxA(k, k)
    For j = 1 To N
        If (j <> k) Then mtxA(k, j) = mtxA(k, j) * mtxA(k, k)
    Next j
    For i = 1 To N
        If (i <> k) Then
            For j = 1 To N
                If (j <> k) Then mtxA(i, j) = mtxA(i, j) - mtxA(i, k) * mtxA(k, j)
            Next j
        End If
    Next i
    For i = 1 To N
        If (i <> k) Then mtxA(i, k) = -mtxA(i, k) * mtxA(k, k)
    Next i
Next k

' 调整恢复行列次序
For k = N To 1 Step -1
    If (nJs(k) <> k) Then
      For j = 1 To N
          p = mtxA(k, j)
          mtxA(k, j) = mtxA(nJs(k), j)
          mtxA(nJs(k), j) = p
      Next j
    End If
    If (nIs(k) <> k) Then
      For i = 1 To N
          p = mtxA(i, k)
          mtxA(i, k) = mtxA(i, nIs(k))
          mtxA(i, nIs(k)) = p
      Next i
    End If
Next k

' 求解成功
MRinv = True
End Function
'****************************************
'矩阵求和函数
'*******************************************
Private Function Msum(M As Integer, N As Integer, Matrixsum() As Double, Matrix1() As Double, Matrix2() As Double)
   Dim i1 As Integer, i2 As Integer
   ReDim Matrixsum(1 To M, 1 To N)
   For i1 = 1 To M
        For i2 = 1 To N
            Matrixsum(i1, i2) = Matrix1(i1, i2) + Matrix2(i1, i2)
        Next i2
        
    Next i1
       
End Function
'****************************************
'矩阵求差函数
'*******************************************
Private Function Mminus(M As Integer, N As Integer, MatrixMinus() As Double, Matrix1() As Double, Matrix2() As Double)
    Dim i1 As Integer, i2 As Integer
    ReDim MatrixMinus(1 To M, 1 To N)
    For i1 = 1 To M
        For i2 = 1 To N
        MatrixMinus(i1, i2) = Matrix1(i1, i2) - Matrix2(i1, i2)
        Next i2
        Next i1
End Function
_
'****************************************
'矩阵转置函数  Matrix1(）需转置的矩阵，Matrixchange()为转置后的矩阵
'*******************************************
Private Function Mchange(M As Integer, N As Integer, Matrixchange() As Double, Matrix1() As Double)
    Dim i1 As Integer, i2 As Integer
    ReDim Matrixchange(N, M)   '动态分配用来存储转置后的矩阵
    For i1 = 1 To M
        For i2 = 1 To N
        Matrixchange(i2, i1) = Matrix1(i1, i2)
        Next i2
        Next i1
End Function
'****************************************
'矩阵想乘函数，MatrixMultiply()为存储AB后的矩阵，Matrix1()为A矩阵，Matrix2()为B矩阵,注意矩阵想乘的顺序
'Mi为行，Ni为列,i=1,2
'*******************************************
Private Function Mmultiply(M1 As Integer, N1 As Integer, M2 As Integer, N2 As Integer, MatrixMultiPly() As Double, Matrix1() As Double, Matrix2() As Double)
    Dim i1 As Integer, i2 As Integer, i3 As Integer
    If N1 <> M2 Then
        MsgBox "两矩阵不能想乘，请检查！", vbOKCancel + vbCritical + vbDefaultButton1
        Exit Function
    End If
    ReDim MatrixMultiPly(1 To M1, 1 To N2) As Double
    For i1 = 1 To M1
     
        For i2 = 1 To N2
         MatrixMultiPly(i1, i2) = 0
            For i3 = 1 To N1
             MatrixMultiPly(i1, i2) = MatrixMultiPly(i1, i2) + Matrix1(i1, i3) * Matrix2(i3, i2)
         
         Next i3
         Next i2
        Next i1
End Function
Private Sub Output_Click()
 Dim outstring As String
 Dim i1 As Integer, i2 As Integer
 CommonDialog1.ShowSave
 If CommonDialog1.FileName <> "*.txt" And CommonDialog1.FileName <> "" Then
  Open CommonDialog1.FileName For Output As #2
   ' For i = 0 To List1.ListCount - 1
   ' dt = dt + List1.List(i)
  outstring = "结果输出:" + vbCrLf
  
  For i1 = 1 To Mline1
    For i2 = 1 To Mlie1
        'outstring = outstring + Str(OutMatrixMul(i1, i2)) + ","
        'outstring = outstring + Format(OutMatrixMul(i1, i2), "######.0000") + ",    "   'format()格式化输出函数
        outstring = outstring + Format(InpMatrix1(i1, i2), "######.0000") + ",    "
     Next i2
        outstring = outstring + vbCrLf
    Next i1
      
  Print #2, outstring
  Close #2
  Else
  MsgBox "没有数据可以保存,请输入数据!", vbInformation, "保存数据文件"
 End If
End Sub
'********************************************