fun.bas

本程序是在原来的单纯形法基础上改进的,主要用于分枝界定法求解的整数规划。 修正的地方： １．运用勃兰特原则 ２.人机互动

Attribute VB_Name = "fun"
'单纯形法
Public Sub lineprog(A, b, C, ibs, m, n)
  Dim Cb() As Single, xgm() As Single, st()  As Single
  Dim sum!, Col%, Row%
  Dim Cycle As Integer
  Dim aij As Single, rate As Single

  Dim i%, j%
  Dim tt As Integer '判断非基变量用
  ReDim xgm(m) '检验数
  ReDim st(n, 2) '替换变量规则'
  ReDim Cb(n) '基变量的价值系数
  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, 1) = b(j) / A(j, Col)
          st(j, 2) = ibs(j)
        Else
          st(j, 1) = 9999
          st(j, 2) = ibs(j)
        End If
      Next j
      stMin st, Row, n '寻找最小θ函数

      If Is_Stop(xgm, ibs, m, n, cs) = True Then '是否找到最优解


        
        For j = 1 To n
          If ibs(j) = 2 Then XX(2) = b(j)
          If ibs(j) = 1 Then XX(1) = b(j)
        Next j
         XX(3) = result
        If cs = "非基变量有等于0!" Then

            MsgBox "因为非基变量有等于0，所以该线性规划为无穷解！"
        End If
         Exit For
      End If
      If Is_Bound(xgm, m, n) = True Then

        MsgBox "该线性规划无最优解!"
        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

End Sub
'寻找检验数最大σ函数
Public Sub xgmMax(xgm, No, m)
  Dim max As Single, i%
  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
'寻找最小θ函数
Public Sub stMin(st, Row, n)
  Dim stNo() As Integer
  Dim min0!, j%, i%, d%
  min0 = st(1, 1)
  For j = 1 To n
     If st(j, 1) < min0 Then
       min0 = st(j, 1)
     End If
  Next j
  Dim iSame%
  iSame = 0
  For i = 1 To n
    If Abs(st(i, 1) - min0) < 0.0001 Then iSame = iSame + 1
  Next i
  ReDim Preserve stNo(iSame, 2)
  d = 0
  For i = 1 To n
    If Abs(st(i, 1) - min0) < 0.0001 Then
       d = d + 1
       stNo(d, 1) = st(i, 2)
       stNo(d, 2) = i
    End If
  Next i
  Dim min1!, row1%
  min1 = stNo(1, 1)
  row1 = 1
  For j = 1 To iSame
     If stNo(j, 1) < min1 Then
       min1 = stNo(j, 1)
       row1 = j
     End If
  Next j
  Row = stNo(row1, 2)
End Sub
'判定解是否最优函数
Public Function Is_Stop(xgm, ibs, m, n, cs) As Boolean
  Dim tt As Integer, i%, j%
  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