3.4 Массивы
____________________________________________________________________
goto L5; end;
x[i]:= (b[i] + S) / a[i, i]; if not(i = 1) then
begin
i:= i - 1; goto L4;
end;
for i:= 1 to n do
writeln('x', i, '= ', x[i]:0:4); writeln(UTF8ToConsole('Нажмите любую клавишу')); readkey;
end.
3.4.1.2. Вариант 2 – без goto
program Gauss_console_app; {$mode objfpc}{$H+}
uses
CRT, FileUtil; var
a:array[1..3, 1..3] of real;
b:array[1..3] of real;
x: array[1..3] of real; i, j, k, p, n: integer; m, S, t: real;
begin
{Ввод коэффициентов расширенной матрицы} n:= 3;
for i:=1 to n do begin
for j:=1 to n do begin
writeln(UTF8ToConsole('Введите a'), i, j); readln (a[i, j]);
end;
writeln(UTF8ToConsole('Введите b'), i); readln(b[i]);
end;
{Основная часть программы} k:= 1;
206
Глава 3 Более сложные элементы языка
____________________________________________________________________
while true do begin
i:= k + 1;
if (a[k, k] = 0) then begin
{перестановка уравнений}
p:= k; // в алгоритме используется буква l, но она похожа на 1 // Поэтому используем идентификатор p
while true do begin
if abs(a[i, k]) > abs(a[p, k]) then p:= i; if i = n then break;
i:= i + 1; continue;
end;
if p= k then i:= k + 1 else
begin j:= k;
while true do begin
t:= a[k, j];
a[k, j]:= a[p, j]; a[p, j]:= t;
if j = n then break; j:= j + 1; continue;
end;
t:= b[k]; b[k]:= b[p]; b[p]:= t;
end;
end; // конец блока перестановки уравнений while true do
begin
m:=a[i, k] / a[k, k]; a[i, k]:= 0;
j:= k + 1; while true do begin
a[i, j]:= a[i, j] - m * a[k, j]; if j = n then break;
j:= j + 1;
207
3.4 Массивы
____________________________________________________________________
continue;
end;
b[i]:= b[i] - m * b[k]; if i = n then break; i:= i + 1;
continue;
end;
if k= n - 1 then break; k:= k + 1;
continue;
end;
{Проверка существования решения} if a[n, n] <> 0 then begin
x[n]:= b[n] / a[n, n]; i:= n - 1;
while true do begin
j:= i + 1; S:= 0;
while true do begin
S:= S - a[i, j] * x[j]; if j = n then break; j:= j + 1;
continue;
end;
x[i]:= (b[i] + S) / a[i, i]; if i = 1 then break;
i:= i - 1; continue;
end;
for i:= 1 to n do
writeln('x', i, '= ', x[i]:0:4); end
else
if b[n] = 0 then writeln(UTF8ToConsole('Система уравнений' +
' не имеет решения.'))
else
writeln(UTF8ToConsole('Система уравнений'+ ' имеет бесконечное множество решений.'));
writeln(UTF8ToConsole('Нажмите любую клавишу'));
208
Глава 3 Более сложные элементы языка
____________________________________________________________________
readkey;
end.
3.4.1.3. Вариант 3 – наилучшая реализация
program Gauss_console_app; {$mode objfpc}{$H+}
uses
CRT, FileUtil; var
a:array of array of real; {матрица коэффициентов системы, двумерный динамический массив}
vector: array of real; {преобразованный одномерный динамический массив}
b:array of real;
x: array of real; i, j, k, n: integer;
procedure gauss(var vector: array of real; var b: array of real;
var x: array of real; var n: integer);
var
a: array of array of real; {матрица коэффициентов системы, двумерный динамический массив}
i, j, k, p, r: integer; m, s, t: real;
begin
SetLength(a, n, n); // установка фактического размера массива {Преобразование одномерного массива в двумерный}
k:=1;
for i:=0 to n-1 do for j:=0 to n-1 do begin
a[i,j]:= vector[k]; k:=k+1;
end;
for k:=0 to n-2 do begin
for i:=k+1 to n-1 do begin
if (a[k,k]=0) then begin
{перестановка уравнений}
209
3.4 Массивы
____________________________________________________________________
p:=k; // в алгоритме используется буква l, но она похожа на 1 // Поэтому используем идентификатор p
for r:=i to n-1 do begin
if abs(a[r,k]) > abs(a[p,k]) then p:=r; end;
if p<>k then begin
for j:= k to n-1 do begin
t:=a[k,j];
a[k,j]:=a[p,j];
a[p,j]:=t;
end;
t:=b[k];
b[k]:=b[p];
b[p]:=t;
end;
end; // конец блока перестановки уравнений m:=a[i,k]/a[k,k];
a[i,k]:=0;
for j:=k+1 to n-1 do begin
a[i,j]:=a[i,j]-m*a[k,j]; end;
b[i]:= b[i]-m*b[k]; end;
end;
{Проверка существования решения} if a[n-1,n-1] <> 0 then begin
x[n-1]:=b[n-1]/a[n-1,n-1]; for i:=n-2 downto 0 do begin
s:=0;
for j:=i+1 to n-1 do begin
s:=s-a[i,j]*x[j]; end;
x[i]:=(b[i] + s)/a[i,i]; end;
writeln(''); writeln(UTF8ToConsole('Решение:'));
210