Все выпуски  

RFpro.ru: Программирование на Delphi и Lazarus


РАССЫЛКИ ПОРТАЛА RFPRO.RU

Лучшие эксперты в разделе

puporev
Статус: Профессионал
Рейтинг: 150
∙ повысить рейтинг »
zdwork
Статус: 2-й класс
Рейтинг: 120
∙ повысить рейтинг »
Асмик Гаряка
Статус: Советник
Рейтинг: 0
∙ повысить рейтинг »

∙ Pascal / Delphi / Lazarus

Номер выпуска:1772
Дата выхода:07.06.2019, 14:15
Администратор рассылки:Зенченко Константин Николаевич (Старший модератор)
Подписчиков / экспертов:32 / 36
Вопросов / ответов:2 / 2

Консультация # 195738: Здравствуйте! У меня возникли сложности с таким вопросом: Решение системы линейных алгебраических уравнений метод квадратных корней (Холецкого) Матрица А коэффициентов системы- 1,53 1,61 1,43 2,35 2,31 2,07 3,83 3,73 3,45 Столбец свободных членов b- -5,13 -3,69 -5,98 в Delphi ...
Консультация # 195739: Здравствуйте! У меня возникли сложности с таким вопросом: Решение системы линейных алгебраических уравнений методом Гаусса Матрица А коэффициентов системы- 1,53 1,61 1,43 2,35 2,31 2,07 3,83 3,73 3,45 Столбец свободных членов b- -5,13 -3,69 -5,98 в Delphi ...

Консультация # 195738:

Здравствуйте! У меня возникли сложности с таким вопросом:
Решение системы линейных алгебраических уравнений метод
квадратных корней (Холецкого)
Матрица А коэффициентов системы-
1,53 1,61 1,43
2,35 2,31 2,07
3,83 3,73 3,45
Столбец свободных членов b-
-5,13
-3,69
-5,98
в Delphi

Дата отправки: 27.05.2019, 23:50
Вопрос задал: mustang289 (Посетитель)
Всего ответов: 1
Страница онлайн-консультации »


Консультирует Зенченко Константин Николаевич (Старший модератор):

Здравствуйте, mustang289!

Код (Pascal) :: выделить код
const
  sizemat = 10;
type
  mattype = array[1..sizemat, 1..sizemat] of real;
  mattype1 = array[1..sizemat] of real;
procedure writemat(var a: mattype; n, m: byte);
var
  i, j: byte;
begin
  writeln;
  for i := 1 to n do
  begin
    for j := 1 to m do
      write(a[i, j]:7:3, ' ');
    writeln
  end;
end;
procedure inputmat(var a: mattype; var d: mattype1; var n: byte);
var
  i, j: byte;
begin
  writeln;
  write('size = ');
  readln(n);
  writeln;
  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,']=');
      readln(d[i]);
    end;
  writeln;
end;
procedure getBnC(var a, b, c: mattype; n: byte);
var
  k, i, a1, j: byte;
begin
  for k := 1 to n do
    for i := 1 to n do
      begin
        if k = i then c[k, i] := 1
          else c[k, i] := 0;
          b[k, i] := 0;
      end;
  for a1 := 1 to n do
  begin
    if a1 = 1 then
    begin
      for i := 1 to n do
        b[i, 1] := a[i, 1];
      for i := 2 to n do
        c[1, i] := a[1, i] / b[1, 1];
    end
    else
    begin
      k := a1;
      for i := a1 to n do
      begin
        b[i, k] := a[i, k];
        for j := 1 to k - 1 do
          b[i, k] := b[i, k] - b[i, j] * c[j, k];
      end;
      i := a1;
      for k := i + 1 to n do
      begin
        c[i, k] := a[i, k];
        for j := 1 to i - 1 do
          c[i, k] := c[i, k] - b[i, j] * c[j, k];
        c[i, k] := c[i, k] / b[i, i];
      end;
    end;
  end;
end;
procedure otvet(var b, c: mattype; d: mattype1; n: byte);
var
  x, y, s: mattype1;
  i, j, k: byte;
  w, q: real;
  y1, x1: mattype;
begin
  for i := 1 to n do
    if i = 1 then y[i] := d[i] / b[i, i]
    else
    begin
      w := 0;
      for k := 1 to i - 1 do
      begin
        y1[i, k] := w + b[i, k] * y[k];
        w := y1[i, k];
      end;
      y[i] := (d[i] - w) / b[i, i];
    end;
  for i := n downto 1 do
    if i = n then x[i] := y[i]
    else
    begin
      q := 0;
      for k := i + 1 to n do
      begin
        x1[i, k] := q + c[i, k] * x[k];
        q := x1[i, k];
      end;
      x[i] := y[i] - q;
    end;
  writeln;
  writeln('roots X:');
  writeln;
  for i := 1 to n do
    writeln('x[', i, ']= ', x[i]:1:4);
  writeln;
