Program Gaussverfahren;

Type Feld = array[1..100,1..101] of real;

Var a:Feld;
    b:array[1..100,1..101] of int32;
    l,l1,d,z:integer;
    x,y,r:int32;
    v:real;
    c:char;


Procedure Eingabe;

  Begin
    writeln;

    repeat

      write('Wie viele Variablen (2 bis 100)? ');
      readln(d)

    until (d>1) and (d<101);

    writeln;
    writeln('Eingabe des Gleichungssystems, bitte nur Dezimalzahlen eingeben!');
    writeln;

    for l:=1 to d do

      Begin

        write(l);
        write('. Gleichung: Gib nacheinander die Vorfaktoren an, nach jedem');
        writeln(' Vorfaktor <Enter> dr�cken!');writeln;

        for l1:=1 to d do

          Begin

            write(' X');write(l1);write('* ');
            read(a[l,l1]);
            if l1<d then write(' + ')
                    else write(' = ')

          End;

          readln(a[l,l1+1])

      End

  End;

Procedure Umwandlung(u:Feld);

  Begin

    for l:=1 to d do

        for l1:=1 to d+1 do
                                    (* Die reelle Matrix wird in eine  *)
          Begin                     (* ganzzahlige Matrix umgewandelt. *)
                                    (* Dabei wird jede Zahl um den Faktor *)
            v:=u[l,l1]*1000;        (* 1000 vergr”áert, um sp„ter auf die *)
            b[l,l1]:=trunc(v)       (* 2. Nachkommastelle runden zu k”nnen. *)
                                    (* Mit trunc werden die Nachkommastellen *)
          End                       (* abgeschnitten! *)

  End;

Procedure Ausgabe;

  Begin

    if d>5 then Begin
                  writeln('Durch die hohe Variablenzahl wird die Darstellung');
                  writeln('des Gleichungssystems fehlerhaft/verschoben!');
                  writeln;
                  writeln('Weiter: <ENTER>');
                  writeln;
                  readln
                End;

    for l:=1 to d do

      Begin

        write('# ');
        for l1:=1 to d+1 do

          Begin                        (* Vorher wurde mit 1000 multipliziert *)
                                       (* und die restlichen Nachkommastellen *)
            z:=0; (*Z„hler*)           (* abgeschnitten. Hier wird wieder durch *)
                                       (* 1000 geteilt und in Vor- (div) und *)
            y:=b[l,l1] div 1000;       (* Nachkommastellen (mod) getrennt *)
            x:=abs(b[l,l1]) mod 1000;
            write(' ');
            if (b[l,l1]/1000>y) and (b[l,l1]/1000<y+0.1) then z:=1;

            r:=x mod 10;
            if r > 4 then x := (x div 10)+1 (* Hier wird abh„ngig von der 3. *)
                     else x := x div 10;    (* Nachkommastelle auf die 2. NK- *)
                                            (* stelle gerundet *)
            if (x=100) and (z=0) then
                          Begin
                                         (* Wenn die ersten beiden Nachkommastellen *)
                            x:=0;        (* 99 lauten und aufgerundet wird, wird die *)
                            y:=abs(y)+1  (* erste Vorkommastelle um 1 erh”ht und die *)
                                         (* Nachkommastellen auf 0 gesetzt *)
                          End;

            if (x=100) and (z=1) then Begin

                                        z:=0;
                                        x:=1

                                      End;

            r:=abs(y);                   (* Im Folgenden wird f�r bis zu 3-stellige *)
            if r=0 then write('  ');     (* Zahlen vor dem Komma geregelt, dass alle *)
                                         (* Zahlen sauber untereinander ausgegeben *)
            while (r<100) and (r<>0) do  (* werden. Ist die Vorkommastelle 0, funktioniert *)
                                         (* das nicht; dieser Fall muss daher extra behandelt *)
              Begin                      (* werden. *)

                write(' ');
                r:=r*10

              End;

              if b[l,l1]<0 then write('-')               (* negative Zahl erkannt *)
                           else if l1=1 then write(' '); (* erste Zahl der Gleichung *)

              write(abs(y));           (* Ausgabe der Vorkommazahl *)
              write(',');
              if z=1 then write('0');
              write(x);                (* Ausgabe der Nachkommazahl *)
              if (x<10) and (z=0) then write('0'); (* Gibt es nur eine Nachkommastelle, wird 0 angeh„ngt. *)
              if l1<d+1 then Begin
                                             (* Hier werden die Variablen ausgegeben, *)
                               write(' X');  (* durchnumeriert X1 bis Xd *)
                               write(l1)

                             End;

            write(' ');
            if (((b[l,l1+1]>0) or (b[l,l1+1]=0)) and (l1<d)) then write(' +') (* Sofern die folgende Zahl nicht *)
                                                             else             (* negativ ist und die aktuelle Variable *)
                if l1=d then if b[l,l1+1]<0 then write('=')                   (* nicht die letzte der Gleichung ist, *)
                                            else write('= ')                  (* wird + gesetzt. Nach der letzten Variable *)
                                                                     (* wird = gesetzt, ist das Ergebnis positiv, folgt eine *)
                        else write(' ')                              (* Leerstelle *)

          End;

        writeln('#')

      End

  End;



