Alguém tem algum código de Eliminação de Gauss com Pivoteamento Parcial?

http://pascalmath.blogspot.com.br/2011/04/algoritmo-pascal-calculo-do.html tenta fazer o download do Código em Pascal e Executável do Programa.
nesse link segue um PDF:
http://wwwp.fc.unesp.br/~arbalbo/Iniciacao_Cientifica/sistemaslineares/teoria/1_Gauss_com_Pivoteamento_Parcial.pdf

Voce conseguiu o codigo? pode me passar? amandasantoro@poli.ufrj.br

Para responder essa pergunta devemos colocar em prática nosso conhecimento sobre Cálculo Numérico

Abaixo está programa desenvolvido no compilador Dev-Pascal.

Código:

Program Gauss_pivoteamento_parcial; 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;

i, j, n, ji, ii, ipivo, k : Integer; // i's sao variaveis auxiliares//

m, soma, pivo, baux, aux : 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 parcial.');

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');

//Metodo da eliminacao de Gauss (Triangularizacao)//

k := 1; //Passo//

erro := False; //A variavel erro se tornara True caso haja erros de divisao por zero//

For j:=1 To n Do

Begin

For i:=k+1 To n Do

Begin

pivo := Abs(a[j,k]); //Pivoteamento Parcial//

ipivo := j; //Encontra em qual linha da coluna k esta o maior elemento//

For ii:=j to n Do

Begin

If Abs(a[ii,k]) > pivo Then

Begin

pivo := a[ii,k];

ipivo := ii;

End;

End;

If ipivo <> j Then //Se ipivo = j e porque o maior elemento ja esta na linha do pivo, e a permutacao nao e necessaria//

Begin

For ji:=1 to n Do //Permuta as linhas necessarias para o pivoteamento parcial//

Begin

aux := a[j,ji];

a[j,ji] := a[ipivo,ji];

a[ipivo,ji] := aux;

End;

baux := b[j];

b[j] := b[ipivo];

b[ipivo] := baux;

End;

If a[j,j] <> 0 Then //Evita erros de divisao por zero//

Begin

m := -1*(a[i,j]/a[j,j]);

For ji:=1 To n Do

a[i,ji] := a[i,ji] + (m*(a[j,ji]));

b[i] := b[i] + m*b[j];

End

Else

erro := True;

End;

k := k + 1;

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', 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',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

Portanto, a baixo está o código em Pascal.

Código:

Program Gauss_pivoteamento_parcial; 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;

i, j, n, ji, ii, ipivo, k : Integer; // i's sao variaveis auxiliares//

m, soma, pivo, baux, aux : 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 parcial.');

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');

//Metodo da eliminacao de Gauss (Triangularizacao)//

k := 1; //Passo//

erro := False; //A variavel erro se tornara True caso haja erros de divisao por zero//

For j:=1 To n Do

Begin

For i:=k+1 To n Do

Begin

pivo := Abs(a[j,k]); //Pivoteamento Parcial//

ipivo := j; //Encontra em qual linha da coluna k esta o maior elemento//

For ii:=j to n Do

Begin

If Abs(a[ii,k]) > pivo Then

Begin

pivo := a[ii,k];

ipivo := ii;

End;

End;

If ipivo <> j Then //Se ipivo = j e porque o maior elemento ja esta na linha do pivo, e a permutacao nao e necessaria//

Begin

For ji:=1 to n Do //Permuta as linhas necessarias para o pivoteamento parcial//

Begin

aux := a[j,ji];

a[j,ji] := a[ipivo,ji];

a[ipivo,ji] := aux;

End;

baux := b[j];

b[j] := b[ipivo];

b[ipivo] := baux;

End;

If a[j,j] <> 0 Then //Evita erros de divisao por zero//

Begin

m := -1*(a[i,j]/a[j,j]);

For ji:=1 To n Do

a[i,ji] := a[i,ji] + (m*(a[j,ji]));

b[i] := b[i] + m*b[j];

End

Else

erro := True;

End;

k := k + 1;

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', 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',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