fork download 
  1. const nmax=10;
  2. var n:integer;
  3. type
  4.  Tmass=array[1..nmax] of real;
  5.  Tmatrix=array[1..nmax,1..nmax] of real;
  6. {перестановка строк при главном элементе=0}
  7. procedure Per(k:integer;var a:Tmatrix;var p:integer);
  8. var z:Real;
  9.     j,i:integer;
  10. begin
  11.  z:=abs(a[k,k]);{модуль главного элемента}
  12.  i:=k;{номер строки}
  13.  p:=0;{количество перестановок}
  14.  for j:=k+1 to n do {ищем в столбце ниже}
  15.   begin
  16.    if abs(a[j,k])>z then {элемент по модулю больше}
  17.     begin
  18.      z:=abs(a[j,k]);
  19.      i:=j;
  20.      p:=p+1;//счетчик перестановок
  21.     end;
  22.   end;
  23. if i>k then{если нашли}
  24. for j:=k to n do
  25.  begin
  26.   z:=a[i,j];
  27.   a[i,j]:=a[k,j];{обмениваем строки}
  28.   a[k,j]:=z;
  29.  end;
  30. end;
  31. {определение знака определителя}
  32. function Znak(p:integer):integer;
  33. begin
  34. if p mod 2=0 then
  35. Znak:=1 else Znak:=-1;
  36. end;
  37. {вычисление определителя матрицы коэффициентов по Гауссу}
  38. procedure Opr(var det:real;var a:tmatrix);
  39. var k,i,j,p:integer;r:real;
  40. begin
  41. det:=1.0;
  42. for k:=1 to n do
  43.  begin
  44.   if a[k,k]=0 then Per(k,a,p);//перестановка строк
  45.   det:=znak(p)*det*a[k,k];//вычисление определителя
  46.   for j:=k+1 to n do //пересчет коэффициентов
  47.    begin
  48.     r:=a[j,k]/a[k,k];
  49.     for i:=k to n do
  50.     a[j,i]:=a[j,i]-r*a[k,i];
  51.    end;
  52.  end;
  53. end;
  54. {вычисление алгебраических дополнений}
  55. procedure Dop(d:tmatrix;var det1:real);
  56. var k,i,j,p:integer;r:real;
  57. begin
  58. det1:=1.0;
  59. for k:=2 to n do
  60.  begin
  61.   Per(k,d,p);
  62.   det1:=znak(p)*det1*d[k,k];
  63.   for j:=k+1 to n do
  64.    begin
  65.     r:=d[j,k]/d[k,k];
  66.     for i:=k to n do
  67.     d[j,i]:=(d[j,i]-r*d[k,i]);
  68.    end;
  69.  end;
  70. end;
  71. {установление знака алгебраических дополнений}
  72. function Znak1(i,m:integer):integer;
  73. begin
  74. if (i+m) mod 2=0 then
  75. Znak1:=1 else Znak1:=-1;
  76. end;
  77. {формирование присоединенной матрицы}
  78. Procedure Peresch(b:Tmatrix;var e:Tmatrix );
  79. var i,m,k,j:integer;z,det1:real;d,c:Tmatrix;
  80. begin
  81. for i:=1 to n do
  82.  begin
  83.   for m:=1 to n do
  84.    begin
  85.     for j:=1 to n do  {перестановка строки}
  86.      begin
  87.       z:=b[i,j];
  88.       for k:=i downto 2 do
  89.       d[k,j]:=b[k-1,j];
  90.       for k:=i+1 to n do
  91.       d[k,j]:=b[k,j];
  92.       d[1,j]:=z;
  93.      end;
  94.     for k:=1 to n do  {перестановка столбца}
  95.      begin
  96.       z:=d[k,m];
  97.       for j:=m downto 2 do
  98.       c[k,j]:=d[k,j-1];
  99.       for j:=m+1 to n do
  100.       c[k,j]:=d[k,j];
  101.       c[k,1]:=z;
  102.      end;
  103.     Dop(c,det1); {вычисление дополнений}
  104.     e[i,m]:=(det1)*znak1(i,m); {установление знака дополнений и }
  105.    end;                       {формирование присоединенной матрицы }
  106.  end;
  107. end;
  108.  
  109. {транспонирование матрицы}
  110. Procedure Trans(b:Tmatrix;var e:Tmatrix);
  111. var i,j:integer;
  112. begin
  113. for i:=1 to n do
  114. for j:=1 to n do
  115. e[i,j]:=b[j,i];
  116. end;
  117.  
  118. {нахождение корней умножением обратной матрицы на столбец свободных членов}
  119. Procedure Resh(n:integer;a:Tmatrix;b:Tmass;var x:Tmass);
  120. var k,j:integer;z:real;
  121. begin
  122. for k:=1 to n do
  123.  begin
  124.   x[k]:=0;
  125.   for j:=1 to n do
  126.    begin
  127.     z:=a[k,j]*b[j];
  128.     x[k]:=x[k]+z;
  129.    end;
  130.  end;
  131. end;
  132. var a,a1,at,b,c:Tmatrix;
  133.     f,x:Tmass;
  134.     det:Real;
  135.     i,j:integer;
  136. begin
  137. {решение системы}
  138. repeat
  139. write('Порядок системы  до ',nmax,' n=');
  140. readln(n);
  141. until n in [1..nmax];
  142. writeln('Введите коэффициенты системы:');
  143. for i:=1 to n do
  144. for j:=1 to n do
  145.  begin
  146.   write('a[',i,',',j,']=');
  147.   readln(a[i,j]);
  148.  end;
  149. writeln('Введите свободнык члены:');
  150. for i:=1 to n do
  151.  begin
  152.   write('f[',i,']=');
  153.   readln(f[i]);
  154.  end;
  155. writeln('Исходная система:');
  156. for i:=1 to n do
  157.  begin
  158.   for j:=1 to n do
  159.   write(a[i,j]:5:1);
  160.   writeln(f[i]:7:1);
  161.  end;
  162. writeln;
  163. a1:=a;{сделаем копию матрицы для нахождения определителя, она изменится}
  164. Opr(det,a1);{вычисление определителя  матрицы}
  165. writeln('Определитель=',det:0:0);
  166. if det=0 then
  167.  begin
  168.   write('Решений не существует');
  169.   readln;
  170.   exit;
  171.  end;
  172. Peresch(a,b); { вычисление присоединенной матрицы}
  173. Trans(b,c);{транспонирование присоединенной матрицы}
  174. for i:=1 to n do
  175. for j:=1 to n do
  176. c[i,j]:=c[i,j]/det;{деление на определитель=обратная матрица}
  177. {нахождение корней}
  178. Resh(n,c,f,x);
  179. for i:=1 to n do
  180. writeln('x[',i,']=',x[i]:0:1);
  181. readln;
  182. end.
Success #stdin #stdout 0s 4916KB
comments (?)
stdin 
2
1
-1
1
1
10
6
stdout 
Порядок системы  до 10 n=Введите коэффициенты системы:
a[1,1]=a[1,2]=a[2,1]=a[2,2]=Введите свободнык члены:
f[1]=f[2]=Исходная система:
  1.0 -1.0   10.0
  1.0  1.0    6.0

Определитель=2
x[1]=8.0
x[2]=-2.0
https://ideone.com/JBdJKv
language:
Pascal (gpc 20070904)
created:
4 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!