Технический форум

Технический форум (http://www.tehnari.ru/)
-   Помощь студентам (http://www.tehnari.ru/f41/)
-   -   Решение системы линейных уравнений - программа не работает (http://www.tehnari.ru/f41/t43929/)

kalugin66 27.12.2010 15:31

Решение системы линейных уравнений - программа не работает
 
при помощи гугла собрал программку на паскале почти без знания паскаля:), но не хватает сил, чтобы понять, почему после того как все значения введены программа падает:(


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 [i]: =b [i] -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 [i]: = (b [i] +s) /a [i, i] ;
writeln ('x [', i,'] =',x [i]: 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 [i]: =0;
for i: =1 to n do
for j: =1 to n do
s [i]: =s [i] +z [i,j] *y [j] ;
writeln ('Вывод результатов решения системы уравненй матричным способом');
for i: =1 to n do write (' ', s [i]: 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 [i]);
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=) 27.12.2010 16:54

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

kalugin66 27.12.2010 18:04

Цитата:

Сообщение от shrek=) (Сообщение 435288)
Я думаю было бы уместно выложить само задание.

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

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

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 27.12.2010 21:48

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

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

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

kalugin66 28.12.2010 03:33

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

Vladimir_S 28.12.2010 22:41

Цитата:

Сообщение от kalugin66 (Сообщение 435537)
можете соорудить только гаусса? чтоб программа одним из способов решала:)

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

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; - недопустимо.


Часовой пояс GMT +4, время: 19:09.

Powered by vBulletin® Version 4.5.3
Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.