Gaussova eliminácia - výpočet neznámých sústav lineárních rovnic

{ GAUSS.PAS                                Copyright (c) Ales Kucik }
{ Tento jednoduchý programek slouzi k vypoctu neznamych soustav     }
{ linearnich rovnic. Vyuziva Gaussovy eliminace, ktera lze snadno   }
{ vyjadrit jako algoritmus. Dejme tomu ze mame                      }
{ lin. rovnice: 3x + 5y = 19, 2x + 4y = 14                          } 
{ V programu proto postupne zadate cisla 3, 5, 19, 2, 4, 14         }
{ a program na vystupu vrati koreny x1= 3, x2= 2                    } 
{                                                                   }
{ Racte si to vyzkouset sami. Program je limitovan konstantou       }
{ MAX na 10 neznamich, ale klidne muzete tuto konstantu zvetsit.    }
{                                                                   }
{ Datum:29.11.2002                             http://www.trsek.com }
 
Program Gaussova_eliminace;
{
Pokud vam jde o co nejvetsi rychlost odstrante vypis matic v prubehu
vypoctu a samozrejme taky proceduru delay za vypisem.
Pokud chcete pocitat s vice jak 10 promennyma staci zmenit konstantu MAX
}
 
Uses crt;
Const max=10;
Type matice = array[1..max,1..max] of real;
Var a:matice;
    i,j,f,g,e,s:byte;
    y:real;
    c,d:boolean;
 
procedure plneni (var b:matice);
var m,n:byte;
  begin
    for m:=1 to s do
      begin
        writeln('Zadej a,b... a z podle: a*x + b*y + ... = z, v ',m,' radku');
        for n:=1 to (s+1) do
          read(b[m,n]);
        writeln;
      end;
  end;
 
procedure vypis (var b:matice);
var m,n:byte;
  begin
    for m:=1 to s do
      begin
        for n:=1 to (s+1) do
          write(b[m,n]:6,'  ');
        writeln;
      end;
  end;
 
procedure nula (m:byte; var b:matice);
  var n,k:byte;
      z:real;
begin
  n:=m;k:=m;
  while (b[m,n]=0) and (m<=s) do   {Test na 0 v danem prvku diagonaly}
    begin
      m:=m+1;
      if b[m,n]<>0 then            {Test na 0 v nizsim radku}
        for n:=1 to s+1 do
          begin
            z:=b[m,n];             {Prohozeni radku}
            b[m,n]:=b[k,n];
            b[k,n]:=z;
          end;
    end;
end;
 
begin
  d:=false;
  clrscr;
  writeln ('Laskave mi zdej kolik bude neznamych jinak nepocitam ! ');
  write ('Tak kolik: ');
  readln(s);
  writeln;writeln;
  plneni(a);               {Naplni matici}
  for i:=1 to s-1 do
    begin
      writeln('Nuluji pod diagonalou');
      nula(i,a);           {Testuje jestli neni na diagonale 0}
      for e:=1 to s-i do
        begin
          if a[i+e,i]<>0 then
            begin
              y:=a[i+e,i]/a[i,i]*(-1);   {Nulovani nizsich radku v danem sloupci}
                for j:=1 to s+1 do
                  begin
                    a[i,j]:=a[i,j]*y;
                    a[i+e,j]:=a[i+e,j]+a[i,j];
                  end;
            end;
        end;
      vypis(a);
      delay(1000);      {urcite spomaleni aby bylo mozno sledovat nulovani}
      writeln;writeln;writeln;
      for f:=i to s do   {Kontrola na nekonecno nebo zadny vysledek}
        begin
          c:=false;
          for g:=1 to s do c:=(a[f,g]<>0) or c;
          if not(c) then d:=a[f,s+1]=0;
          if not(c) then f:=s;  {Ukonci cyklus}
        end;
      if not(c) then i:=s-1;    {Ukonci cyklus}
    end;
    if c then
    begin
      for j:=s downto 1 do
        begin
          for e:=j+1 to s do a[j,s+1]:=a[j,s+1]-a[j,e];  {Odecte od s+1 jiz spocitane prvky radku}
          a[s+1,j]:=a[j,s+1]/a[j,j];                     {Spocte vysledne x? }
          for i:=1 to j-1 do a[i,j]:=a[i,j]*a[s+1,j];    {Dosadi x? do vyssich radku}
        end;
      for j:=1 to s do
      writeln('x',j,'= ',a[s+1,j]:8);         {Vypis vysledku}
    end
       else if d then writeln('Tato rovnice ma nekonecno reseni!')
                 else writeln('Tato rovnice nema reseni!');
  writeln;writeln;
  writeln('Neco stiskni ((Pokud mozno na ty veci co lezi pred tebou)) !!!');
  repeat until keypressed;
end.