Технический форум
Вернуться   Технический форум > Программирование > Форум программистов > Delphi, Kylix and Pascal


Ответ
 
Опции темы Опции просмотра
Старый 11.06.2018, 12:32   #1 (permalink)
annie7
Новичок
 
Регистрация: 11.06.2018
Сообщений: 3
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
По умолчанию Результат программы - Pascal

Помогите исправить результат у обратной матрицы (начальная выводиться с ошибками).
Т.е. исходная матрица должна равняться стартовой. От этого ошибка в дальнейших расчетах.

program lr;

type
mtr = array[0..9, 0..9] of real;

const
eps = 0.00001;{ all numbers less than eps are equal 0 }

var
np: integer;
n: byte;

procedure trans_pob(var a: mtr; n: byte);
var
i, j: byte;
x: real;
begin
for i := 1 to n do
for j := 0 to i - 1 do
begin
x := a[i, j];
a[i, j] := a[j, i];
a[j, i] := x;
end;
writeln('Matrix transponirovannaya otnositelno pobochnoy diagonal ');
for i := 0 to n - 1 do
begin
for j := 0 to n - 1 do
write(a[i, j]:3);
writeln;
end;
readln;
end;

function scal(a: mtr; n, st, sb: byte): real;
var
i: byte;
s: real;
begin
s := 0;
for i := 0 to n - 1 do
s := s + a[st - 1, i] * a[i, sb - 1];
scal := s;
end;

procedure PrintMatr(m, m1: mtr; n, nz, nd: integer);
var
i, j: integer;
begin
for i := 1 to n do
begin

for j := 1 to n do
write(m[i, j]:nz:nd);
for j := 1 to n do
write(m1[i, j]:nz:nd);
writeln;
end;

end;

procedure MultString(var a, b: mtr; 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 a, b: mtr; i1, i2: integer; r: real);
{ Процедура прибавляет к i1 строке матрицы a 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: mtr; var c: mtr);
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;

var
a, b, a0, d: mtr;
w, i, j, s1, s2: byte;

begin
repeat
write('Vvedite size matrix from 2 to 10, n = ');
read(n);
until n in [2..10];
randomize;
writeln('Ishodnaya matrix ');
for i := 0 to n - 1 do
begin
for j := 0 to n - 1 do
begin
a[i, j] := 1 + random(10);
write(a[i, j]:3);
end;
writeln;
end;
writeln('Vyberite preobrazovanie');
writeln('1 - Perestanovka two strok');
writeln('2 - Transponirovanie matrix otnositelno pobochnoy diagonal');
writeln('3 - Skalyarnoe proizvedenie stroki and stolbza');
repeat
read(w);
until w in [1..3];
case w of
1: trans_pob(a, n);
2:
begin
repeat
write('Vvedite number stroki from 1 to ', n, ' s1 = ');
read(s1);
if (s1 > n) then
begin
writeln('Stroki s vvedynnym number ne sushestvuet');
read;
end else
until s1 in [1..n];
repeat
write('Vvedite number stolbza from 1 to ', n, ' s2 = ');
read(s2);
if (s2 > n) then
begin
writeln('Stolbza s vvedynnym number ne sushestvuet');
read;
end else
until s2 in [1..n];
writeln('Skalyarnoe proizvedenie stroki ', s1, ' and stolbza ', s2, ' = ', scal(a, n, s1, s2));
readln;
end;
3:
begin{ начало основной программы }
for i := 1 to n do
begin
for j := 1 to n do
begin
b[i, j] := 0;
d[i, j] := a[i, j];
end;
b[i, i] := 1;
end;
for i := 1 to n do
for j := 1 to n do
a0[i, j] := d[i, j];
writeln('Starting matrix:');np := 0;
PrintMatr(d, b, n, 6, 1);
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(d, b, i, j, sign(d[i, i]) * sign(d[j, i]));
{ PrintMatr(a,b,n,6,1);}
{ Прямой ход }
if (abs(d[i, i]) > eps) then
begin
MultString(d, b, i, 1 / d[i, i]);
for j := i + 1 to n do
AddStrings(d, b, j, i, -d[j, i]);
{ PrintMatr(d,b,n,6,1);}
end
else
begin
writeln('Обратной матрицы не существует.');
halt;
end
end;
{writeln('Обратный ход:');}
if (d[n, n] > eps) then
begin
for i := n downto 1 do
for j := 1 to i - 1 do
begin
AddStrings(d, b, j, i, -d[j, i]);
end;
{ PrintMatr(d,b,n,8,4);}
end
else writeln('Обратной матрицы не существует.');
MultMatr(a0, b, d);
writeln('Начальная матрица, обратная к ней матрица:');
PrintMatr(a0, b, n, 7, 3);
writeln('Проверка: должна быть единичная матрица.');
PrintMatr(d, d, n, 7, 3);
end;
end;
end.
Миниатюры
aacuiyiiue.png  
annie7 вне форума   Ответить с цитированием

