Форум программистов, компьютерный форум, киберфорум
Delphi для начинающих
Форум программистов и сисадминов Киберфорум > Форум программистов > Delphi > Delphi для начинающих
Войти
Регистрация
Восстановить пароль
Карта форума Темы раздела Блоги Сообщество Поиск Заказать работу  
 
Рейтинг 4.93/27: Рейтинг темы: голосов - 27, средняя оценка - 4.93
6 / 6 / 2
Регистрация: 23.03.2009
Сообщений: 198
1

Реализация метода вращений Якоби (где-то ошибся)

02.01.2010, 14:41. Показов 5116. Ответов 6
Метки нет (Все метки)
Author24 — интернет-сервис помощи студентам
Всем здравствуйте и с Новым Годом Переписывал из Pascal в Delphi и где-то ошибся:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99

program jacobi;
uses crt;
 
Const
  n=7;
 
var i,j,it,jt,v,s:integer;
    fi,e:real;
    A,B:array [1..n,1..n] of real;
    f: text;
 
function GetSumm: real;
var ii,jj: integer;
    ss: real;
begin
ss:=0;
for ii:=1 to n do
  for jj:=1 to n do
    if ii<>jj then ss:=ss+A[ii,jj]*A[ii,jj];
GetSumm:=ss;
end;
 
procedure GetMax(var iii,jjj: integer);
var ii,jj: integer;
    max: real;
begin
max:=0.0;
for ii:=1 to n do
  for jj:=1 to n do
    if (ii<>jj) and (abs(A[ii,jj])>max) then
    begin
      max:=abs(A[ii,jj]);
      iii:=ii;
      jjj:=jj;
    end;
end;
 
 
begin
assign(f,'po5.m');
reset(f);
 
Writeln('A = ');
for i:=1 to n do
begin
  Write('[ ');
  for j:=1 to n do
  begin
    read(f,A[i,j]);
    write(A[i,j]:4:3,' ');
  end;
  Writeln(']');
end;
 
Writeln;
Write('Eps = ');
Readln(e);
Writeln;
 
{metod Yacobi}
while GetSumm > e do
begin
  GetMax(it,jt);
  if (A[it,it]-A[jt,jt])=0 then fi:=0.785 else
  fi:=0.5*arctan(2*A[it,jt]/(A[it,it]-A[jt,jt]));
  {kammentariy-pri delenii na nol bydet beskonechnost!!!}
  for v:=1 to n do
  begin
    B[v,it]:=A[v,it]*cos(fi)+A[v,jt]*sin(fi);
    B[v,jt]:=-A[v,it]*sin(fi)+A[v,jt]*cos(fi);
  end;
  for v:=1 to n do
    for s:=1 to n do
      if (s<>it) and (s<>jt) then B[v,s]:=A[v,s];
 
  for s:=1 to n do
  begin
    A[it,s]:=B[it,s]*cos(fi)+B[jt,s]*sin(fi);
    A[jt,s]:=-B[it,s]*sin(fi)+B[jt,s]*cos(fi)
  end;
  for v:=1 to n do
    for s:=1 to n do
      if (v<>it) and (v<>jt) then A[v,s]:=B[v,s];
end;
 
for i:=1 to n do
begin
  for j:=1 to n do
    Write(abs(A[i,j]):0:4,' ');
  Writeln;
end;
Writeln;
 
for i:=1 to n do
  Writeln('l',i,' = ',A[i,i]:0:4);
 
close(f);
readln;
end.
Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74

function GetSum(Dimension:Integer; Matrix:Mas):Real;
var
  i,j:Integer;
  sum:Real;
begin
  sum:=0;
  for i:=1 to Dimension do
    for j:=1 to Dimension do
      if i<>j then
        sum:=sum+Matrix[i,j]*Matrix[i,j];
  Result:=sum;      
end;
 
procedure FindMax(var n,m:Integer; Dimension:Integer; Matrix:mas);
var
  i,j:Integer;
  max:Real;
begin
  max:=0.0;
  for i:=1 to Dimension do
    for j:=1 to Dimension do
      if (i<>j) and (Abs(Matrix[i,j])>max) then
        begin
          max:=Abs(Matrix[i,j]);
          n:=i;
          m:=j;
        end;
end;
 
procedure Calculate(var StartMatrix,FinishMatrix:Mas; Dimension:Integer);
var
  i,j,n,m,v,s:Integer;
  fi,e:Real;
  A,B:Mas;
