Форум программистов, компьютерный форум, киберфорум
Pascal ABC
Форум программистов и сисадминов Киберфорум > Форум программистов > Pascal (Паскаль) > Pascal ABC
Войти
Регистрация
Восстановить пароль
Блоги Сообщество Поиск Заказать работу  
 
Рейтинг 4.60/15: Рейтинг темы: голосов - 15, средняя оценка - 4.60
0 / 0 / 0
Регистрация: 21.06.2010
Сообщений: 4

Процедуры и функции. Решение матрицы методом Гаусса

21.06.2010, 20:16. Показов 3137. Ответов 5
Метки нет (Все метки)
Студворк — интернет-сервис помощи студентам
Здравствуйте уважаемые господа программисты.Очень нужна ваша помощь.
В общем вот программа которая, решает матрицы методом гаусса,но в ней не хватает проверки корней,как я понял проверка выполняется так:полученные корни умножаются на строки в матрице,и должен получится столбец под названием vector(b).За ранее благодарю.



Code
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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134

Uses CRT;
 
Const
     maxn = 10;
 
Type
    Data = Real;
    Matrix = Array[1..maxn, 1..maxn] of Data;
    Vector = Array[1..maxn] of Data;
 
Procedure ReadSystem(n: Integer; var a: Matrix; var b: Vector);
Var
   i, j, r: Integer;
Begin
     r := WhereY;
     GotoXY(2, r);
     Write('A');
     For i := 1 to n do begin
         GotoXY(i*6+2, r);
         Write(i);
         GotoXY(1, r+i+1);
         Write(i:2);
     end;
     GotoXY((n+1)*6+2, r);
     Write('b');
     For i := 1 to n do begin
         For j := 1 to n do begin
             GotoXY(j * 6 + 2, r + i + 1);
             Read(a[i, j]);
         end;
         GotoXY((n + 1) * 6 + 2, r + i + 1);
         Read(b[i]);
     end;
 
End;
 
 
Procedure WriteX(n :Integer; x: Vector);
Var
   i: Integer;
Begin
     For i := 1 to n do
         Writeln('x', i, ' = ', x[i]);
End;
 
 
Function Gauss(n: Integer; a: Matrix; b: Vector; var x:Vector): Boolean;
Var
   i, j, k, l: Integer;
   q, m, t: Data;
Begin
 
     For k := 1 to n - 1 do begin
 
 
         l := 0;
         m := 0;
         For i := k to n do
             If Abs(a[i, k]) > m then begin
                m := Abs(a[i, k]);
                l := i;
             end;
 
 
         If l = 0 then begin
            Gauss := false;
            Exit;
         end;
 
 
         If l <> k then begin
            For j := 1 to n do begin
                t := a[k, j];
                a[k, j] := a[l, j];
                a[l, j] := t;
            end;
            t := b[k];
            b[k] := b[l];
            b[l] := t;
         end;
 
 
         For i := k + 1 to n do begin
             q := a[i, k] / a[k, k];
             For j := 1 to n do
                 If j = k then
                    a[i, j] := 0
                 else
                      a[i, j] := a[i, j] - q * a[k, j];
                 b[i] := b[i] - q * b[k];
             end;
 
     end;
 
 
     x[n]:= b[i] / a[n, n];
     For i := n - 1 downto 1 do begin
         t := 0;
         For j := 1 to n-i do
             t := t + a[i, i + j] * x[i + j];
         x[i] := (1 / a[i, i]) * (b[i] - t);
     end;
 
     Gauss := true;
End;
 
Var
    n, i: Integer;
    a: Matrix ;
    b, x: Vector;
Begin
      ClrScr;
      Writeln('reshenie');
      Writeln;
 
      Writeln('razshirennaia matrica');
      Repeat
             Write('n');
             Read(n);
      Until (n > 0) and (n <= maxn);
      Writeln;
 
      Writeln('3:5');
      ReadSystem(n, a, b);
      Writeln;
 
      If Gauss(n, a, b, x) then begin
         Writeln('x=');
         WriteX(n, x);
      end
      else
          Writeln('reshenii net');
      Writeln;
End.
0
IT_Exp
Эксперт
34794 / 4073 / 2104
Регистрация: 17.06.2006
Сообщений: 32,602
Блог
 21.06.2010, 20:16
