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

Delphi & Pascal (česká wiki)
Přejít na: navigace, hledání
Category: KMP (Club of young programmers)

Author: Aleš Kucik
web: www.webpark.cz/prog-pascal

Program: Gauss.pas
File exe: Gauss.exe

Tento jednoduchý prográmek slouží k výpočtu neznámých soustav lineárních rovnic. Využívá Gaussovy eliminace, která lze snadno vyjádřit jako algoritmus. Dejme tomu že máme lin. rovnice

Račte si to vyzkoušet sami. Program je limitován konstantou MAX na 10 neznámích, ale klidně můžete tuto konstantu zvětšit.
{ 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.