frmmain.frm

适合解线性规划问题

VERSION 5.00
Begin VB.Form FrmMain 
   Caption         =   "单纯形法"
   ClientHeight    =   6870
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7890
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   ScaleHeight     =   6870
   ScaleWidth      =   7890
   StartUpPosition =   2  'CenterScreen
   Begin VB.PictureBox Picture1 
      Height          =   2895
      Left            =   120
      ScaleHeight     =   2835
      ScaleWidth      =   5355
      TabIndex        =   8
      Top             =   3000
      Width           =   5415
   End
   Begin VB.Frame Frame1 
      Caption         =   "有无人工变量"
      Height          =   2415
      Left            =   5880
      TabIndex        =   5
      Top             =   240
      Width           =   1815
      Begin VB.OptionButton Opt_No 
         Caption         =   "无人工变量"
         ForeColor       =   &H000000FF&
         Height          =   495
         Left            =   240
         TabIndex        =   7
         Top             =   720
         Width           =   1215
      End
      Begin VB.OptionButton Opt_Yes 
         Caption         =   "有人工变量"
         ForeColor       =   &H000000FF&
         Height          =   495
         Left            =   240
         TabIndex        =   6
         Top             =   1320
         Width           =   1215
      End
   End
   Begin VB.CommandButton Cmd_Exit 
      Caption         =   "退出"
      Height          =   495
      Left            =   3360
      TabIndex        =   4
      Top             =   6120
      Width           =   1575
   End
   Begin VB.Frame Frame2 
      Caption         =   "输入阵列"
      Height          =   2535
      Left            =   120
      TabIndex        =   1
      Top             =   120
      Width           =   5415
      Begin VB.TextBox TxtSubject 
         Height          =   1455
         Left            =   480
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   3
         Top             =   840
         Width           =   4455
      End
      Begin VB.Label Label3 
         Caption         =   "阵列数据"
         ForeColor       =   &H000000FF&
         Height          =   375
         Left            =   2160
         TabIndex        =   2
         Top             =   360
         Width           =   855
      End
   End
   Begin VB.CommandButton Cmd_Calcuate 
      Caption         =   "计算"
      Height          =   495
      Left            =   1200
      TabIndex        =   0
      Top             =   6120
      Width           =   1575
   End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'如果没有人工变量的话，此程序就为普通单纯形法。
'如果有人工变量，此程序可用于两阶断的第二阶段运算
'编制者董延军
'[e-mail]
Option Explicit
Dim A() As Single, Cb() As Single, ibs() As Integer, C() As Single, _
   xgm() As Single, st() As Single, b() As Single
