VPF::[Delphi | Pascal] решение СЛАУ - Форум программистов

valentos

Дата 5.5.2007, 17:44 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 187
Регистрация: 7.12.2006
Где: Belarussia, Gomel

Репутация: 2
Всего: 2

1. В среде Delphi (Можно в Pascal) написать приложение, осуществляющее решение СЛАУ методом Крамера и Гаусса.

Кстати, при написании проги желательно использовать динамический массив!
Полностью прогу писать необязательно, мне надо только рабочие Методы(Крамера и Гаусса). И пожалуйста с коментами, что бы знать что куда относиться!
smile

--------------------

[code=sql]select name, telephone from Girls where age between 20 and 25 and (.)(.) >= 2 order by IQ desc [/code]

Rodman

Дата 5.5.2007, 18:35 (ссылка)

(нет голосов)

Загрузка ...

CIO

Профиль
Группа: Участник
Сообщений: 6144
Регистрация: 7.5.2006
Где: Ukraine ⇛ Kyiv ci ty

Репутация: 26
Всего: 122

Код


program Approx;
{$APPTYPE CONSOLE}
Uses Math, Sysutils;
const nn=15; n=4; m=1; { м - степень полинома, n - количество входных значений} 
var a: array [1..nn,1..nn] of real; xx,xk,x,y: array[1..nn] of real; b: array[1..m+1] of real;
n1,i,j,k,t: integer; nu,y_,sn,s,d: real;
begin
n1:=m+1;
x[1]:=0; x[2]:=1; x[3]:=2; x[4]:=3;
y[1]:=5; y[2]:=3; y[3]:=2; y[4]:=0;
(* Формирование матрицы *)
for i:=0 to m do for j:=0 to m do
begin
s:=0;
for k:=1 to n do s:=s+Power(x[k],i+j);
a[i+1,j+1]:=s;
end;
(***********************)
(* Формирование столбца свободных членов *)
for i:=0 to m do
begin
s:=0;
for k:=1 to n do s:=s+y[k]*Power(x[k],i);
b[i+1]:=s;
end;
for i:=1 to n1 do
begin
 for j:=1 to n1 do write(' ',a[i,j]:5:2);
write(' =',b[i]:5:2); writeln;
 end;
writeln('---');
(*****************************************)
(* Решение СЛАУ методом Гаусса *)
for i:=1 to n1-1 do
begin
for k:=i+1 to n1 do
begin
d:=a[k,i]/a[i,i];
for j:=i+1 to n1 do
a[k,j]:=a[k,j]-a[i,j]*d;
b[k]:=b[k]-b[i]*d;
end;
end;
for i:=n1 downto 1 do
begin
for j:=i+1 to n1 do
b[i]:=b[i]-a[i,j]*xx[j];
xx[i]:=b[i]/a[i,i];
end;
for i:=1 to n1 do writeln(xx[i]:5:2);
(******************************)
writeln('---');
(* Получение приближения функции *)
for i:=1 to n do
begin
s:=0;
for j:=1 to n1 do s:=s+xx[j]*Power(x[i],j-1);
xk[i]:=s;
writeln(y[i]:5:2,' ',xk[i]:5:2);
end;
writeln('---');
(********************************)
(* Оценка качества аппроксимации *)
s:=0; for k:=1 to n do s:=s+sqr(y[k]-xk[k]);
sn:=sqrt(1/(n-1)*s);
s:=0; for k:=1 to n do s:=s+y[k];
y_:=(1/n)*s;
nu:=(sn/y_)*100;
writeln(nu:5:2);
(*********************************)
readln;
end.

http://forum.sources.ru/index.php?showtopi...mp;view=showall

http://forum.sources.ru/index.php?showtopic=53319

--------------------

CRM с функцией АвтоОбзвона

Лотереи мира

valentos

Дата 5.5.2007, 18:59 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 187
Регистрация: 7.12.2006
Где: Belarussia, Gomel

Репутация: 2
Всего: 2

Сложновато!!
Может лучше поможешь разобраться в этих 2 функциях?!
Тут короче прога, в нее вводиться фиксированное кол-во уравнений и неизвестных,
тобиш тут массив 3х4, мне надо переделать эту прогу так чтобы можно было изменять
кол-во уравнений и неизвестных, т.е. с использованием динамичесого массива.
Для такого массива вроде нужно использовать:
mas: array of array of real;
setlength(mas,n,m);