end;
var
  a, a1, c, b: mattype;
  d: mattype1;
  n: byte;
begin
  InputMat(a, d, n);
  getBnC(a, b, c, n);
  Writeln('matrix B: ');
  writemat(b, n, n);
  Writeln('matrix C: ');
  writemat(c, n, n);
  otvet(b, c, d, n);
  readln;
end.

Код брался тут.

Удачи!

Консультировал: Зенченко Константин Николаевич (Старший модератор)
Дата отправки: 06.06.2019, 18:56
Рейтинг ответа:

НЕ одобряю 0 одобряю!

Консультация # 195739:

Здравствуйте! У меня возникли сложности с таким вопросом:
Решение системы линейных алгебраических уравнений
методом Гаусса
Матрица А коэффициентов системы-
1,53 1,61 1,43
2,35 2,31 2,07
3,83 3,73 3,45
Столбец свободных членов b-
-5,13
-3,69
-5,98
в Delphi

Дата отправки: 27.05.2019, 23:51
Вопрос задал: mustang289 (Посетитель)
Всего ответов: 1
Страница онлайн-консультации »


Консультирует Зенченко Константин Николаевич (Старший модератор):

Здравствуйте, mustang289!

Код (Pascal) :: выделить код
const
  n=3;
type
  tMas=array[1..n,1..n+1]of real;
var
  a:array[1..n,1..n]of real;
  b:array[1..n]of real;
  t:tMas;
  i,j:integer;
procedure Gaus(var a:tMas;b,c:integer);
  var
    d,e:integer;
  begin
    if b<=c then
      begin
        e:=b;
        while e<=c do
          begin
            d:=c+1;
            while b<=d do
              begin
                a[e,d]:=a[e,d]/a[e,b];
                dec(d);
              end;
            inc(e);
          end;
        e:=b+1;
        while e<=c do
          begin
            for d:=b to c+1 do
              a[e,d]:=a[e,d]-a[b,d];
            inc(e);
          end;
        Gaus(a,b+1,c);
        a[b,b]:=a[b,4];
        e:=c;
        while b<e do
          begin
            a[b,b]:=a[b,b]-a[e,e]*a[b,e];
            dec(e);
          end;
      end;
  end;
begin
  for i:=1 to n do
    begin
      for j:=1 to n do
        begin
          write('a[',i,',',j,']:=');
          readln(a[i,j]);
        end;
      write('b[',i,']:=');
      readln(b[i]);
    end;
{  a[1,1]:=1.53;a[1,2]:=1.61;a[1,3]:=1.43;b[1]:=-5.13;
  a[2,1]:=2.35;a[2,2]:=2.31;a[2,3]:=2.07;b[2]:=-3.69;
  a[3,1]:=3.83;a[3,2]:=3.73;a[3,3]:=3.45;b[3]:=-5.98;}
  for i:=1 to n do
    begin
      for j:=1 to n do
        t[i,j]:=a[i,j];
      t[i,4]:=b[i];
    end;
  writeln('extenge matrix:');
  for i:=1 to n do
    begin
      for j:=1 to n+1 do
        write(t[i,j]:10:5);
      writeln;
    end;
  Gaus(t,1,n);
  writeln('roots:');
  for i:=1 to n do
    write(t[i,i]:10:5);
  writeln;
  writeln('check:');
  for i:=1 to n do
    begin
      t[i,4]:=0;
      for j:=1 to n do
        begin
          t[i,4]:=t[i,4]+a[i,j]*t[j,j];
          write(a[i,j]*t[j,j]:10:5);
        end;
      writeln(t[i,4]:10:5,' = ',b[i]:10:5);
    end;
  readln;
end.

Удачи!

Консультировал: Зенченко Константин Николаевич (Старший модератор)
Дата отправки: 06.06.2019, 18:59
Рейтинг ответа:

НЕ одобряю 0 одобряю!


Оценить выпуск | Задать вопрос экспертам

главная страница  |  стать участником  |  получить консультацию
техническая поддержка

Дорогой читатель!
Команда портала RFPRO.RU благодарит Вас за то, что Вы пользуетесь нашими услугами. Вы только что прочли очередной выпуск рассылки. Мы старались. Пожалуйста, оцените его. Если совет помог Вам, если Вам понравился ответ, Вы можете поблагодарить автора - для этого в каждом ответе есть специальные ссылки. Вы можете оставить отзыв о работе портале. Нам очень важно знать Ваше мнение. Вы можете поближе познакомиться с жизнью портала, посетив наш форум, почитав журнал, который издают наши эксперты. Если у Вас есть желание помочь людям, поделиться своими знаниями, Вы можете зарегистрироваться экспертом. Заходите - у нас интересно!
МЫ РАБОТАЕМ ДЛЯ ВАС!


В избранное