Задача: дана система n-уравнений с n-неизвестными. Написать программу решения системы методом Гаусса, применяя только одномерные массивы.
Алгоритм:
1. С файла считывается число уравнений и расширенная матрица системы.
2. С помощью метода Гаусса находим корни.
3. Вычисленные корни записываем в файл, где находиться расширенная матрица системы.
program prak2;
{Программа для решения системы линейных алгебраических уравнений с помощью
метода Гаусса. Вычесления осуществляются в одномерных массивах.
Версия 1.0
22.03.2013
jester}
uses crt;
const n=20;
type Tmatrix=array [0..n*n-1] of real;
Tfree_member=array [0..n-1] of real;
var number:byte;
matrix:Tmatrix;
x,free_member:Tfree_member;
path:string;
//===========================
function Read_matrix_with_file(path:string; var number:byte):boolean;
var i,j,number_of_unknowns,number_of_equations:byte;
outcome:integer;
f:text;
begin
assign(f,path); {$I-} reset(f); {$I+} outcome:=IOResult; //проверка существования файла
if outcome<>0 then
begin
writeln('Неверный путь к файлу или такого файла не существует');
Read_matrix_with_file:=false;
exit;
end;
readln(f,number);
if number>n then
begin
writeln('Неправильный ввод данных!');
Read_matrix_with_file:=false;
exit;
end;
for i:=0 to number-1 do //считывание матрицы с файла
begin
for j:=0 to number-1 do read(f,matrix[i*number+j]);
readln(f,free_member[i]);
end;
close(f);
Read_matrix_with_file:=true;
end;
//===========================
procedure Transposition(var matrix:Tmatrix; var free_member:Tfree_member; i,number:byte);
var buf:real;
buf_index,j:byte;
begin
if (i=number-1)and(matrix[i*number+i]=0)and(matrix[i*number+i]<>free_member[i]) then
begin
writeln('Система несовместна!');
exit;
end;
buf_index:=i+1;
while (matrix[i*number+i]=0)and(buf_index<=number)do
begin
for j:=0 to number-1 do //перестановка строк местами
begin
buf:=matrix[i*number+j]; //перестановка строк основной матрицы
matrix[i*number+j]:=matrix[buf_index*number+j];
matrix[buf_index*number+j]:=buf;
end;
buf:=free_member[i]; //перестановка свобных членов
free_member[i]:=free_member[buf_index];
free_member[buf_index]:=buf;
inc(buf_index);
end;
end;
//===========================
function Gauss(number:byte):boolean;
var i,j,t:byte;
buf_accum,buf:real;
begin
for i:=0 to number-1 do //прямой ход
begin
//так как на ноль делить нельзя проверяем элемент
if matrix[i*number+i]=0 then Transposition(matrix,free_member,i,number);
for j:=i+1 to number-1 do
begin
buf:=matrix[j*number+i]/matrix[i*number+i];
for t:=i to number-1 do matrix[j*number+t]:=matrix[j*number+t]-buf*matrix[i*number+t];
free_member[j]:=free_member[j]-buf*free_member[i];
end;
end;
//в ходе решения матрица может привестись к трапецивидной форме
//тогда она будет иметь безконечное число решений
if (matrix[i*number+i]=0)and(matrix[i*number+i]=free_member[i])then
begin
writeln('Система имеет безконечное число решений');
Gauss:=false;
exit;
end;
for i:=number-1 downto 0 do //обратный ход
begin
buf_accum:=0;
for j:=i+1 to number-1 do
begin
buf:=matrix[i*number+j]*x[j];
buf_accum:=buf_accum+buf;
end;
x[i]:=(free_member[i]-buf_accum)/matrix[i*number+i];
end;
Gauss:=true; writeln('Решение системы алгебраических уравнений:');
for i:=0 to number-1 do writeln('x[',i,'] = ',x[i]:4:4); readkey;
end;
//===========================
procedure Write_answer_in_file(number:byte; path:string);
var i:byte;
s:string;
f:text;
begin
assign(f,path); append(f); writeln(f,' '); writeln(f,'Roots of equations:');
for i:=0 to number-1 do
begin
write(f,x[i]:4:4);
write(f,' ');
end;
close(f);
end;
//===========================
begin
clrscr;
writeln('В файле в первой строке должно содержаться число количества уравнений,');
writeln('далее с новой строки записана расширенная матрица системы (каждый элемент');
writeln('через пробел). Введите путь к файлу и его название с расширением .txt:');
readln(path);
if Read_matrix_with_file(path,number) then
begin
if Gauss(number) then Write_answer_in_file(number,path) else
begin
readkey;
exit;
end;
end
else
begin
readkey;
exit
end
end.
№ 1 | Автор: jester |
2013-03-23, 18:43 | Изменено: jester - Сб, 2013-03-23, 19:31
|
Репутация: [ + 3 ]
|
|
|
№ 1 | Автор: jester |
2013-03-23, 18:43 | Изменено: jester - Сб, 2013-03-23, 19:31
|
Репутация: [ + 3 ]
|
|
|
|
