Решение системы линейных уравнений - программа не работает

[kalugin66]

Решение системы линейных уравнений - программа не работает

при помощи гугла собрал программку на паскале почти без знания паскаля, но не хватает сил, чтобы понять, почему после того как все значения введены программа падает


Program Gauss;
uses crt;
const N=3;
eps=0.00001; { all numbers less than eps are equal 0 }
type matr=array [1. n,1. n] of real;
mas=array [1. n] of real;
var
i,j: integer;
b,x: mas;
variant: byte;
a,c: matr;
dt: real;
imx,np: integer;
{*** печать исходной и обратной матрицы*** }
procedure PrintMatr2 (m,m1: matr; n,nz,nd: integer);
var i,j: integer;
begin
for i: =1 to n do
begin
if (i=1) then write (np: 2,': ')
else write (' ');
for j: =1 to n do
write (m [i,j]: nz: nd); write (' ');
for j: =1 to n do
write (m1 [i,j]: nz: nd);
writeln;
end;
inc (np);
end;
procedure MultString (var a,b: matr; i1: integer; r: real);
var j: integer;
begin
for j: =1 to n do
begin
a [i1,j]: =a [i1,j] *r;
b [i1,j]: =b [i1,j] *r;
end;
end;
procedure AddStrings (var а,b: matr; i1, i2: integer; r: real);
{ процедура прибавляет к i1 строке матрицы а i2-ю умноженную на r}
var j: integer;
begin
for j: =1 to n do
begin
a [i1,j]: =a [i1,j] +r*a [i2,j] ;
b [i1,j]: =b [i1,j] +r*b [i2,j] ;
end;
end;
procedure MultMatr (a,b: matr; var c: matr);
var i,j,k: byte;
s: real;
begin
for i: =1 to n do
for j: =1 to n do
begin
s: =0;
for k: =1 to n do
s: =s+a [i,k] *b [k,j] ;
c [i,j]: =s;
end;
end;
function sign (r: real): shortint;
begin
if (r>=0) then sign: =1 else sign: =-1;
end;
{***************************************************}
{** вычеркивание из матрицы строки и столбца **}
procedure GetMatr (a: matr; var b: matr; m, i,j: integer);
var ki,kj,di,dj: integer;
begin
di: =0;
for ki: =1 to m-1 do
begin
if (ki=i) then di: =1;
dj: =0;
for kj: =1 to m-1 do
begin
if (kj=j) then dj: =1;
b [ki,kj]: =a [ki+di,kj+dj] ;
end;
end;
end;
{*** метод Гаусса *******}
procedure gauss (a: matr; b: mas; var x: mas; n: integer);
Var k: byte;
m, s: real;
begin
{ приведение к треугольному виду}
For k: =1 to N-1 do
For i: =k+1 to n do
begin
m: =a [i,k] /a [k,k] ;
a [i,k]: =0;
For j: =k+1 to N do
a [i,j]: =a [i,j] -m*a [k,j] ;
b : =b -m*b [k] ;
end;
{расчет неизвестных х в обратном порядке}
x [n]: =b [n] /a [n,n] ;
writeln;
writeln ('Вывод результатов решения системы уравнений методом Гаусса');
writeln ('x [',n,'] =',x [n]: 6: 2);
for i: = (n-1) downto 1 do
begin s: =0;
For j: =i+1 to n do
s: =s-a [i,j] *x [j] ;
x : = (b +s) /a [i, i] ;
writeln ('x [', i,'] =',x : 6: 2);
end;
end;
{*** матричный способ ***}
procedure matrica (a: matr; y: mas; n: integer);
var z,a0: matr;
imx,np: integer;
s: mas;
begin
for i: =1 to n do
begin
for j: =1 to n do z [i,j]: =0;
z [i, i]: =1;
end;
for i: =1 to n do
for j: =1 to n do
a0 [i,j]: =a [i,j] ;
for i: =1 to n do
begin
{ к i-ой строке прибавляем (или вычитаем) j-ую строку
взятую со знаком i-того элемента j-ой строки. Таким образом,
на месте элементова a [i, i] возникает сумма модулей элементов i-того
столбца (ниже i-ой строки) взятая со знаком бывшего элемента a [i, i],
равенство нулю которой говорит о несуществовании обратной матрицы }
for j: =i+1 to n do
AddStrings (a,z, i,j,sign (a [i, i]) *sign (a [j, i]));
{ PrintMatr (a,b,n,6,1); }
{ прямой ход }
if (abs (a [i, i]) >eps) then
begin
MultString (a,z, i,1/a [i, i]);
for j: =i+1 to n do
AddStrings (a,z,j, i,-a [j, i]);
{ PrintMatr (a,b,n,6,1); }
end
else
begin
writeln ('Обратной матрицы не существует. ');
halt;
end
end;
{обратный ход: '); }
if (a [n,n] >eps) then
begin
for i: =n downto 1 do
for j: =1 to i-1 do
begin
AddStrings (a,z,j, i,-a [j, i]);
end;
{ PrintMatr (a,b,n,8,4); }
end
else writeln ('Обратной матрицы не существует. ');
MultMatr (a0,z,a);
writeln ('Начальная матрица, обратная к ней матрица: ');
PrintMatr2 (a0,z,n,7,3);
{** умножение обратной матрицы на столбец свободных членов **}
for i: =1 to n do s : =0;
for i: =1 to n do
for j: =1 to n do
s : =s +z [i,j] *y [j] ;
writeln ('Вывод результатов решения системы уравненй матричным способом');
for i: =1 to n do write (' ', s : 5: 2);
end;
begin {***** тело программы ******}
clrscr;
writeln ('ввод матрицы коэффициентов при неизвестных х');
for i: =1 to N do
for j: =1 to N do
begin
write (' введите a [', i,',',j,'] => ');
read (a [i,j]);
end;
writeln ('ввод столбца свободных членов');
for i: =1 to N do
begin
write (' введите b [', i,'] => ');
read (b );
end;
writeln ('введите вариант ');
writeln (' 1 - решение системы линейных уравнений методом Гаусса ');
write (' 2 - решение системы линейных уравнений матричным методом => ');
readln (variant);
case variant of
1: gauss (a,b,x,n);
2: matrica (a,b,n);
else writeln ('неверно указан вариант');
end;
end.

 

[shrek=)]