Dim strFile As String, strOutfile As String '文件名
Dim Result As Single '目标函数值
Dim intStop As Integer, intBound As Integer
Dim m%, n% 'm为变量个数，n为约束条件个数中
Dim sum!, Col%, Row%
Dim Cycle As Integer
Dim aij As Single, rate As Single
Dim cs As String
Private Sub Cmd_Calcuate_Click()
  Dim i%, j%
  On Error GoTo myError
  FrmMain.Cls
  Picture1.Cls
  cs = ""
  Dim Filenumber As Integer
  Dim tt As Integer '判断非基变量用
  Dim strPrint As String, strPrintResult As String
  Filenumber = FreeFile
  Open strFile For Input As #Filenumber
  Open strOutfile For Output As #3
  Input #Filenumber, m, n
  ReDim C(m) '价值系数
  ReDim ibs(n) '基变量序列号
  ReDim xgm(m) '检验数
  ReDim st(n)  '替换变量规则
  ReDim A(n, m) '约束矩阵
  ReDim Cb(n) '基变量的价值系数
  ReDim b(n)  '右端项值
  For i = 1 To m   'i代表横向,j代表纵向
     Input #Filenumber, C(i)
  Next i
  For j = 1 To n
     Input #Filenumber, ibs(j)
  Next j
  For j = 1 To n
     For i = 1 To m
       Input #Filenumber, A(j, i)
     Next i
     Input #Filenumber, b(j)
  Next j
  Close #Filenumber
  For j = 1 To n
      Cb(j) = C(ibs(j))
  Next j
  '此部分为单纯形法核心部分
  '##########################################第一大部分############################
  For Cycle = 1 To cycleMax
      '求得基变量价值系数的值
      Result = 0
      For j = 1 To n
         Result = Result + Cb(j) * b(j) '此式计算出目标函数值Z
      Next j
      '下面部分求得检验数σ
      For i = 1 To m
        sum = 0
        For j = 1 To n
          sum = sum + Cb(j) * A(j, i)
        Next j
        xgm(i) = C(i) - sum
      Next i
      xgmMax xgm, Col, m '找出检验数σ最大值
      For j = 1 To n
        If A(j, Col) > Eps Then
          st(j) = b(j) / A(j, Col)
        Else
          st(j) = 9999
        End If
      Next j
      stMin st, Row, n '寻找最小θ函数

  
  '##########################################第一大部分############################
      '输出结果
      Print #3, "          =================================="
      Print #3, "                    第" & Cycle & "迭代"
      Print #3, "          ================================="
      strPrint = ""
      strPrintResult = ""
      For j = 1 To n
         strPrint = Format(Cb(j), "0.00") & "   " & "X" & Format(ibs(j), "0") & "   " & Format(b(j), "0.00")
         For i = 1 To m
           strPrint = strPrint & "   " & Format(A(j, i), "0.00")
         Next i
         strPrint = strPrint & "   " & Format(st(j), "0.00")
         Print #3, strPrint
      Next j
      strPrintResult = strPrintResult & "      -Z     " & Format(-Result, "0.00")
      For i = 1 To m
         strPrintResult = strPrintResult & "   " & Format(xgm(i), "0.00")
      Next i
      Print #3, strPrintResult
      If Is_Stop(xgm, ibs, m, n, cs) = True Then '是否找到最优解
        If Opt_Yes.Value = True Then
           If Result <> 0 Then
              Picture1.Print "加人工变量后，当得到最优解时，由于w≠0,所以原问题无最优解!"
              Exit For
           End If
        End If
        Print #3,
        Picture1.Print "                         最优解"
        Picture1.Print "          =================================="
        Print #3, "          =================================="
        Print #3, "                    最优解"
        Print #3, "          =================================="
        For j = 1 To n
          Picture1.Print , "X" & ibs(j) & "=" & Format(b(j), "0.00")
          Print #3, "                   X" & ibs(j) & "=" & Format(b(j), "0.00")
        Next j
        For i = 1 To m
           tt = 0
           For j = 1 To n
              If i = ibs(j) Then
                tt = tt + 1
              End If
           Next j
           If tt = 0 Then
              Picture1.Print , "X" & i & "=" & Format(0, "0.00")
              Print #3, "                   X" & i & "=" & Format(0, "0.00")
           End If
         Next i
         Print #3, "          =================================="
         Print #3, "                   Z*=" & Format(Result, "0.00")
         Picture1.Print "                   ================="
         Picture1.Print "                      Z*=" & Format(Result, "0.00")
         If Opt_No.Value = True Then
            If cs = "非基变量有等于0!" Then
              Print #3, "&&&&&&&&&&&&&&&&&"
              Print #3, "因为非基变量有等于0，所以该线性规划为无穷解！"
              Picture1.Print "&&&&&&&&&&&&&&&&&"
              Picture1.Print "因为非基变量有等于0，所以该线性规划为无穷解！"
            End If
         End If
         Exit For
      End If
      If Is_Bound(xgm, m, n) = True Then
        Picture1.Print "&&&&&&&&&&&&&&&&&"
        Picture1.Print "该线性规划无最优解!"
        Exit For
      End If
  '##########################################第二大部分############################
     '如果没找到解且有解，下面将完成旋转运算迭代
      ibs(Row) = Col '进基与出基转化
      Cb(Row) = C(Col)
      aij = A(Row, Col)
      If aij = 0 Then
         MsgBox "aij=0,请检查数据或者程序后再运行！", 0 + 16 + 0, "程序运行有故障"
         Exit Sub
      End If
      b(Row) = b(Row) / aij
      For i = 1 To m
        A(Row, i) = A(Row, i) / aij
      Next i
      '进行矩阵初等行变化
      For j = 1 To Row - 1
        If A(j, Col) <> 0 Then
           rate = A(j, Col)
           For i = 1 To m
              A(j, i) = A(j, i) - A(Row, i) * rate
           Next i
           b(j) = b(j) - b(Row) * rate
        End If
      Next j
      For j = Row + 1 To n
        If A(j, Col) <> 0 Then
           rate = A(j, Col)
           For i = 1 To m
             A(j, i) = A(j, i) - A(Row, i) * rate
           Next i
           b(j) = b(j) - b(Row) * rate
        End If
      Next j
  '##########################################第二大部分############################
  Next Cycle
  Close #3
  Exit Sub
myError:
MsgBox "输入的文件结构可能不符合要求，请检查后重试！", 0 + 16 + 0, "程序运行有故障"
End Sub
'寻找检验数最大σ函数
Private Sub xgmMax(xgm, No, m)
  Dim i%
  Dim max As Single
  max = 0
  No = 1
  For i = 1 To m
     If xgm(i) > max Then
       max = xgm(i)
       No = i
     End If
  Next i
End Sub
'寻找最小θ函数
Private Sub stMin(st, Row, n)
  Dim min As Single
  Dim i%, j%
  min = st(1)
  Row = 1
  For j = 1 To n
     If st(j) < min Then
       min = st(j)
       Row = j
     End If
  Next j
End Sub
'判定解是否最优函数
Public Function Is_Stop(xgm, ibs, m, n, cs) As Boolean
  Dim i%, j%
  Dim tt As Integer
  intStop = 0
  For i = 1 To m
    If xgm(i) > 0 Then
      intStop = intStop + 1
    End If
  Next i
  If intStop = 0 Then
     Is_Stop = True '如果对应检验系数小于0，则找到最优解
     For i = 1 To m
         tt = 0
         For j = 1 To n
           If i = ibs(j) Then
             tt = tt + 1
           End If
         Next j
         If tt = 0 Then
           If xgm(i) = 0 Then cs = "非基变量有等于0!"
         End If
     Next i
  Else
     Is_Stop = False
  End If
End Function
'判定解是否有界函数
Public Function Is_Bound(xgm, m, n) As Boolean
  Dim i%, j%
  For i = 1 To m
       intBound = 0
       If xgm(i) > 0 Then
          For j = 1 To n
            If A(j, i) <= 0 Then intBound = intBound + 1
          Next j
          If intBound = n Then
             Is_Bound = True  '如果对应检验系数大于0，那么矩阵aij<=0,则无界
             Exit For
          Else
             Is_Bound = False
          End If
       End If
  Next i
End Function
Private Sub Cmd_Exit_Click()
  End
End Sub
Private Sub Form_Load()
  strFile = App.Path + "\inifile\matrix.txt"
  strOutfile = App.Path + "\inifile\outfile.txt"
  Opt_No = True
End Sub
Private Sub TxtSubject_KeyUp(KeyCode As Integer, Shift As Integer)
  Dim Filenumber As Integer
  Filenumber = FreeFile
  Open strFile For Output As #Filenumber
  Print #1, TxtSubject.Text
  Close #Filenumber
End Sub