begin
  //e:=0.00000000000001;
  e:=0.1;
  SetLength(A,Dimension+1,Dimension+1);
  SetLength(B,Dimension+1,Dimension+1);
  SetLength(FinishMatrix,Dimension+1,Dimension+1);
  for i:=1 to Dimension do
    for j:=1 to Dimension do
      A[i,j]:=StartMatrix[i,j];
  while GetSum(Dimension,A)>e do
    begin
      FindMax(n,m,Dimension,A);
      if (A[n,n]-A[m,m])=0 then
          fi:=0.785
      else fi:=0.5*arctan(2*A[n,m]/(A[n,n]-A[m,m]));
      for v:=1 to Dimension do
        begin
          B[v,n]:=A[v,n]*cos(fi)+A[v,m]*sin(fi);
          B[v,m]:=-A[v,n]*sin(fi)+A[v,m]*cos(fi);
        end;
      for v:=1 to Dimension do
        for s:=1 to Dimension do
          if (s<>n) and (s<>m) then
            B[v,s]:=A[v,s];
      for s:=1 to Dimension do
        begin
          A[n,s]:=B[n,s]*cos(fi)+B[m,s]*sin(fi);
          A[m,s]:=-B[n,s]*sin(fi)+B[m,s]*cos(fi)
        end;
      for v:=1 to n do
        for s:=1 to n do
          if (v<>n) and (v<>m) then
            A[v,s]:=B[v,s];
    end;
  for i:=1 to Dimension do
    for j:=1 to Dimension do
      FinishMatrix[i,j]:=A[i,j];
  FreeMemoryMatrix(A);
  FreeMemoryMatrix(B);
end;
Вот в delphi-исходнике где-то ошибся, считает только матрицы размерностью 2х2, а при 3х3 виснет.
В прикрепленных файлах сам метод и исходник на pascal.
З.Ы.: может у кого уже есть готовый этот метод?!
Вложения
Тип файла: rar jacobi.rar (1.0 Кб, 158 просмотров)
Тип файла: rar jacobi_teor.rar (30.2 Кб, 123 просмотров)
0
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
 02.01.2010, 14:41
Ответы с готовыми решениями:

Метод вращений Якоби с++
Используя метод Якоби найти с точностью 0.0001 все собственные значения и векторы матрицы А:...

Метод вращений Якоби
Есть код для нахождения собственных значений и векторов, а так же их их сортировка для метода...

Решение СЛАУ методом вращений (Якоби)
помогите, может у когото имеется приложение (на языке Pascal или C++), Решение СЛАУ методом...

Решение СЛАУ методом вращений (Якоби)
помогите, может у когото имеется приложение (на языке Pascal или C++), Решение СЛАУ методом...

6
Programmer
40 / 40 / 6
Регистрация: 07.04.2009
Сообщений: 187
02.01.2010, 21:09 2
Извольте выложить полный исходный код Delphi...
Если просто переписать, тогда:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86

program Project1;
 
{$APPTYPE CONSOLE}
 
uses
  SysUtils;
 
const
  n = 7;
var
  i, j, it, jt, v, s: Integer;
  fi, e: Real;
  A, B: array [1..n, 1..n] of Real;
  f: Text;
 
function GetSumm: real;
  var
    ii, jj: Integer;
    ss: Real;
  begin
    ss := 0;
    for ii := 1 to n do
      for jj := 1 to n do
        if ii <> jj then ss := ss + A[ii, jj] * A[ii, jj];
        GetSumm := ss;
  end;
procedure GetMax(var iii,jjj: integer);
  var
    ii, jj: Integer;
    max: Real;
  begin
    max:=0.0;
    for ii:=1 to n do
      for jj:=1 to n do
        if (ii<>jj) and (abs(A[ii,jj])>max) then begin
          max:=abs(A[ii,jj]);
          iii:=ii;
          jjj:=jj;
        end;
  end;
 
begin
  Assign(f,'C:\PO5.TXT');
  Reset(f);
  Writeln('A = ');
  for i:=1 to n do begin
    Write('[ ');
    for j:=1 to n do begin
      Read(f, A[i,j]);
      Write(A[i,j] :4 :3, ' ');
    end;
  Writeln(']');
  end;
  Writeln;
  Write('Eps = ');
  Readln(e);
  Writeln;
  while GetSumm > e do begin
    GetMax(it,jt);
    fi := 0.5 * Arctan(2 * A[it, jt] / (A[it, it] - A[jt, jt]));
    for v:=1 to n do begin
      B[v,it]:=A[v,it]*cos(fi)+A[v,jt]*sin(fi);
      B[v,jt]:=-A[v,it]*sin(fi)+A[v,jt]*cos(fi);
    end;
    for v:=1 to n do
      for s:=1 to n do
        if (s<>it) and (s<>jt) then B[v,s]:=A[v,s];
    for s:=1 to n do begin
      A[it,s]:=B[it,s]*cos(fi)+B[jt,s]*sin(fi);
      A[jt,s]:=-B[it,s]*sin(fi)+B[jt,s]*cos(fi)
    end;
    for v:=1 to n do
      for s:=1 to n do
        if (v<>it) and (v<>jt) then A[v,s]:=B[v,s];
  end;
  for i:=1 to n do begin
    for j:=1 to n do
      Write(abs(A[i,j]):0:4,' ');
    Writeln;
  end;
  Writeln;
  for i:=1 to n do
    Writeln('l',i,' = ',A[i,i]:0:4);
  Close(f);
  ReadLn;