Я думаю было бы уместно выложить само задание.

 

[kalugin66]

Я думаю было бы уместно выложить само задание.

программа должна решать систему линейных уравнений матричным методом и методом гаусса с любым количеством неизвестных$%.

примеры линейных уравнений

27x1-3x2+0,5x3=1,5
-2x1+4x2+1,7x3=12,5
-0,37x1-0,18x2+-3x3=10,25

0,3x1+3,3x2-9,5x3=12,5
6,1x1-4,3x2-1,1x3=-5,5
-4,7x1+6,7x2-7,4x3=41,41

 

[Vladimir_S]

Уважаемый Kalugin, как-то вот не очень я верю, что (если, конечно, приведен реальный листинг) Вы могли не то, что данные ввести, а и просто программу оттранслировать. Дело, видите ли, в том, что подобных конструкций:

array [1. n,1. n], array [1. n]

не пропустит ни один Паскаль-транслятор, потому как диапазон обозначается через двойную точку, а не точку+пробел, т.е. надо так:

array [1..n,1..n], array [1..n]

Теперь по сути задачи.
К сожалению, чтобы иметь возможность Вам помочь, мне, например, надо влезть в полузабытую алгебру, и, в частности, в матричный метод решения СЛАУ (гауссов я знаю). Одно я помню: получить обратную матрицу - дело ох, непростое, и даже изрядно муторное, а потому та краткость, с которой решается эта проблема в приведенном листинге, вызывает некоторые подозрения. Нет, я не утверждаю, что это неправильно, просто не знаю, надо разбираться.
А вот разбираться в эти предновогодние дни мне, уж простите, просто некогда. Если дело терпит до января, то еще может быть, а нет - так увы, ничем не могу помочь.
Впрочем, может быть кто-нибудь еще возьмется?

 

[kalugin66]

можете соорудить только гаусса? чтоб программа одним из способов решала

 

[Vladimir_S]

можете соорудить только гаусса? чтоб программа одним из способов решала

Могу. Соорудил:

Program Gauss;
uses crt;
const
 N=3;
 eps=0.00001; { all numbers less than eps are equal to 0 }
type
 matr=array [1..n,1..n] of real;
 mas=array [1..n] of real;
var
 i,j: integer;
 b,x: mas;
 a: matr;
{*** метод Гаусса *******}
procedure gausss(ag: matr; bg: mas; var xg: mas; Ng: integer);
 Var
  k,ig,jg: byte;
  m,s: real;
  blg:boolean;
  c:mas;
 begin

{ приведение к треугольному виду}
  For k:=1 to Ng-1 do
   begin
    If ABS(ag[k,k])<eps then
     begin
      ig:=k;
      blg:=false;
      repeat
       Inc(ig);
       if ABS(ag[ig,k])>eps then
        begin
         blg:=true;
         c:=ag[k];
         ag[k]:=ag[ig];
         ag[ig]:=c;
         s:=bg[k];
         bg[k]:=bg[ig];
         bg[ig]:=s;
        end;
      until blg;
     end;
    m:=ag[k,k];
    for jg:=k to Ng do
     ag[k,jg]:=ag[k,jg]/m;
    bg[k]:=bg[k]/m;
    for ig:=k+1 to Ng do
     if ABS(ag[ig,k])>eps then
      begin
       m:=ag[ig,k];
       for jg:=k to Ng do
        ag[ig,jg]:=ag[k,jg]-ag[ig,jg]/m;
       bg[ig]:=bg[k]-bg[ig]/m;
      end
     else
      ag[ig,k]:=0;
   end;

{расчет неизвестных х в обратном порядке}
 xg[Ng]:=bg[Ng]/ag[Ng,Ng] ;
 for ig:=(Ng-1) downto 1 do
  begin
   s:=0;
   For jg:=ig+1 to Ng do
    s:=s+ag[ig,jg]*xg[jg] ;
   xg[ig]:=bg[ig]-s;
  end;
end;

BEGIN {***** тело программы ******}
 clrscr;
 writeln ('ввод матрицы коэффициентов при неизвестных х');
 for i:=1 to N do
  for j:=1 to N do
   begin
    write (' введите a [', i,',',j,'] => ');
    readln (a [i,j]);
   end;
 writeln ('ввод столбца свободных членов');
 for i:=1 to N do
  begin
   write (' введите b [', i,'] => ');
   readln (b [i]);
  end;
 Writeln;
 gausss (a,b,x,n);
 writeln ('Вывод результатов решения системы уравнений методом Гаусса');
 for i:=1 to n do
  writeln('x [',i,'] =',x[i]:6:2);
 readln;
END.

Между прочим, еще раз убедился, что Ваши уверения в том, что Вы якобы свою программу запускали, есть, извините за прямоту, чистой воды враньё. Ибо при таком количестве ошибок ни о какой даже трансляции, а не то что запуске, и речи быть не может. Отмечу (на будущее) главные:
1. Называть программу и процедуру одним именем - недопустимо (у Вас там и там "gauss").
2. Запись операции присваивания не допускает разрывов и пробелов, т.е:
x:= 45; - правильно, а
x: = 45; - недопустимо.