Linear Programming Using Dual Simplex method

Question

I want to solve an optimization problem using the Dual Simplex Method. Although Mathematica gives the result directly when I use the command Minimize but I want to get the tableau results for every iterations. How can I do that? Any help is highly appreciated.

Answer 1

You can use this. The code is not at all elegant but it works really well. It is designed to handle any number of variables and constraints. Just encode the constraints and the objective function, the objective function as the last element of the array. It will automatically construct the simplex tableau, determine the pivot elements, reduce rows, until reaching the final tableau.

 Module[{A = {{1, 2, 3/2, 12000},
 {2/3, 2/3, 1, 4600},
 {1/2, 1/3, 1/2, 2400},
 {11, 16, 15, 0}}}, Atemp = {};
  constraints = Length[A] - 1;
  variables = Length[A[[1]]] - 1;
  A[[Length[A]]] = -A[[Length[A]]];
  c = Table[A[[i]][[variables + 1]], {i, 1, Length[A]}];

  echelon = Append[IdentityMatrix[constraints], Table[0, {i, 1, constraints}]];

  For[i = 0, i < Length[A], i++; A[[i]] = Drop[A[[i]], {variables + 1}]];
  For[i = 0, i < Length[A], i++;For[k = 0, k < constraints, k++;A[[i]] =Append[A[[i]],echelon[[i]][[k]]]]];

 (*Setting up the slack variables*)

 For[i = 0, i < Length[A], i++; A[[i]] = Append[A[[i]], c[[i]]]];vars = Table[Subscript[x, i], {i, 1, variables}];slack = Table[Subscript[s, i], {i, 1, constraints}];
 For[i = 0, i < Length[slack], i++;vars = Append[vars, slack[[i]]]];vars = Append[vars, "C"];

 Atemp = Append[Atemp, A];
(*Performing the Simplex Method*)
iteration = 1;
Subscript[pivot, iteration] = {};
While[Min[A[[Length[A]]]] < 0,Subscript[text, iteration] = {};

   (*Finding the Pivot column*)

   For[col = 0, col < Length[A] + 1, col++;
If[A[[Length[A]]][[col]] == Min[A[[Length[A]]]], Break[]]
];
 (*Finding the Pivot row*)

 cols = Table[A[[j]][[col]], {j, 1, constraints}];
  tem = Table[A[[k]][[Length[A[[1]]]]], {k, 1, Length[A] - 1}];
    If[Min[cols] <       0,For[i = 0, i < Length[cols], i++;If[cols[[i]] < 0 || cols[[i]] == 0,cols = ReplacePart[cols, i -> x]]],
If[Min[cols] == 0,For[i = 0, i < Length[cols], i++;If[cols[[i]] == 0, cols = ReplacePart[cols, i -> x]]]]];
     temp = Table[tem[[i]]/cols[[i]], {i, 1, Length[tem]}];
      If[Length[Min[temp]] > 1,For[row = 0, row < Length[temp], row++;If[temp[[row]] == Min[temp][[1]], Break[]]],For[row = 0, row < Length[temp], row++;If[temp[[row]] == Min[temp], Break[]]]];

  (*Performing Gaussian Elimination*)

 Subscript[text, iteration] = Append[Subscript[text, iteration],StringForm["R`` \[DoubleLongLeftRightArrow] ``R``", row, If[A[[row]][[col]] == 0, 0, 1/A[[row]][[col]]], row]];

  If[A[[row]][[col]] == 0, A[[row]] = A[[row]],A[[row]] = A[[row]]/A[[row]][[col]]];For[j = 0, j < Length[A] - 1, j++;If[row + j < Length[A] + 1,
 Subscript[text, iteration] = 
  Append[Subscript[text, iteration], 
   StringForm["R`` \[DoubleLongLeftRightArrow] ``R`` + R``", 
    row + j, -A[[row + j]][[col]], row, row + j]];
 A[[row + j]] = A[[row + j]] - A[[row + j]][[col]]*A[[row]],
 Subscript[text, iteration] = 
  Append[Subscript[text, iteration], 
   StringForm[
    "R`` \[DoubleLongLeftRightArrow] ``R`` + R``", (row + j) - 
     Length[A], -A[[(row + j) - Length[A]]][[col]], 
    row, (row + j) - Length[A]]];
 A[[(row + j) - Length[A]]] = 
  A[[(row + j) - Length[A]]] - 
   A[[(row + j) - Length[A]]][[col]]*A[[row]]
 ]
];
   Subscript[pivot,iteration] = {"Pivot Element:", StringForm["col:`` ", col], 
 StringForm["row:`` ", row]};
  Atemp = Append[Atemp, A];
  iteration += 1;
 ];
    Subscript[text, iteration] = "";
    Subscript[pivot, iteration] = "";
  ];
      Manipulate[Column[{Style[TableForm[Atemp[[iteration]], TableHeadings -> {{""}, vars}],Large],Spacer[100],Row[{Column[{Subscript[pivot, iteration] // TableForm}],Spacer[100], Subscript[text, iteration] // TableForm}]},Alignment -> Center], {iteration, Table[n, {n, 1, Length[Atemp]}]}, ControlType -> SetterBar, ContentSize -> Automatic]

It can be easily altered to perform minimization by inserting A=Transpose[A];

   Module[{A = {{1, 2, 3/2, 12000},
 {2/3, 2/3, 1, 4600},
 {1/2, 1/3, 1/2, 2400},
 {11, 16, 15, 0}}}, Atemp = {};
  A=Transpose[A];(*Insert Here*)

Answer 2

You can try this, where you enter the tableau as an array and the pivot point you want to use for the current iteration.

reducesimplex[sim0_List, {pivRow_Integer, pivCol_Integer}] := 
  Module[{sim = sim0, piv = {pivRow, pivCol}}, 
    sim[[piv[[1]]]] = sim[[piv[[1]]]]/sim[[piv[[1]], piv[[2]]]];
    reducerows = Delete[Range[4], {piv[[1]]}];
    reducerows = DeleteCases[reducerows, Flatten@Position[Flatten[sim[[All, piv[[2]]]]], 0]];
    (sim[[#]] = -sim[[#, piv[[2]]]] sim[[piv[[1]]]] + sim[[#]]) & /@ reducerows;
    simplex = sim;
  ]

I have a very messy way of finding the pivot point for the next iteration if you need that as well.

(Note: This was made for 3 constraint variables and 3 slack variables only. Also, simplex tableau that is being inputted must be a feasible solution.)

findpivot[sim0_List] :=
  Module[{sim = sim0},
    enter = Flatten@Position[sim[[4, 1 ;; 6]], Min[DeleteCases[sim[[4, 1 ;; 6]], 0]]];
    ratios = Table[If[sim[[i, #]] != 0, sim[[i, 7]]/sim[[i, #]], Null], {i, 3}] & /@ enter;

    If[Flatten@Position[ratios, _?Negative] != {}, 
      If[Length[Position[ratiocheck, _?Negative]] >= 2, 
        ratiocheck = ratios; (ratiocheck[[#, #]] = Null) & /@ Position[ratiocheck, _?Negative], 
        ratiocheck = Flatten[Table[ratios, Length[Position[ratios, _?Negative]]], 1];
        (ratiocheck[[##]] = Null) & @@ Flatten@Position[ratiocheck, _?Negative];
        DeleteDuplicates[ratiocheck];],
      ratiocheck = ratios;];

    leastNonneg = Flatten@Position[ratiocheck, Min[ratiocheck /. {Null -> Nothing}]];

    If[leastNonneg == {}, 
      enter = Flatten@Position[sim[[4, 1 ;; 6]], 
      Min[DeleteCases[Drop[sim[[4, 1 ;; 6]], enter], 0]]];
      ratios = Table[If[sim[[i, #]] != 0, sim[[i, 7]]/sim[[i, #]], Null], {i,3}] & /@ enter;

      If[Flatten@Position[ratios, _?Negative] != {}, 
        If[Length[Position[ratiocheck, _?Negative]] >= 2, 
          ratiocheck = ratios; (ratiocheck[[#, #]] = Null) & /@ Position[ratiocheck, _?Negative], 
          ratiocheck = Flatten[Table[ratios, Length[Position[ratios, _?Negative]]], 1];
          (ratiocheck[[##]] = Null) & @@ Flatten@Position[ratiocheck, _?Negative]; 
          DeleteDuplicates[ratiocheck];     
        ],
        ratiocheck = ratios;];

    leastNonneg = Flatten@Position[ratiocheck, Min[ratiocheck /. {Null -> Nothing}]];
    ];

    pivot = {leastNonneg[[2]], enter[[leastNonneg[[1]]]]};
  ]

Like I said, messy, but it works as far as I have seen. There are much more concise ways of going about this I'm sure.