Ответы с готовыми решениями:

Решение матрицы методом Гаусса
Мне нужно написать программу для решения матрицы с помощью метода Гаусса. Программу написала. Ответы получились боле-менее нормальные....

Решение трехдиагональной матрицы методом Гаусса
Получил такое вот задание: Записать макрос для решения методом Гаусса СЛАУ с трѐхдиагональной матрицей размером (nxn) с...

Решение матрицы методом Гаусса в MS Excel
Не спешите предлагать &quot;похожие&quot; темы, пожалуйста! Возникла немного нестандартная ситуация - переменных 5, а поэтому действия совершаются...

5
Почетный модератор
 Аватар для Puporev
64314 / 47610 / 32743
Регистрация: 18.05.2008
Сообщений: 115,168
21.06.2010, 20:46
zimba, Я написал Вам проверку, но Ваша программа неправильно находит корни.
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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154

Uses CRT;
 
Const
     maxn = 10;
 
Type
    Data = Real;
    Matrix = Array[1..maxn, 1..maxn] of Data;
    Vector = Array[1..maxn] of Data;
 
Procedure ReadSystem(n: Integer; var a: Matrix; var b: Vector);
Var
   i, j, r: Integer;
Begin
     r := WhereY;
     GotoXY(2, r);
     Write('A');
     For i := 1 to n do begin
         GotoXY(i*6+2, r);
         Write(i);
         GotoXY(1, r+i+1);
         Write(i:2);
     end;
     GotoXY((n+1)*6+2, r);
     Write('b');
     For i := 1 to n do begin
         For j := 1 to n do begin
             GotoXY(j * 6 + 2, r + i + 1);
             Readln(a[i, j]);
         end;
         GotoXY((n + 1) * 6 + 2, r + i + 1);
         Readln(b[i]);
     end;
 
End;
 
 
Procedure WriteX(n :Integer; var x: Vector);
Var
   i: Integer;
Begin
     For i := 1 to n do
         Writeln('x', i, ' = ', x[i]:0:3);
End;
 
 
Function Gauss(n: Integer; a: Matrix; b: Vector; var x:Vector): Boolean;
Var
   i, j, k, l: Integer;
   q, m, t: Data;
Begin
 
     For k := 1 to n - 1 do begin
 
 
         l := 0;
         m := 0;
         For i := k to n do
             If Abs(a[i, k]) > m then begin
                m := Abs(a[i, k]);
                l := i;
             end;
 
 
         If l = 0 then begin
            Gauss := false;
            Exit;
         end;
 
 
         If l <> k then begin
            For j := 1 to n do begin
                t := a[k, j];
                a[k, j] := a[l, j];
                a[l, j] := t;
            end;
            t := b[k];
            b[k] := b[l];
            b[l] := t;
         end;
 
 
         For i := k + 1 to n do begin
             q := a[i, k] / a[k, k];
             For j := 1 to n do
                 If j = k then
                    a[i, j] := 0
                 else
                      a[i, j] := a[i, j] - q * a[k, j];
                 b[i] := b[i] - q * b[k];
             end;
 
     end;
 
 
     x[n]:= b[i] / a[n, n];
     For i := n - 1 downto 1 do begin
         t := 0;
         For j := 1 to n-i do
             t := t + a[i, i + j] * x[i + j];
         x[i] := (1 / a[i, i]) * (b[i] - t);
     end;
 
     Gauss := true;
End;
procedure Proverka(n: Integer; a: Matrix; b,x: Vector; var p:Vector);
var i,j:byte;
begin
for i:=1 to n do
 begin
  p[i]:=0;
  for j:=1 to n do
  p[i]:=p[i]+a[i,j]*x[i];
 end;
writeln('Proverka:');
writeln('ishod.  vychs.');
for i:=1 to n do
 begin
  write(b[i]:7:2);
  writeln(p[i]:7:2);
 end;
end;
 
Var
    n, i: Integer;
    a: Matrix ;
    b, x, p: Vector;
