home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 08 / spielth / spielth2.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1979-12-31  |  5.0 KB  |  148 lines
  1. program Simplex_Algorithmus;
  2.  
  3.   const  m_max = 5;
  4.          n_max = 6;
  5.  
  6.   type  Schema = array [0..m_max, 0..n_max] of real;
  7.  
  8.                                (* die eigentliche Matrix steht in
  9.                                   [1..m_max-1, 1..n_max-2].
  10.                                   Die anderen Indizes stehen fuer:
  11.                                      - die Indizes i & k  (0;0)
  12.                                      - die b bzw. z       (m_max;n_max-1)
  13.                                      - die b/a            (?;n_max)
  14.                                      - Q steht in [m_max,n_max-1]         *)
  15.  
  16.   var  S, S_neu : Schema;
  17.        m, n     : byte;
  18.  
  19.   procedure Eingabe;           (* Eingabe des Schemas S *)
  20.    var i, j: byte;
  21.     begin
  22.       ClrScr;
  23.       Write('Anzahl der Zeilen : '); ReadLn(m);
  24.       Write('Anzahl der Spalten: '); ReadLn(n);
  25.  
  26.       for i := 1 to n do S[0,i] := i;       (* Initialisierung der Indizes *)
  27.       for i := 1 to m do S[i,0] := n+i;
  28.  
  29.       ClrScr;
  30.       WriteLn('Eingabe der Matrix:'); WriteLn;
  31.       for i := 1 to m do
  32.         begin
  33.           for j := 1 to n do
  34.             begin
  35.               Write(i,'. Zeile, ', j,'. Spalte: '); ReadLn(S[i,j])
  36.             end;
  37.           WriteLn
  38.         end;
  39.  
  40.       ClrScr;
  41.       WriteLn('Eingabe des Vektors b:'); WriteLn;
  42.       for i := 1 to m do
  43.         begin
  44.           Write(i,'. Komponente: '); ReadLn(S[i,n+1])
  45.         end;
  46.  
  47.       ClrScr;
  48.       WriteLn('Eingabe der Komponenten der Zielfunktion z:'); WriteLn;
  49.       for i := 1 to n do
  50.         begin
  51.           Write(i,'. Komponente: '); ReadLn(S[m+1,i])
  52.         end;
  53.  
  54.       for i := 1 to m do S[i,n+2] := 0.0;    (* Letzte Spalte zunaechst leer *)
  55.  
  56.       S[m+1,n+1] := 0.0                      (* Zielfunktion Q zunaechst 0 *)
  57.     end;
  58.  
  59.   procedure Ausgabe;               (* gibt das Schema S aus *)
  60.     var i, j: byte;
  61.     begin
  62.       WriteLn; WriteLn;
  63.       Write('     ');
  64.       for i := 1 to n do Write(S[0,i]:8:0);
  65.       WriteLn;
  66.       for i := 0 to n+2 do Write('---------');
  67.       WriteLn;
  68.       for i := 1 to m do
  69.         begin
  70.           Write(S[i,0]:3:0, ' |');
  71.           for j := 1 to n do Write(S[i,j]:8:2);
  72.           Write(' | ', S[i,n+1]:8:2, ' | ');
  73.           if S[i,n+2] <> 0.0 then WriteLn(S[i,n+2]:8:2)
  74.                              else WriteLn('--':5)
  75.         end;
  76.       for i := 0 to n+2 do Write('---------');
  77.       WriteLn;
  78.       Write('     ');
  79.       for i := 1 to n do Write(S[m+1,i]:8:2);
  80.       WriteLn(' | ',S[m+1,n+1]:8:2)
  81.     end;
  82.  
  83.   procedure Simplex;
  84.     var i, k,
  85.         pivot_zeile, pivot_spalte: byte;
  86.         min, pivot               : real;
  87.     begin
  88.       repeat
  89.         pivot_spalte := 1;                   (* Ermittlung der Pivotspalte *)
  90.         while (pivot_spalte <= n) and (S[m+1,pivot_spalte] <= 0.0) do
  91.           pivot_spalte := Succ(pivot_spalte);
  92.  
  93.         if pivot_spalte <= n then
  94.           begin
  95.             min := 1e8; pivot_zeile := 0;    (* Ermittlung der Pivotzeile *)
  96.             for k := 1 to m do
  97.               if S[k,pivot_spalte] > 0.0 then
  98.                 begin
  99.                   S[k,n+2] := S[k,n+1] / S[k,pivot_spalte];  (* Quotient b/a *)
  100.                   if S[k,n+2]<min then
  101.                     begin
  102.                       min := S[k,n+2]; pivot_zeile := k
  103.                     end
  104.                 end
  105.               else S[k,n+2] := 0.0;          (* Quotient nicht zu ermitteln *)
  106.  
  107.             if pivot_zeile > 0 then
  108.               begin
  109.                 Ausgabe; WriteLn;
  110.                 WriteLn('Pivotzeile: ',pivot_zeile,'  Pivotspalte: ',pivot_spalte);
  111.                 repeat until KeyPressed;
  112.  
  113.                 S_neu := S;                     (* zur Uebernahme der Indizes *)
  114.                 S_neu[0,pivot_spalte] := S[pivot_zeile,0];  (* Index-Tausch *)
  115.                 S_neu[pivot_zeile,0] := S[0,pivot_spalte];
  116.  
  117.                 pivot := S[pivot_zeile,pivot_spalte];   (* das Pivotelement *)
  118.                 S_neu[pivot_zeile,pivot_spalte] := 1/pivot;
  119.  
  120.                 for i := 1 to n+1 do           (* Elemente der Pivotzeile *)
  121.                   if i <> pivot_spalte then
  122.                     S_neu[pivot_zeile,i] := S[pivot_zeile,i] / pivot;
  123.  
  124.                 for k := 1 to m+1 do           (* Elemente der Pivotspalte *)
  125.                   if k <> pivot_zeile then
  126.                     S_neu[k,pivot_spalte] := -S[k,pivot_spalte] / pivot;
  127.  
  128.                 for k := 1 to m+1 do           (* die restlichen Elemente *)
  129.                   if k <> pivot_zeile then
  130.                     for i := 1 to n+1 do
  131.                       if i <> pivot_spalte then
  132.                         S_neu[k,i] := S[k,i] - S[pivot_zeile,i]*S[k,pivot_spalte]/pivot;
  133.  
  134.                 S := S_neu
  135.               end
  136.           end
  137.       until (pivot_spalte > n) or (pivot_zeile = 0);
  138.  
  139.       for k := 1 to m do S[k,n+2] := 0.0;     (* Loeschen der letzten Spalte *)
  140.       WriteLn; WriteLn; WriteLn('Loesung:',#7); Ausgabe
  141.     end;
  142.  
  143.   begin
  144.     Eingabe;
  145.     ClrScr;
  146.     Simplex
  147.   end.
  148.