end.
Но видно вы хотите модифицировать код...
1
6 / 6 / 2
Регистрация: 23.03.2009
Сообщений: 198
04.01.2010, 15:28  [ТС] 3
Я создал новый Unit для этого метода
Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

unit UnitJacobi;
 
interface
 
type
  Mas=array of array of Double;
 
procedure Jacobi(var Matrix:Mas; Dimension:Integer; E:Real);
 
implementation
 
function GetSum(Dimension:Integer; Matrix:Mas):Real;
var
  i,j:Integer;
  sum:Real;
begin
  sum:=0;
  for i:=1 to Dimension do
    for j:=1 to Dimension do
      if i<>j then
        sum:=sum+Matrix[i,j]*Matrix[i,j];
  Result:=sum;      
end;
 
procedure FindMax(var n,m:Integer; Dimension:Integer; Matrix:mas);
var
  i,j:Integer;
  max:Real;
begin
  max:=0.0;
  for i:=1 to Dimension do
    for j:=1 to Dimension do
      if (i<>j) and (Abs(Matrix[i,j])>max) then
        begin
          max:=Abs(Matrix[i,j]);
          n:=i;
          m:=j;
        end;
end;
 
procedure Jacobi(var Matrix:Mas; Dimension:Integer; E:Real);
var
  i,j,n,m,v,s:Integer;
  fi:Real;
  B:Mas;
begin
  SetLength(B,Dimension+1,Dimension+1);
  while GetSum(Dimension,Matrix)>E do
    begin
      FindMax(n,m,Dimension,Matrix);
      if (Matrix[n,n]-Matrix[m,m])=0 then
          fi:=0.785
      else fi:=0.5*arctan(2*Matrix[n,m]/(Matrix[n,n]-Matrix[m,m]));
      for v:=1 to Dimension do
        begin
          B[v,n]:=Matrix[v,n]*cos(fi)+Matrix[v,m]*sin(fi);
          B[v,m]:=-Matrix[v,n]*sin(fi)+Matrix[v,m]*cos(fi);
        end;
      for v:=1 to Dimension do
        for s:=1 to Dimension do
          if (s<>n) and (s<>m) then
            B[v,s]:=Matrix[v,s];
      for s:=1 to Dimension do
        begin
          Matrix[n,s]:=B[n,s]*cos(fi)+B[m,s]*sin(fi);
          Matrix[m,s]:=-B[n,s]*sin(fi)+B[m,s]*cos(fi)
        end;
      for v:=1 to n do
        for s:=1 to n do
          if (v<>n) and (v<>m) then
            Matrix[v,s]:=B[v,s];
    end;
  FreeMemory(B);
end;  
 
end.
но дело в том что он не считает теперь и я не могу понять где ошибка
0
Programmer
40 / 40 / 6
Регистрация: 07.04.2009
Сообщений: 187
04.01.2010, 22:51 4
Вы определили размерность динамического массива Matrix?
0
6 / 6 / 2
Регистрация: 23.03.2009
Сообщений: 198
05.01.2010, 10:17  [ТС] 5
да. вот вызывающая процедура
Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

procedure TMainForm.ButtonRunTaskClick(Sender: TObject);  //запуск расчётов
var
  Matrix:Mas;
  E:Real;
  P:Double;
begin
  SetLength(Matrix,Dimension+1,Dimension+1);
  if Input(Matrix,E)=True then  //ввод матрицы  точности
    Input(Matrix,E)
  else Application.MessageBox('Неправильно введён один или несколько коэффициентов напряжений или точность вычислений! Проверьте ввод!', 
    'Ошибка!', MB_OK + MB_ICONWARNING);
  Jacobi(Matrix,Dimension,E);
  P:=Sqrt(Sqr(Matrix[1,1])+Sqr(Matrix[2,2])+Sqr(Matrix[3,3]));  
  OutputResults(Matrix,P);  //вывод на экран результатов
  FreeMemory(Matrix);
