unit pivotgauss;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,math;
CONST
   np=101;
TYPE
   matricereelle=ARRAY OF ARRAY OF float;
   matriceentiere=ARRAY OF ARRAY OF integer;
   tableaureel=ARRAY OF float;
   tableauentier=ARRAY  OF integer;
   tableaustring=array of string;
   tableaubooleen=array of boolean;
   function ResoudLineaire(var a:matricereelle; n:integer; var x:tableaureel):boolean;


 implementation


     function ResoudLineaire(var a:matricereelle; n:integer; var x:tableaureel):boolean;
   const
   ZERO = 1.0E-20;
var

   S : tableaureel;
   NROW : tableauentier;
   TEMP,AMAX,XM,SUM : float;
   FLAG,M,ICHG,I,NN,IMAX,J,JJ,IP,JP,NCOPY,I1,J1,N1,K,N2,LL,KK : integer;
    ok:boolean;
   begin
   setlength(s,n);  setlength(nrow,n);
       ok:=true;
      if ( OK ) then
         begin
            M := N + 1;
{           STEP 1                                                     }
            for I := 1 to N do
               begin
                  S[I-1] := abs( A[I-1,0] );
{                 initialize row pointer                               }
                  NROW[I-1] := I;
                  for J := 1 to N do
                     if ( abs( A[I-1,J-1] ) > S[I-1] ) then
                        S[I-1] := abs( A[I-1,J-1] );
                  if ( S[I-1] <= ZERO ) then OK := false
               end;
            NN := N - 1;
            ICHG := 0;
            I := 1;
{           STEP 2                                                     }
{           elimination process                                        }
            while ( OK ) and ( I <= NN ) do
               begin
{                 STEP 3                                               }
                  IMAX := NROW[I-1];
                  AMAX := abs( A[IMAX-1,I-1] ) / S[IMAX-1];
                  IMAX := I;
                  JJ := I + 1;
                  for IP := JJ to N do
                     begin
                        JP := NROW[IP-1];
                        TEMP := abs(A[JP-1,I-1]/S[JP-1]);
                        if ( TEMP > AMAX ) then
                           begin
                              AMAX := TEMP;
                              IMAX := IP
                           end
                     end;
{                    STEP 4                                            }
{                    system has no unique solution                     }
                     if ( AMAX <= ZERO ) then OK := false
                     else
                        begin
{                          STEP 5                                      }
{                          simulate row interchange                    }
                           if ( NROW[I-1] <> NROW[IMAX-1] ) then
                              begin
                                 ICHG := ICHG + 1;
                                 NCOPY := NROW[I-1];
                                 NROW[I-1] := NROW[IMAX-1];
                                 NROW[IMAX-1] := NCOPY
                              end;
{                          STEP 6                                      }
                           I1 := NROW[I-1];
                           for J := JJ to N do
                              begin
                                 J1 := NROW[J-1];
{                                STEP 7                                }
                                 XM := A[J1-1,I-1] / A[I1-1,I-1];
{                                STEP 8                                }
                                 for K := JJ to M do
                                    A[J1-1,K-1] := A[J1-1,K-1] - XM * A[I1-1,K-1];
{                                multiplier XM could be saved in A[J1,I]  }
                                 A[J1-1,I-1] := 0.0
                              end
                        end;
                     I := I + 1
                  end;
               if ( OK ) then
                  begin
{                    STEP 9                                            }
                     N1 := NROW[N-1];
                     if ( abs( A[N1-1,N-1] ) <= ZERO ) then OK := false
{                    system has no unique solution                     }
                     else
                        begin
{                          STEP 10                                     }
{                          start backward substitution                 }
                           X[N-1] := A[N1-1,M-1] / A[N1-1,N-1];
{                          STEP 11                                     }
                           for K := 1 to NN do
                              begin
                                 I := NN - K + 1;
                                 JJ := I + 1;
                                 N2 := NROW[I-1];
                                 SUM := 0.0;
                                 for KK := JJ to N do
                                    begin
                                       SUM := SUM - A[N2-1,KK-1]*X[KK-1]
                                    end;
                                 X[I-1] := (A[N2-1,M-1] + SUM) / A[N2-1,I-1]
                              end;
{                          STEP 12                                     }
{                          procedure completed successfully            }

                        end
                  end;
              { if ( not OK ) then writeln ('System has no unique solution ') }
             ResoudLineaire:=OK;
         end;
         finalize(nrow); finalize(s);
       end;


   begin
   end.