Procedure Berechnung;

  Var w:array[1..101] of real;
      i,l2:integer;

  Begin

    l:=1;

    Repeat

      l2:=l-1;
      v:=0;                    (* Hier wird so lange der Vorfaktor *)
                               (* �berpr�ft, bis ein von 0 verschiedener *)
      Repeat                   (* Vorfaktor gefunden ist *)

        l2:=l2+1;
        v:=a[l2,l]

      Until (v<>0) or (l2=d);

      if v<>0 then              (* Wurde ein von 0 verschiedener Vorfaktor *)
                                (* gefunden, beginnt die Pivotsuche: *)
        Begin                   (* es wird der betragsm„áig kleinste Vorfaktor *)
                                (* der betreffenden Variable gesucht und die *)
          i:=l2;                (* zugeh”rige Gleichung gemerkt *)
          for l1:=l to d do

            Begin

              if (abs(a[l1,l])<abs(v)) and (a[l1,l]<>0) then Begin

                                                               v:=a[l1,l];
                                                               i:=l1

                                                             End

            End;

          if i>l then for l1:=1 to d+1 do Begin                 (* Steht die Pivotgleichung *)
                                                                (* nicht oben, wird die obere *)
                                            w[l1]:=a[l,l1];     (* Gleichung mit ihr getauscht *)
                                            a[l,l1]:=a[i,l1]/v;
                                            a[i,l1]:=w[l1]

                                          End
                                                              (* Steht die Pivotgleichung oben *)
                 else for l1:=1 to d+1 do a[l,l1]:=a[l,l1]/v; (* werden alle Vorfaktoren und das *)
                                                              (* Ergebnis durch den Pivot geteilt *)
          for l1:=l+1 to d do

            Begin                                              (* Elimination der betreffenden *)
                                                               (* Variable aus allen Gleichungen *)
              v:=a[l1,l];                                      (* mit Hilfe der Pivotgleichung *)
              for l2:=l to d+1 do a[l1,l2]:=a[l1,l2]-v*a[l,l2]

            End;

          l:=l+1

        End

    Until (l=d) or (v=0);   (* Die Eliminationsschritte erfolgen so lange, bis *)
                            (* die letzte Variable der Gleichung erreicht wurde *)
    if a[d,d]<>0 then Begin (* oder kein von 0 verschiedener Vorfaktor gefunden wurde. *)

                        a[d,d+1]:=a[d,d+1]/a[d,d]; (* Hier wird die letzte Gleichung, *)
                        a[d,d]:=1                  (* die nur noch eine Variable enth„lt,*)
                                                   (* gel”st.*)
                      End;

    Umwandlung(a);
    writeln;
    if v=0 then Begin (* Wurde kein von 0 verschiedener Vorfaktor entdeckt, ist das *)
                      (* Gleichungssystem nicht oder nicht eindeutig l”sbar.*)
                  writeln('Das Gleichungssystem ist nicht oder nicht eindeutig');
                  writeln('l”sbar. Ergebnis zu diesem Zeitpunkt der Umwandlung:');
                  writeln
                End;
    writeln('Zeilenstufenform:');    (* Ausgabe der Zeilenstufenform als obere *)
    writeln;                         (* Dreiecksform des Gleichungssystems *)
    Ausgabe;

    if (a[d,d] <>0) and (v<>0) then  (* Wenn das Gleichungssystem eindeutig *)
                                     (* l”sbar ist, wird es diagonalisiert und *)
      Begin                          (* dadurch berechnet. *)

        for l:= d-1 downto 1 do

          for l1:= 1 to l do

            for l2:= d+1 downto l+1 do

              a[l1,l2]:=a[l1,l2]-a[l1,l+1]*a[l+1,l2];

        Umwandlung(a);
        writeln;
        writeln('L”sung in der Diagonalform:');
        writeln;
        Ausgabe;
        writeln;
        writeln('L”sungsmenge:');
        write('L={ ( ');
        for l:=1 to d do
                                              (* Ausgabe der L”sungsmenge mit *)
          Begin                               (* Rundung der Ergebnisse auf 2 *)
                                              (* Nachkommastellen, vgl. oben *)
            z:=0;
            y:=b[l,d+1] div 1000;
            x:=abs(b[l,d+1]) mod 1000;
            if (b[l,l1]/1000>y) and (b[l,l1]/1000<y+0.1) then z:=1;
            r:=x mod 10;
            if r > 4 then x := (x div 10)+1
                     else x := x div 10;

            if (x=100) and (z=0) then Begin

                                        y:=abs(y)+1;
                                        x:=0

                                      End;

            if (x=100) and (z=1) then Begin

                                        z:=0;
                                        x:=1

                                      End;

            if b[l,d+1]<0 then write('-');
            write(abs(y));
            if x>0 then write(',');
            if (z=1) and (x>0) then write('0');
            if x>0 then write(x);
            if l<d then write(' / ')

          End;

          writeln(' ) }')

      End


  End;



Begin

  Repeat

    writeln;
    writeln('Programm Gaussverfahren, <C> Dieter Eiermann 2015');
    Eingabe;
    writeln;
    Umwandlung(a);
    writeln('Zu l”sendes Gleichungssystem:');
    writeln;
    Ausgabe;
    writeln;
    Berechnung;
    readln;
    write('Neues Gleichungssystem (j/n)?');
    readln(c)

  Until c='n'

End.