Старый 11.06.2018, 12:32
Helpmaster
Member
 
Аватар для Helpmaster
 
Регистрация: 08.03.2016
Сообщений: 0

В более обсуждаемых темах можно найти полезные ответы

Программы, Pascal
Программы в Pascal
Помогите с написанием программы на Pascal

Старый 11.06.2018, 17:18   #2 (permalink)
Vladimir_S
Специалист
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
По умолчанию

Хотел бы попробовать Вам помочь, но для этого мне нужно:
1. ПОЛНОЕ задание (можно в виде прикрепленного файла doc (docx) или txt).
2. По возможности полное описание хода Ваших действий при решении задачи, включая алгоритм нахождения обратной матрицы (их есть несколько).

Пока же я вижу какой-то сумбур. Вот что за бред: "исходная матрица должна равняться стартовой"? Если матрица — исходная, то она же, естественно, и стартовая и, конечно, равна сама себе. Если речь идёт о матрице после некоторых действий (например, двойного инвертирования), то так и надо писать.
Далее, п.1 меню Вы обозначаете "Перестановка двух строк" и отсылаете к процедуре trans_pob. Но это процедура никакой не перестановки двух строк, а простого транспонирования матрицы (т.е. относительно ГЛАВНОЙ диагонали), в комментарии же внутри процедуры Вы утверждаете, что это транспонирование относительно ПОБОЧНОЙ диагонали, что несколько сложнее. И так далее, и тому подобное.
Vladimir_S вне форума   Ответить с цитированием
Старый 11.06.2018, 18:55   #3 (permalink)
annie7
Новичок
 
Регистрация: 11.06.2018
Сообщений: 3
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
По умолчанию

Приложила саму программу и задание.

Да, к сожалению, не исправила "Перестановка строк" и т.д. Осталось с прошлой программы, подобной этой.

Обратная матрица вычисляется с помощью метода Гаусса.
Вложения
Тип файла: txt Программа.txt (5.0 Кб, 741 просмотров)
Тип файла: txt Задание.txt (348 байт, 831 просмотров)
annie7 вне форума   Ответить с цитированием
Старый 11.06.2018, 19:02   #4 (permalink)
Vladimir_S
Специалист
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
По умолчанию

Цитата:
Сообщение от annie7 Посмотреть сообщение
Приложила саму программу и задание.

Да, к сожалению, не исправила "Перестановка строк" и т.д. Осталось с прошлой программы, подобной этой.

Обратная матрица вычисляется с помощью метода Гаусса.
Спасибо. Ладно, попробую сегодня-завтра.
Vladimir_S вне форума   Ответить с цитированием
Старый 11.06.2018, 19:06   #5 (permalink)
annie7
Новичок
 
Регистрация: 11.06.2018
Сообщений: 3
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
По умолчанию

Хорошо, спасибо большое.
annie7 вне форума   Ответить с цитированием
Ads

Яндекс

Member
 
Регистрация: 31.10.2006
Сообщений: 40200
Записей в дневнике: 0
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 55070
Старый 12.06.2018, 20:23   #6 (permalink)
Vladimir_S
Специалист
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
По умолчанию

