Dze je subor www.TrSek.com/cover/ales/gauss.pas{ 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.