{Решение систем линейных уравнений методом Гаусса Автор: Алексей Безродный }

Uses CRT;
Const maxn = 10; 
Type Data = Real;
     Matrix = Array[1..maxn,
	  1..maxn] of Data;
     Vector = Array[1..maxn]
	  of Data;
{ Процедура ввода расширенной
 матрицы системы }
Procedure ReadSystem(n: 
Integer; var a: Matrix; var b: Vector);
Var i,j,r: Integer;
Begin
  r:= WhereY;
  GotoXY(2, r);
  Write('A');
  For i := 1 to n do begin
    GotoXY(i*6+2, r);Write(i);
    GotoXY(1, r+i+1);Write(i:2);
                     end;
    GotoXY((n+1)*6+2, r);
    Write('b');
  For i := 1 to n do begin
   For j := 1 to n do begin
   GotoXY(j * 6 + 2, r + i + 1);
    Read(a[i, j]);
                end;
GotoXY((n + 1) * 6 + 2, 
r + i + 1);
       Read(b[i]);
  end;
End;

{ Процедура вывода результатов }
Procedure WriteX(n :Integer;
 x: Vector);
Var
   i: Integer;
Begin
     For i := 1 to n do
         Writeln('x', i,
		  ' = ', x[i]);
End;


{ Функция, реализующая метод Гаусса }
Function Gauss(n: Integer;
 a: Matrix; b: Vector; 
 var x:Vector): Boolean;
Var
   i, j, k, l: Integer;
   q, m, t: Data;
Begin

     For k := 1 to n - 1 do begin

{ Ищем строку l 
с максимальным элементом в k-ом столбце}
         l := 0;
         m := 0;
         For i := k to n do
    If Abs(a[i, k]) > m then begin
                m := Abs(a[i, k]);
                l := i;
             end;

{ Если у всех строк от
k до n элемент в k-м столбце нулевой,
                то система 
	не имеет однозначного решения }
         If l = 0 then begin
            Gauss := false;
            Exit;
         end;

{ Меняем местом l-ую строку с k-ой }
If l <> k then begin
For j := 1 to n do begin
    t := a[k, j];
    a[k, j] := a[l, j];
    a[l, j] := t;
        end;
            t := b[k];
            b[k] := b[l];
            b[l] := t;
         end;

{ Преобразуем матрицу }
For i := k + 1 to n do begin
    q := a[i, k] / a[k, k];
    For j := 1 to n do
    If j = k then
    a[i, j] := 0
                else
a[i, j] := a[i, j] - q * a[k, j];
b[i] := b[i] - q * b[k];
             end;

     end;

     { Вычисляем решение }
     x[n] := b[n] / a[n, n];
For i := n - 1 downto 1 do begin
t := 0;
For j := 1 to n-i do
t := t + a[i, i + j] * x[i + j];
x[i] := (1 / a[i, i]) * (b[i] - t);
     end;

     Gauss := true;
End;

Var
    n, i: Integer;
    a: Matrix ;
    b, x: Vector;
Begin
      ClrScr;
      Writeln('Программа решения
	   систем линейных уравнений
	    по методу Гаусса');
      Writeln;

      Writeln('Введите порядок 
	  матрицы системы (макс. 10)');
      Repeat
             Write('>');
             Read(n);
      Until (n > 0) and (n <= maxn);
      Writeln;

      Writeln('Введите
	   расширенную матрицу системы');
      ReadSystem(n, a, b);
      Writeln;

      If Gauss(n, a, b, x)
	   then begin
         Writeln('Результат 
		 вычислений по методу Гаусса');
         WriteX(n, x);
      end
      else
          Writeln('Данную 
		  систему невозможно 
		  решить по методу Гаусса');
      Writeln;
End.