Ох, боюсь, не справиться мне в назначенный срок. Старею, видать. Всю голову сломал над отладкой программы, а конца не видно. А тут ещё эта ненавистная СИ-шная нумерация с нуля, ужасно мешает. И критерий вырожденности матрицы какой-то мутный... Попробовал по-своему и окончательно запутался. Надеюсь, что добью.
Vladimir_S вне форума   Ответить с цитированием
Старый 13.06.2018, 17:00   #7 (permalink)
Vladimir_S
Специалист
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
По умолчанию

Так, ну начинает кое-что получаться. Правда, с этими критериями вырожденности и вообще с возможным возникновением нулевых элементов — некие непонятки. Но, во всяком случае, обратную матрицу я получил (по критерию результата произведения исходной и полученной матриц в виде единичной матрицы).
Тьфу ты, и не думал, что эта ерунда — такая сложная окажется. Ещё поковыряю, прежде чем выкладывать.
Vladimir_S вне форума   Ответить с цитированием
Старый 14.06.2018, 14:28   #8 (permalink)
Vladimir_S
Специалист
 
Регистрация: 27.08.2008
Адрес: Санкт-Петербург
Сообщений: 27,807
Сказал(а) спасибо: 340
Поблагодарили 583 раз(а) в 208 сообщениях
Репутация: 113184
По умолчанию

Уф, ну, не знаю, актуально ещё или нет, но, признаться, самого "заело". Вроде "добил".
Несколько замечаний.
1. Программа зациклена с возможностью выхода.
2. Транспонирование матрицы сделано "по рабоче-крестьянски", т.е. с генерацией другой матрицы, а не с преобразованием исходной. Это нужно затем, чтобы сохранить исходную матрицу для последующих действий, не куроча её.
3. Поиск обратной матрицы сделан "из первых принципов", т.е. процедура написана "с нуля". В принципе, ошибка может возникнуть, если диагональный элемент обнулился, а на него надо делить. Для такого случая предусмотрено завершение программы с выводом сообщения о невозможности решения. Впрочем, сколько ни гонял, на такое не напоролся ни разу. Вероятно, это может возникнуть, если матрица вырождена, но вырожденную матрицу нужно специально строить, случайное же её появление очень маловероятно.
Код:
program lr;

type
  mtr = array[0..9, 0..9] of real;

const
  eps = 0.00001;{ all numbers less than eps are equal to zero }

var
  a,b,d:mtr;
  w,i,j,s1,s2,n:byte;

procedure Trans(m1:mtr;var m2:mtr);
var
  i,j:byte;
begin
 for i:=0 to n-1 do
  for j:=0 to n-1 do
   m2[i,j]:=m1[j,i];
end;

function Scal(a:mtr; st,sb:byte):real;
var
  i:byte;
  s:real;
begin
  s:=0;
  for i:=0 to n-1 do
   s:=s+a[st-1,i]*a[i,sb-1];
  scal:=s;
end;

procedure PrintMatr(m:mtr);
var
  i,j:integer;
begin
  for i:=0 to n-1 do
  begin
    for j:=0 to n-1 do
      write(m[i,j]:8:3);
    writeln;
  end;
end;

procedure Inversion(m:mtr; var c:mtr);
var
 m1,e:mtr;
 i,j,k,p,r:byte;
 Q,Dummy:real;