Begin
      ClrScr;
      Writeln('reshenie');
      Writeln;
 
      Writeln('razshirennaia matrica');
      Repeat
             Write('n');
             Readln(n);
      Until (n > 0) and (n <= maxn);
      Writeln;
 
      Writeln('3:5');
      ReadSystem(n, a, b);
      Writeln;
 
      If Gauss(n, a, b, x) then begin
         Writeln('x=');
         WriteX(n, x);
         writeln;
         Proverka(n,a,b,x,p);
      end
      else
          Writeln('reshenii net');
 
      readln;
End.
1
0 / 0 / 0
Регистрация: 21.06.2010
Сообщений: 4
21.06.2010, 20:49  [ТС]
Возможно найти ошибку ?
0
Почетный модератор
 Аватар для Puporev
64314 / 47610 / 32743
Регистрация: 18.05.2008
Сообщений: 115,168
21.06.2010, 21:30
Я вообще не понимаю что у Вас написано.

Добавлено через 3 минуты
К тому же настолько безобразно оформлен код, что вообще читать невозможно.
0
0 / 0 / 0
Регистрация: 21.06.2010
Сообщений: 4
21.06.2010, 21:47  [ТС]
Не обременит написать подобную программу с проверкой ? т.е. решение матриц методом гаусса с помощью процедуры и функции
0
Почетный модератор
 Аватар для Puporev
64314 / 47610 / 32743
Регистрация: 18.05.2008
Сообщений: 115,168
21.06.2010, 22:41
Все у Вас правильно, это я начудил, перепутал i и j.
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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145

Uses CRT;
 
Const
     maxn = 10;
 
Type
    Data = Real;
    Matrix = Array[1..maxn, 1..maxn] of Data;
    Vector = Array[1..maxn] of Data;
 
Procedure ReadSystem(n: Integer; var a: Matrix; var b: Vector);
Var
   i, j, r: Integer;
Begin
     r := WhereY;
     GotoXY(2, r);
     Write('A');
     For i := 1 to n do begin
         GotoXY(i*6+2, r);
         Write(i);
         GotoXY(1, r+i+1);
         Write(i:2);
     end;
     GotoXY((n+1)*6+2, r);
     Write('b');
     For i := 1 to n do begin
         For j := 1 to n do begin
             GotoXY(j * 6 + 2, r + i + 1);
             Readln(a[i, j]);
         end;
         GotoXY((n + 1) * 6 + 2, r + i + 1);
         Readln(b[i]);
     end;
 
End;
 
 
Procedure WriteX(n :Integer; var x: Vector);
Var
   i: Integer;
Begin
     For i := 1 to n do
         Writeln('x', i, ' = ', x[i]:0:3);
End;
 
 
Function Gauss(n: Integer; a: Matrix; b: Vector; var x:Vector): Boolean;
Var i, j, k, l: Integer;
    q, m, t: Data;
Begin
For k := 1 to n - 1 do
 begin
  l := 0;
  m := 0;
  For i := k to n do
  If Abs(a[i, k]) > m then
   begin
    m := Abs(a[i, k]);
    l := i;
   end;
  If l = 0 then
   begin
     Gauss := false;
     Exit;
   end;
  If l <> k then
   begin
    For j := 1 to n do
     begin
      t := a[k, j];
      a[k, j] := a[l, j];
      a[l, j] := t;
     end;
    t := b[k];
    b[k] := b[l];
    b[l] := t;
   end;
  For i := k + 1 to n do
   begin
    q := a[i, k] / a[k, k];
    For j := 1 to n do
    If j = k then a[i, j] := 0
    else a[i, j] := a[i, j] - q * a[k, j];
    b[i] := b[i] - q * b[k];
   end;
 end;
x[i]:= b[i] / a[i, i];
For i := n - 1 downto 1 do
 begin
  t := 0;
  For j := 1 to n-i do
  t := t + a[i, i + j] * x[i + j];
  x[i] := (1 / a[i, i]) * (b[i] - t);
 end;
 Gauss := true;
End;
procedure Proverka(n: Integer; a: Matrix; x: Vector; var b,p:Vector);
var i,j:byte;
begin
for i:=1 to n do
 begin
  p[i]:=0;
  for j:=1 to n do
  p[i]:=p[i]+a[i,j]*x[j];
 end;
writeln('Proverka:');
writeln('ishod.  vychs.');
for i:=1 to n do
 begin
  write(b[i]:7:2);
  writeln(p[i]:7:2);
 end;
end;
 