end;
дело в том что при запуске расчётов она просто виснет и всё
0
gamezeldol
03.05.2011, 16:36 6
Здраствуйте! А вы не могли прикрепить файл Delphi с данной программой... уже реализованной. Спасибо большое.
6 / 6 / 2
Регистрация: 23.03.2009
Сообщений: 198
03.05.2011, 17:09  [ТС] 7
gamezeldol, я использовал данный метод для решения определённой задачи, а конкретно расчёт полного напряжения на основе матрицы тензора напряжений. Ниже представлен код модуля для данного метода:
Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96

unit UnitJacobi;
 
interface
 
type
  Mas=array of array of Double;
 
procedure Jacobi(var Matrix:Mas; Dimension:Integer; E:Real);
procedure FreeMemoryMatrix(var Matrix:Mas; Dimension:Integer);
function IsSimmetrical(Matrix:Mas; Dimension:Integer):Boolean;
 
implementation
 
function IsSimmetrical(Matrix:Mas; Dimension:Integer):Boolean;  //проверка матрицы на симметричность
var
  i,j:Integer;
begin
  Result:=True;
  for i:=1 to Dimension do
    for j:=1 to Dimension do
      if Matrix[i,j]<>Matrix[j,i] then
        Result:=False;
end;
 
procedure FreeMemoryMatrix(var Matrix:Mas; Dimension:Integer);  //освобождение выделенной памяти
var
  i:Integer;
begin
  Matrix:=nil;
end;
 
function GetSum(Dimension:Integer; Matrix:Mas):Real;  //вычисление погрешности
var
  i,j:Integer;
  sum:Real;
begin
  sum:=0;
  for i:=1 to Dimension do
    for j:=1 to Dimension do
      if i<>j then
        sum:=sum+Matrix[i,j]*Matrix[i,j];
  Result:=sum;      
end;
 
procedure FindMax(var n,m:Integer; Dimension:Integer; Matrix:mas);  //вычисление максимального по абсолютной величине внедиагонального элемента и его индексов 
var
  i,j:Integer;
  max:Real;
begin
  max:=0.0;
  for i:=1 to Dimension do
    for j:=1 to Dimension do
      if (i<>j) and (Abs(Matrix[i,j])>max) then
        begin
          max:=Abs(Matrix[i,j]);
          n:=i;
          m:=j;
        end;
end;
 
procedure Jacobi(var Matrix:Mas; Dimension:Integer; E:Real);  //нахождение сосбственных значений методом вращений якоби
var
  i,j,n,m,v,s:Integer;
  fi:Real;
  B:Mas;  //промежуточная матрица
begin
  SetLength(B,Dimension+1,Dimension+1);
  while GetSum(Dimension,Matrix)>E do
    begin
      FindMax(n,m,Dimension,Matrix);
      if (Matrix[n,n]-Matrix[m,m])=0 then
        fi:=(Sqrt(2)/2) else
      fi:=0.5*arctan(2*Matrix[n,m]/(Matrix[n,n]-Matrix[m,m]));  //вычисление угла поворота
      for v:=1 to Dimension do
        begin
          B[v,n]:=Matrix[v,n]*cos(fi)+Matrix[v,m]*sin(fi);
          B[v,m]:=-Matrix[v,n]*sin(fi)+Matrix[v,m]*cos(fi);
        end;
      for v:=1 to Dimension do
        for s:=1 to Dimension do
          if (s<>n) and (s<>m) then
            B[v,s]:=Matrix[v,s];
      for s:=1 to Dimension do
        begin
          Matrix[n,s]:=B[n,s]*cos(fi)+B[m,s]*sin(fi);
          Matrix[m,s]:=-B[n,s]*sin(fi)+B[m,s]*cos(fi)
        end;
      for v:=1 to Dimension do
        for s:=1 to Dimension do
          if (v<>n) and (v<>m) then
            Matrix[v,s]:=B[v,s];
    end;
  FreeMemoryMatrix(B,Dimension);
end;
 
end.
0
03.05.2011, 17:09
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
 03.05.2011, 17:09
Помогаю со студенческими работами здесь

Метод вращений Якоби для решения СЛАУ
Привет! Ребят, помогите пожжжжжжалуйста!!! Написал метод вращений, но X находятся неправильно....

Где лежит реализация метода GetResourceFromDefault?
// auto-generated internal extern static String...

Распараллеливание метода Якоби
Помогите пожалуйста распараллелить функцию Якоби для решения СЛАУ. Я вообще ничего не понимаю в...

Сходимость метода Якоби и Гаусса-Зейделя
(Задача) Показать, что существует система уравнений третьего порядка, для которой метод Якоби...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
7
Ответ Создать тему
КиберФорум - форум программистов, компьютерный форум, программирование
Поддержать - Реклама - Обратная связь
Powered by vBulletin
Copyright ©2000 - 2024, CyberForum.ru