Вот код.
- Код: Выделить всё
Program Vot_eto_pravilno;
uses crt;
Const
MaxN = 10;
MaxK = 10;
T=0.00001; {Ограничиваем числа бликие к нулю}
Type
TVector = array[1..MaxN] of Real;
TMatrix = array[1..MaxN, 1..MaxN] of Real;
Procedure ReadSystem(N: Integer; var A: TMatrix; var U: TVector);
{Процедура ввода расширенной матрицы}
Var
r, i, j: Integer;
Begin
r := WhereY;
GotoXY(2, r);
TextColor(12);
Write('A');
for i := 1 to n do
Begin
GotoXY(i*6+2, r);
TextColor(11);
Write(i);
GotoXY(1, r+i+1);
TextColor(11);
Write(i:2);
End;
GotoXY((n+1)*6+2, r);
TextColor(12);
Write('U');
TextColor(7);
for i := 1 to n do
Begin
For j := 1 to n do
Begin
GotoXY(j*6+2, r+i+1);
Readln(A[i,j]);
End;
GotoXY((n+1)*6+2, r+i+1);
Readln(U[i]);
End;
End;
procedure Per(n,k:integer;a:TMatrix;var p:integer);{перестановка строк с макс. главным элементом}
var z:real;
j,i:integer;
begin
z:=abs(a[k,k]);
i:=k;
p:=0;
for j:=k+1 to n do
begin
if abs(a[j,k])>z then
begin
z:=abs(a[j,k]);
i:=j;
p:=p+1;
end;
end;
if i>k then
for j:=k to n do
begin
z:=a[i,j];
a[i,j]:=a[k,j];
a[k,j]:=z;
end;
end;
function znak(p:integer):integer;{изменение знака при перестановке строк матрицы}
begin
if p mod 2=0 then
znak:=1 else znak:=-1;
end;
function znak1(i,m:integer):integer;{изменение знака при перестановке строк при нахождении дополнений}
begin
if (i+m) mod 2=0 then
znak1:=1 else znak1:=-1;
end;
procedure opr(n,p:integer;a:TMatrix;var det:real;var f:byte);{нахождение определителя матрицы}
var k,i,j:integer;
r:real;
begin
det:=1.0;f:=0;
for k:=1 to n do
begin
if a[k,k]=0 then per(k,n,a,p);
det:=znak(p)*det*a[k,k];
if abs(det)<t then
begin
f:=1;
writeln('Обратной матрицы нет!');
readln;
exit;
end;
for j:=k+1 to n do
begin
r:=a[j,k]/a[k,k];
for i:=k to n do
a[j,i]:=a[j,i]-r*a[k,i];
end;
end;
end;
procedure opr1(n,p:integer;d:Tmatrix;var det1:real);{нахождение определений для дополнений}
var k,i,j:integer;
r:real;
begin
det1:=1.0;
for k:=2 to n do
begin
if d[k,k]=0 then per(n,k,d,p);
det1:=znak(p)*det1*d[k,k];
for j:=k+1 to n do
begin
r:=d[j,k]/d[k,k];
for i:=k to n do
d[j,i]:=d[j,i]-r*d[k,i];
end;
end;
end;
Procedure Peresch(n,p:integer;var b:Tmatrix;det1:real;var e:Tmatrix);{вычисление дополнений}
var i,m,k,j:integer;
z:real;
d,c:Tmatrix;
begin
for i:=1 to n do
for m:=1 to n do
begin
for j:= 1 to n do {перестановка строк}
begin
z:=b[i,j];
for k:=i downto 2 do
d[k,j]:=b[k-1,j];
for k:=i+1 to n do
d[k,j]:=b[k,j];
d[1,j]:=z;
end;
for k:=1 to n do {перестановка столбцов}
begin
z:=d[k,m];
for j:=m downto 2 do
c[k,j]:=d[k,j-1];
for j:=m+1 to n do
c[k,j]:=d[k,j];
c[k,1]:=z;
end;
Opr1(n,p,c,det1);{вычисление определителей}
e[i,m]:=det1*znak1(i,m);{вычисление дополнений}
end;
end;
Procedure Proverka(a,b:Tmatrix; n:integer;var c:Tmatrix);{проверка - умножение прямой матрицы на обратную}
var k,j,i:integer;
z:double;
begin
for k:=1 to n do
for j:=1 to n do
begin
c[k,j]:=0;
for i:=1 to n do
begin
z:=a[i,j]*b[k,i];
c[k,j]:=c[k,j]+z;
end;
end;
end;
procedure Vyvod(var a:Tmatrix; n:integer);{вывод матриц на экран}
var k,j:integer;
begin
for k:=1 to n do
begin
for j:=1 to n do
write(a[k,j]:7:2);
writeln;
end;
end;
Procedure Transp(a:Tmatrix; n:integer;var at:Tmatrix);{транспонирование матрицы}
var k,j:integer;
begin
for k:= 1 to n do
for j:=1 to n do
at[k,j]:=a[j,k];
end;
Procedure Transp1(var a: TMatrix; n:integer);
{Процедура вывода транспонированной матрицы на экран}
Var
k,j: integer;
Begin
for k:= 1 to n do
Begin
for j:= 1 to n do
Write ('|',A[j,k]:8:2,'|'); {Вывод транспонированной матрицы}
Writeln;
End;
End;
Procedure Dop(var e: TMatrix; n:integer);
{Процедура вывода дополнений на экран}
Var
i,m: integer;
Begin
for i:= 1 to n do
Begin
for m:= 1 to n do
Write ('|',e[i,m]:8:2,'|'); {Вывод дополнений матрицы}
Writeln;
End;
End;
Procedure Reshenie_lin_Yravneni(n: Integer; a: TMatrix; U: TVector; var x:TVector);
Var
k, l, i, j: Integer;
p:Real;
Begin
Writeln('Вычисление решения линейных уравнений');
For i := n - 1 downto 1 do begin
p:=0;
For j := 1 to n-i do
p := p + a[i, i + j] * x[i + j];
x[i] := (1 / a[i, i]) * (U[i] - p);
end;
End;
{ Процедура вывода результатов }
Procedure WriteX(n :Integer; x: TVector);
Var
i: Integer;
Begin
For i := 1 to n do
Writeln('x', i, ' = ', x[i]);
End;
var
n,k,j,i,p: Integer;{n-размер матрицы,k-счетчик по строкам,j-счетчик по столбцам,p-счетчик перестановок}
a,at,b,c,e:Tmatrix;{a-исходная, at-транспонированная, b-матрица дополнений, e-обратная, с-проверка}
det,det1:real;{det-определитель исходной матрицы,det1-определители-дополнения}
f:byte;{признак несуществования обратной матрицы}
U,x: TVector;
Begin
ClrScr;
Write('Введите порядок матрицы системы (макс. 10): ');
repeat
Readln(n);
until (n > 0) and (n <= maxn);
Writeln;
Writeln('Введите расширенную матрицу системы');
ReadSystem(n, a, u);
Writeln;
Writeln('Исходная матрица, без коэффициентов:');
Vyvod(a,n);
Writeln;
Readln;
Opr(n,p,a,det,f); {Вычисление определителя}
write('Определитель = ',det:2:0, '.');
Writeln;
Writeln('Транспонированная матрица');
Transp1(a,n);
Writeln;
if f=1 then exit;
Transp(a,n,b); {транспонируем матрицу}
Peresch(n,p,b,det1,e); {считаем дополнения}
Writeln('Матрица дополнений');
Dop(e,n);
Writeln;
writeln('Обратная матрица:');
for k:=1 to n do
for j:=1 to n do
e[k,j]:=e[k,j]/det; {создаем обратную матрицу}
Vyvod(e,n);
writeln('Проверка:');
Proverka(a,e,n,c); {делаем проверку}
Vyvod(c,n);
readln;
Writeln('Результаты вычисления');
WriteX(n, x);
Writeln;
end.
Процедура решения системы называется Reshenie_Lin_Yravnen;
Вывод осуществляется в самом низу программы.
Можете подсказать, где ошибка в процедуре, вроде переменные все стоят правильно, убрать даже если P;=0 в цикле всё равно ставит нули.
Заранее спасибо.