Так вот сел я вчера переделывать и сломал голову над этой кодярой. Непонятно что откуда, если ты поймешь исправь под. дин. массив или хотябы откоментируй!!
И еще одно, при использовании дин. массива, когда перекачиваешь данные в такой массив, бьет ошибка, пока не увеличишь его размер массива на 1 больше, что это может быть? Плиз помогите!!!

Код



Function tdesslau.Gaus: Boolean;
Var
  i,j,k,l:Integer;
  a:array [1..3,1..4] of real;
  w,m,t:real;
Begin
  form1.Memo2.Lines.Clear;
  for i:=1 to 3 do
    for j:=1 to 4 do a[i,j]:=q[i,j];
  For k:=1 to 2 do
    begin
      l:=0; m:=0;
      For i:=k to 3 do
        If Abs(a[i,k])>m then begin
          m:=Abs(a[i,k]);
          l:=i;
        end;
      If l=0 then begin
        form1.memo2.Lines.clear;
        form1.memo2.Lines.Add('система методом Гаусса не решается');;
        Exit;
      end;
      If l<>k then begin
        For j:=1 to 3 do begin
          t:=a[k,j];
          a[k,j]:=a[l,j];
          a[l,j]:=t;
        end;
        t:=a[k,4];
        a[k,4]:=a[l,4];
        a[l,4]:=t;
      end;
      For i:=k+1 to 3 do begin
        if a[k,k]=0 then begin
          form1.memo2.Lines.clear;
          form1.memo2.Lines.Add('система методом Гаусса не решается');
          exit;
                         end;
        w:=a[i,k]/a[k,k];
        For j:=1 to 3 do
          If j=k then a[i,j]:=0
          else a[i,j]:=a[i,j]-w*a[k,j];
        a[i,4]:=a[i,4]-w*a[k,4];
      end;
     end;
     if a[3,3]=0 then
       begin
         form1.memo2.Lines.clear;
         form1.memo2.Lines.Add('система методом Гаусса не решается');
         exit;
       end;
     xk[3]:=a[3,4]/a[3,3];
     For i:=2 downto 1 do begin
         t:=0;
         For j:=1 to 3-i do t:=t+a[i,i+j]*xk[i+j];
          if a[i,i]=0 then
            begin
              form1.memo2.Lines.clear;
              form1.memo2.Lines.Add('система методом Гаусса не решается');
              exit;
            end;
         xk[i]:=(1/a[i,i])*(a[i,4]-t);
     end;

     for i:=1 to 3 do
       form1.memo2.Lines.Add(floattostr(xk[i]));
End;

procedure TDesSLAU.opr3(ax:a3; var d:integer);
    begin
     d:=ax[1,1]*ax[2,2]*ax[3,3]+ax[1,3]*ax[2,1]*ax[3,2]
     +ax[1,2]*ax[2,3]*ax[3,1]-ax[3,1]*ax[2,2]*ax[1,3]
     -ax[2,1]*ax[1,2]*ax[3,3]-ax[3,2]*ax[2,3]*ax[1,1];
    end;

function tdesslau.kramer:boolean;
var az:a3;
 i,j,d,d1:integer;
 x:array[1..3] of real;
begin
  form1.memo1.lines.clear;
  for i:=1 to 3 do
    for j:=1 to 3 do az[i,j]:=q[i,j];
   slau.opr3(az,d);
   if d=0 then
       begin
         form1.memo1.lines.add('определитель равен нулю,система методом Крамера не решается');
         exit;  
       end;
    for i:=1 to 3 do
      for j:=2 to 3 do az[i,j]:=q[i,j];
      for i:=1 to 3 do az[i,1]:=q[i,4];
   slau.opr3(az,d1);
   x[1]:=d1/d;
    for i:=1 to 3 do az[i,1]:=q[i,1];
    for i:=1 to 3 do az[i,2]:=q[i,4];
    for i:=1 to 3 do az[i,3]:=q[i,3];
   slau.opr3(az,d1);
   x[2]:=d1/d;
    for i:=1 to 3 do az[i,1]:=q[i,1];
    for i:=1 to 3 do az[i,2]:=q[i,2];
    for i:=1 to 3 do az[i,3]:=q[i,4];
   slau.opr3(az,d1);
   x[3]:=d1/d;
    form1.memo1.lines.clear;
    for i:=1 to 3 do form1.memo1.lines.add(floattostr(x[i]));


end;

Это сообщение отредактировал(а) valentos - 6.5.2007, 08:24

--------------------

[code=sql]select name, telephone from Girls where age between 20 and 25 and (.)(.) >= 2 order by IQ desc [/code]

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Центр помощи \| Следующая тема »