program GAUSS;
{  GAUSS ELIMINATIONSVERFAHREN mit RÜCKWÄRTSSUBSTITUTION
   zur Lösung eines linearen Gleichungssystems mit n Unbekannten
Eingabe:   Anzahl der Unbekannten und Gleichungen n in einer Matrix
           A = (A(I,J)) wobei 1<=I<=n und 1<=J<=n+1.

     A[1,1] X[1] + A[1,2] X[2] +...+ A[1,n] X[n] = A[1,n+1]
     A[2,1] X[1] + A[2,2] X[2] +...+ A[2,n] X[n] = A[2,n+1]
      .
     A[n,1] X[1] + A[n,2] X[2] +...+ A[n,n] X[n] = A[n,n+1]

Ausgabe:  Lösungsvektor x(1), x(2),...,x(n) oder Fehlermeldung 
                                                                   }
const
   ZERO = 1.0E-15;
var
   A : array [ 1..12, 1..13 ] of real;
   X : array [ 1..12 ] of real;
   C,XM,SUM : real;
 
   FLAG,N,M,I,J,ICHG,NN,IP,JJ,K,L,KK : integer;
   OK : boolean;
   AA : char;
   NAME : string [ 14 ];
   INP,OUP : text;
procedure INPUT;
   begin
      writeln('Lösung eines linearen Gleichungssystems.');
      writeln ('Eingabe über Datenfile in der Form: ');
      writeln('A(1,1), A(1,2), ..., A(1,N+1), A(2,1), A(2,2), ..., A(2,N+1),');
      writeln ('..., A(N,1), A(N,2), ..., A(N,N+1) '); writeln;
      write ('Soviele Matrixelemente wie gewünscht in einer Zeile, ');
      writeln ('jedoch mit Leerzeichen getrennt ');
      writeln; writeln;
      OK := false;
        begin
            writeln ('Name des Datenfiles – z.B. C:\Daten.txt');
            readln ( NAME );
            assign ( INP, NAME );
            reset ( INP );
            OK := false;
            while ( not OK ) do
               begin
                  writeln ('Anzahl der Gleichungen als Integer. ');
                  readln ( N );
                     begin
                        for I := 1 to N do
                           for J := 1 to N + 1 do read ( INP, A[I,J] );
                        OK := true;
                        close ( INP )
                     end
               end
         end
   end;
procedure OUTPUT;
   begin
      writeln ('Ausgabe:');
      writeln ('1...Bildschirm ');
      writeln ('2...in Datenfile ');
      writeln ('Eingabe 1 oder 2 ');
      readln ( FLAG );
      if ( FLAG = 2 ) then
         begin
            writeln ('Name des Ausgabefiles – z.B. C:\output.txt');
            readln ( NAME );
            assign ( OUP, NAME )
         end
      else assign ( OUP, 'CON' );
      rewrite ( OUP );
      writeln(OUP,'GAUSS ELIMINATION');
      writeln(OUP);
      writeln ( OUP, ' Das Gleichungssystem ');
      for I := 1 to N do
         begin
            for J := 1 to M do write ( OUP, A[I,J]:12:8 );
            writeln ( OUP )
         end;
      writeln ( OUP ); writeln ( OUP );
      writeln ( OUP, 'hat den Lösungsvektor: ');
      for I := 1 to N do write ( OUP, '':2, X[I]:12:8 );
      writeln ( OUP ); writeln ( OUP );
      writeln ( OUP, 'Anzahl der Zeilenvertauschungen= ',ICHG);
      close ( OUP )
   end;
   begin
      INPUT;
      if ( OK ) then
         begin
{           STEP 1                                                     }
            NN := N - 1;
            M := N + 1;
            ICHG := 0;
            I := 1;
            while ( OK ) and ( I <= NN ) do
               begin
{                 STEP 2                                               }
{                 use IP instead of p                                  }
                  IP := I;
                  while ( abs( A[IP,I] ) <= ZERO ) and ( IP <= N ) do
                     IP := IP + 1;
                  if ( IP = M ) then OK := false
                  else
                     begin
{                       STEP 3                                         }
                        if ( IP <> I ) then
                           begin
                              for JJ := 1 to M do
                                 begin
                                    C := A[I,JJ];
                                    A[I,JJ] := A[IP,JJ];
                                    A[IP,JJ] := C
                                 end;
                              ICHG := ICHG + 1
                           end;
{                       STEP 4                                         }
                        JJ := I + 1;
                        for J := JJ to N do
                           begin
{                             STEP 5                                   }
                              XM := A[J,I] / A[I,I];
{                             STEP 6                                   }
                              for K := JJ to M do
                                 A[J,K] := A[J,K] - XM * A[I,K];
                              A[J,I] := 0.0
                           end
                     end;
                  I := I + 1
               end;
            if ( OK ) then
               begin
{                 STEP 7                                               }
                  if ( abs( A[N,N] ) <= ZERO ) then OK := false
                  else
                     begin
{                       STEP 8                                         }
{                       Rückwärtssubstitution                          }
                        X[N] := A[N,M] / A[N,N];
{                       STEP 9                                         }
                        for K := 1 to NN do
                           begin
                              I := NN - K + 1;
                              JJ := I + 1;
                              SUM := A[I,M];
                              for KK := JJ to N do
                                 SUM := SUM - A[I,KK] * X[KK];
                              X[I] := SUM / A[I,I]
                           end;
{                       STEP 10                                        }
{                       Ende der Prozedur                              }
                        OUTPUT
                     end
               end;
            if ( not OK ) then writeln ('Gleichungssystem ist singulär')
         end
   end.

