O programa abaixo foi desenvolvido no compilador Dev-Pascal, e utiliza a Eliminação de Gauss para o Escalonamento (Triangularização Superior da Matriz Ampliada) e Pivoteamento Total, para evitar pivôs nulos, resolvendo o sistema equivalente por retrossubstituição.
Download do Código em Pascal e Executável do Programa:
http://www.4shared.com/file/TuoeSXKr/Eliminacao_Gauss_Pivot_Total.html
Download do Compilador Dev-Pascal: http://www.bloodshed.net/devpascal.html
Código:
Program Gauss_pivoteamento_total;
Uses crt;
Var
a : Array[1..100,1..100] Of Real; //se desejar uma matriz maior, basta criar arrays maiores//
x, b : Array[1..100] Of Real;
o:array[1..100] of integer;
i, j, n, ji, k, h, posx, posl, posc : Integer;
m, soma, auxb, aux, p : Real;
resposta : char;
nome : String;
erro : Boolean;
resultado : Text;
Begin
Repeat
repeat
Clrscr;
Textcolor (White);
Writeln ('Resolucao de sistemas de equacoes lineares utilizando o metodo da eliminacao');
Writeln ('de Gauss (triangularizacao) com pivoteamento total.');
Writeln;
Write ('Digite a ordem do sistema (n), no maximo n=100: ');
Readln (n);
until n >= 2;
//le os coeficientes da matriz A//
for j:=1 to n do
begin
Repeat
clrscr;
Writeln ('AX = B');
Writeln;
Writeln ('Matriz ampliada do sistema');
Writeln;
Writeln ('Digite os elementos da coluna ',j,' da matriz A (coeficientes de x',j,'):');
Writeln;
for i:=1 to n do
begin
Write('a[',i,'x',j,']= ');
readln(a[i,j]);
end;
writeln;
writeln;
Textcolor (White);
Write ('Confira os valores digitados, estao corretos? (digite s=sim, n=nao): ');
Readln (resposta);
Until (resposta = 'S') Or (resposta = 's');
end;
//le os coeficientes da matriz B//
repeat
clrscr;
Writeln ('AX = B');
Writeln;
Writeln ('Matriz ampliada do sistema');
Writeln;
Writeln ('Digite os elementos da matriz B (termos independentes)');
Writeln;
for i:=1 to n do
begin
Write('b[',i,']= ');
readln(b[i]);
end;
writeln;
writeln;
Write ('Confira os valores digitados, estao corretos? (digite s=sim, n=nao): ');
Readln (resposta);
Until (resposta = 'S') Or (resposta = 's');
clrscr;
for k:=1 to n do //inicializa o vetor ordem das incognitas x//
o[k]:=k;
erro := False; //A variavel erro se tornara True caso haja erros de divisao por zero//
//pivoteamento total//
for h:=1 to n do
begin
p:=abs(a[h,h]);
posl:=h;
posc:=h;
for i:=h+1 to n do
begin
for j:=h+1 to n do
begin
if p<abs(a[i,j])
then begin
p:=abs(a[i,j]);
posl:=i; //guardam a posicao (linha e coluna) do maior pivo//
posc:=j;
end;
end;
end;
if (posl>h) then //troca linha h pela linha posl//
begin
for k:=1 to n do
begin
aux:=a[posl,k];
a[posl,k]:=a[h,k];
a[h,k]:=aux;
end;
auxb:=b[posl];
b[posl]:=b[h];
b[h]:=auxb;
end;
if (posc<>h) then //troca coluna h pela coluna posc//
begin
for k:=1 to n do
begin
aux:=a[k,posc];
a[k,posc]:=a[k,h];
a[k,h]:=aux;
end;
posx:=o[h];
o[h]:=o[posc];
o[posc]:=posx; //vetor que guarda a ordem das incognitas x//
end;
//Metodo da eliminacao de Gauss (Triangularizacao)//
If a[h,h] <> 0 Then //Evita erros de divisao por zero//
Begin
for i:=h+1 to n do
begin
m := -1*(a[i,h]/a[h,h]);
For ji:=1 To n Do
a[i,ji] := a[i,ji] + (m*(a[h,ji]));
b[i] := b[i] + m*b[h];
end;
End
Else
erro := True;
end;
If erro = True Then
Begin
Clrscr;
Writeln ('Erro! Talvez este sistema linear nao tenha solucao (sistema impossivel)');
End
Else
Begin
//Metodo de resolucao de sistemas triangulares (Retrossubstituicao)//
If a[n,n] <> 0 Then
x[n] := b[n] / a[n,n]
Else
x[n] := 0;
For i := n-1 Downto 1 Do
Begin
soma := 0;
For j := i+1 To n Do
soma := soma + a[i,j]*x[j];
If a[i,i] <> 0 Then
x[i] := (1/a[i,i]) * (b[i] - soma)
Else
x[i] := (b[i] - soma);
End;
//Imprime na tela o resultado//
clrscr;
Writeln ('AX = B');
Writeln;
Textcolor (Lightcyan);
For i := 1 To n Do
Writeln ('x', o[i], ' = ', x[i]);
writeln;
//Grava o resultado em um arquivo de texto .txt//
Writeln;
Textcolor (White);
Write ('Deseja salvar os resultados em um arquivo de texto? (digite s=sim, n=nao): ');
Readln (resposta);
If (resposta = 's') Or (resposta = 'S') Then
Begin
Writeln;
Write ('Digite o nome do arquivo a ser salvo: ');
Readln (nome);
nome := (nome + '.txt');
Assign(resultado, nome);
Rewrite (resultado);
Writeln (resultado, 'valores de x (incognitas):');
Writeln (resultado);
For i:=1 To n Do //Escreve X//
Writeln (resultado,'X',o[i], ' = ',x[i]);
Close (resultado);
Writeln;
Writeln ('O arquivo foi salvo no mesmo diretorio do arquivo executavel!');
End;
End;
Writeln;
Textcolor (White);
Write ('Deseja reiniciar o programa? (digite s=sim, n=nao): ');
Readln (resposta);
Until (resposta <> 'S') And (resposta <> 's');
End.
Se desejarem fazer qualquer melhoria, correção de algum eventual erro, fiquem a vontade! ; )