begin
 for i:=0 to n-1 do
  for j:=0 to n-1 do
   begin
    m1[i,j]:=m[i,j];
    e[i,j]:=0;
   end;
 for i:=0 to n-1 do e[i,i]:=1;
 {Avers}
 for k:=0 to n-1 do
  begin
   Q:=m1[k,k];
   if Abs(Q)<eps then
    begin
     Writeln('No solution!');
     Readln;
     Halt;
    end
   else
    begin
     for j:=0 to n-1 do
      begin
       m1[k,j]:=m1[k,j]/Q;
       e[k,j]:=e[k,j]/Q;
      end;
     for i:=k+1 to n-1 do
      begin
       Q:=m1[i,k];
       if Abs(Q)<eps then
        m1[i,k]:=0
       else
        for j:=0 to n-1 do
         begin
          m1[i,j]:=m1[i,j]/Q;
          e[i,j]:=e[i,j]/Q;
          m1[i,j]:=m1[k,j]-m1[i,j];
          e[i,j]:=e[k,j]-e[i,j];
         end;
      end;
    end;
  end;

 {Revers}
 for k:=n-1 downto 0 do
  begin
   Q:=m1[k,k];
   if Abs(Q)<eps then
    begin
     Writeln('No solution!');
     Readln;
     Halt;
    end
   else
    begin
     for j:=n-1 downto 0 do
      begin
       m1[k,j]:=m1[k,j]/Q;
       e[k,j]:=e[k,j]/Q;
      end;
     if k>0 then
      begin
       for i:=k-1 downto 0 do
        begin
         Q:=m1[i,k];
         if Abs(Q)<eps then
          m1[i,k]:=0
         else
          for j:=n-1 downto 0 do
           begin
            m1[i,j]:=m1[i,j]/Q;
            e[i,j]:=e[i,j]/Q;
            m1[i,j]:=m1[i,j]-m1[k,j];
            e[i,j]:=e[i,j]-e[k,j];
           end;
        end;
      end;
    end;
  end;
 for i:=0 to n-1 do
  for j:=0 to n-1 do
   c[i,j]:=e[i,j];
end;

procedure MultMatr(a,b:mtr; var c:mtr);
var
  i,j,k:byte;
  s:real;
begin
  for i:=0 to n-1 do
    for j:=0 to n-1 do
    begin
      s:=0;
      for k:=0 to n-1 do
       s:=s+a[i,k]*b[k,j];
      c[i,j]:=s;
    end;
end;

Begin
 repeat
  write('Enter the matrix size from 2 to 10, n = ');
  readln(n);
 until n in [2..10];
 randomize;
 for i:=0 to n-1 do
  for j:=0 to n-1 do a[i,j]:=1+random(10);
 Repeat
  writeln;
  writeln('Choose the action:');
  writeln('1 - Matrix transposition');
  writeln('2 - Scalar product of string and column');
  writeln('3 - Inverse matrix');
  writeln('4 - Quit');
  repeat
    readln(w);
  until w in [1..4];
  case w of
    1:
      begin
       Trans(a,b);
       Writeln('Initial matrix:');
       PrintMatr(a);
       Writeln;
       Writeln('Transposed matrix:');
       PrintMatr(b);
      end;
    2:
      begin
       repeat
        Writeln('Initial matrix:');
        PrintMatr(a);
        Writeln;
        write('Enter the string number from 1 to ', n, ' s1 = ');
        readln(s1);
        if (s1>n) then
         writeln('String with this number does not exist');
       until s1 in [1..n];
       repeat
        write('Enter the column number from 1 to ', n, ' s2 = ');
        readln(s2);
        if (s2>n) then
         writeln('Column with this number does not exist');
        until s2 in [1..n];
        writeln('Scalar product of string ',s1,' and column ', s2, ' = ', Scal(a,s1,s2):0:3);
      end;
    3:
      begin
       Inversion(a,b);
       Writeln('Initial matrix:');
       PrintMatr(a);
       Writeln;
       Writeln('Inverse matrix:');
       PrintMatr(b);
       Writeln;
       Writeln('Test. Product of initial and inverse matrix:');
       MultMatr(a,b,d);
       PrintMatr(d);
      end;
    end;
 Until w=4;
End.
Миниатюры
lr01.jpg   lr02.jpg   lr03.jpg  
Vladimir_S вне форума   Ответить с цитированием
Ads

Яндекс

Member
 
Регистрация: 31.10.2006
Сообщений: 40200
Записей в дневнике: 0
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 55070
Ответ

Опции темы
Опции просмотра

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Выкл.
HTML код Выкл.
Trackbacks are Вкл.
Pingbacks are Вкл.
Refbacks are Выкл.




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

Powered by vBulletin® Version 6.2.5.
Copyright ©2000 - 2014, Jelsoft Enterprises Ltd.