Eliminação de Gauss com Pivoteamento Total - Resolução de Sistemas Lineares

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