Var
    n, i: Integer;
    a: Matrix ;
    b, x, p: Vector;
Begin
      ClrScr;
      Writeln('reshenie');
      Writeln;
 
      Writeln('razshirennaia matrica');
      Repeat
             Write('n');
             Readln(n);
      Until (n > 0) and (n <= maxn);
      Writeln;
 
      Writeln('3:5');
      ReadSystem(n, a, b);
      Writeln;
 
      If Gauss(n, a, b, x) then begin
         Writeln('x=');
         WriteX(n, x);
         writeln;
         Proverka(n,a,x,b,p);
      end
      else
          Writeln('reshenii net');
 
      readln;
End.
0
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
BasicMan
Эксперт
29316 / 5623 / 2384
Регистрация: 17.02.2009
Сообщений: 30,364
Блог
 21.06.2010, 22:41
Помогаю со студенческими работами здесь

MS Excel. Решение матрицы методом Гаусса
Количество переменных не совпадает с количеством строк, поэтому обычным методом не решается :( Помогите, пожалуйста, с методом...

Решение СЛАУ методом гаусса с помощью матрицы вращения
помогите пожалуйста!!!!!!!!!напишите кто нибудь программу матод гаусса решения слу с помощью матрицы вращения на СИ

Решение СЛАУ методом Гаусса - добавить вывод треугольного вида матрицы
Есть программа, которая решает систему линейных уравнений методом Гаусса. Нужно добавить вывод треугольного вида матрицы. Заранее...

Численное решение СЛАУ методом Гаусса с организацией хранения матрицы в виде одномерного массива
Помогите кому не сложно.

Решение системы линейных уравнений методом Гаусса и Жордана-Гаусса
Помогите пожалуйста начала работать сначала работать с методом Гаусса, но в Unit2 Delphi ругается на type arys=array of real; не могу...


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

Или воспользуйтесь поиском по форуму:
6
Ответ Создать тему
Новые блоги и статьи
http://iceja.net/ математические сервисы
iceja 20.01.2026
Обновила свой сайт http:/ / iceja. net/ , приделала Fast Fourier Transform экстраполяцию сигналов. Однако предсказывает далеко не каждый сигнал (см ограничения http:/ / iceja. net/ fourier/ docs ). Также. . .
http://iceja.net/ сервер решения полиномов
iceja 18.01.2026
Выкатила http:/ / iceja. net/ сервер решения полиномов (находит действительные корни полиномов методом Штурма). На сайте документация по API, но скажу прямо VPS слабенький и 200 000 полиномов. . .
Расчёт переходных процессов в цепи постоянного тока
igorrr37 16.01.2026
/ * Дана цепь постоянного тока с R, L, C, k(ключ), U, E, J. Программа составляет систему уравнений по 1 и 2 законам Кирхгофа, решает её и находит переходные токи и напряжения на элементах схемы. . . .
Восстановить юзерскрипты Greasemonkey из бэкапа браузера
damix 15.01.2026
Если восстановить из бэкапа профиль Firefox после переустановки винды, то список юзерскриптов в Greasemonkey будет пустым. Но восстановить их можно так. Для этого понадобится консольная утилита. . .
Сукцессия микоризы: основная теория в виде двух уравнений.
anaschu 11.01.2026
https:/ / rutube. ru/ video/ 7a537f578d808e67a3c6fd818a44a5c4/
WordPad для Windows 11
Jel 10.01.2026
WordPad для Windows 11 — это приложение, которое восстанавливает классический текстовый редактор WordPad в операционной системе Windows 11. После того как Microsoft исключила WordPad из. . .
Classic Notepad for Windows 11
Jel 10.01.2026
Old Classic Notepad for Windows 11 Приложение для Windows 11, позволяющее пользователям вернуть классическую версию текстового редактора «Блокнот» из Windows 10. Программа предоставляет более. . .
Почему дизайн решает?
Neotwalker 09.01.2026
В современном мире, где конкуренция за внимание потребителя достигла пика, дизайн становится мощным инструментом для успеха бренда. Это не просто красивый внешний вид продукта или сайта — это. . .
КиберФорум - форум программистов, компьютерный форум, программирование
Поддержать - Реклама - Условия использования - Обратная связь
Powered by vBulletin
Copyright ©2000 - 2026, CyberForum.ru