Не пойму, почему не правильно выводит решение.
Добавлено: 13.04.2020 13:43:07Процедура не правильно выводит решение системы уравнений, если задать.
Процедура расчёта решения перед основной частью:
Процедура вывода результата пред основной частью:
Вызов в самом низу в основной части:
Ставил в процедуру обратную матрицу, то есть переменную e но это не помогло.
Заранее спасибо.
- Код: Выделить всё
Program Resh;
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 Dop(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 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('----------------------');
If f=1 Then Exit;
Transp(a,n,b); {Транспонируем матрицу}
Dop(n,p,b,det1,e); {Считаем дополнения}
Writeln('Матрица дополнений'); {Выводим дополнения для проверки правильности вычисления}
Dop(e,n);
Writeln;
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('----------------------');
Writeln('Проверка:');
Proverka(a,e,n,c); {Делаем проверку}
Vyvod(c,n);
Readln;
Reshenie_lin_Yravneni(n,a,u,x); {Вычисляем решение системы уравнений}
Writeln('Результаты вычисления'); {Выводим результаты}
WriteX(n, x);
Writeln;
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;
Вызов в самом низу в основной части:
- Код: Выделить всё
Reshenie_lin_Yravneni(n,a,u,x); {Вычисляем решение системы уравнений}
Writeln('Результаты вычисления'); {Выводим результаты}
WriteX(n, x);
Writeln;
End.
Ставил в процедуру обратную матрицу, то есть переменную e но это не помогло.
Заранее спасибо.
