uses Dos,Crt;
const N=10;
MainTextColor=15;
DiagonColor=2;
OutPutI=3;
OutPutJ=7;
ScaleI=10;
ScaleJ=3;
type TMatrix=array[1..N,1..N] of real;
TVec=array[1..N] of real;
{Процедура решает задачу ввода порядка исходной матрицы}
procedure Read_Range(var Range:integer);
begin
writeln('Блок ввода данных');
write('Введите порядок исходной матрицы A_Matrix=');
read(Range);
end;
{Процедура считывания исходной матрицы}
procedure InputMatrix(var AMatrix:TMatrix;Range:integer);
var i,j,cols,rows:integer;
begin
Rows:=Range;
Cols:=Range;
writeln('Введите исходную матрицу');
for i:=1 to cols do
for j:=1 to rows do
begin
GoToXY(OutPutI+ScaleI*i,OutPutJ+ScaleJ*j);
read(AMatrix[i,j]);
end;
end;
procedure PlotSameMatrix(var CEquival:TMatrix;AMatrix:TMatrix;Range:integer);
var i,j:integer;
begin
for i:=1 to Range do
for j:=1 to Range do
begin
CEquival[i,j]:=AMatrix[i,j];
end;
ClrScr;
end;
{Процедуры форматированного вывода/печати матриц AMatrix}
procedure Coord_AMatrix(var AMatrix:TMatrix;Range:integer);
var i,j,k:integer;
begin
for i:=1 to Range do
for j:=1 to range do
begin
GoToXY(OutPutI+ScaleI*i,OutPutJ+ScaleJ*j);
if i=j then TextColor(DiagonColor) else TextColor(MainTextColor);
write(AMatrix[i,j]:4:2);
end;
end;
{==========================================================================}
procedure Coord_VMatrix(var VMatrix:TMatrix;Range:integer);
var i,j:integer;
begin
for i:=1 to Range do
for j:=1 to range do
begin
GoToXY(OutPutI+ScaleI*i,OutPutJ+ScaleJ*j);
write(VMatrix[i,j]:4:2);
end;
end;
{Суммирование диагональных элементов (след матрицы)}
function Trace(Range:integer;AMatrix:TMatrix):real;
var i,N:integer;
diag_sum:real;
begin
Diag_sum:=0;
Trace:=0;
N:=Range;
for i:=1 to N do
begin
Diag_sum:=diag_sum+AMatrix[i,i];
Trace:=Diag_sum;
end;
end;
{Промежуточная матрица V}
procedure VInter(var VMatrix:TMatrix;BMatrix,AMatrix:TMatrix;Range:integer;
Pk:real);
var i,j,m,i0:integer;
begin
ClrScr;
TextColor(MainTextColor);
writeln( 'Промежуточная матрица Bn');
readln;
for i:=1 to Range do
for j:=1 to Range do
begin
if i=j then BMatrix[i,j]:=AMatrix[i,j]-Pk
else BMatrix[i,j]:=AMatrix[i,j];
VMatrix[i,j]:=BMatrix[i,j];
Coord_VMatrix(VMatrix,Range);
end;
readln;
end;
{Процедура формирования матрицы A (последовательности матриц)}
procedure AConsistance(var AMatrix:TMatrix;CEquival,V:TMatrix;Range:integer);
var i,j,k:integer;
begin
ClrScr;
for i:=1 to Range do
for j:=1 to Range do
begin
AMatrix[i,j]:=0;
end;
for k:=1 to Range do
for i:=1 to Range do
begin
for j:=1 to Range do
begin
AMatrix[k,i]:=AMatrix[k,i]+CEquival[k,j]*V[j,i];
end;
Coord_AMatrix(AMatrix,Range);
end;
end;
{==========================================================================}
{Промежуточная функция возведения в степень}
function pow(x:real;y:integer):real;
begin
if x=0 then pow:=0;
if x>0 then pow:=exp(y*ln(x));
if (x<0) and ((y mod 2)=0) then pow:=exp(y*ln(-x));
if (x<0) and ((y mod 2)<>0) then pow:=-exp(y*ln(-x));
end;
{Окончательная функция}
function f(x:real;i:integer;PVec:TVec;Range:integer):real;
var k:integer;
begin
k:=1;
if Range=4 then f:=pow(x,4)-PVec[k]*pow(x,3)-PVec[k+1]*pow(x,2)
-PVec[k+2]*x-PVec[k+3];
if Range=3 then f:=pow(x,3)-PVec[k]*pow(x,2)-PVec[k+1]*x-PVec[k+2];
end;
{Derivative -вторая производная}
function F_deriv(x:real;i:integer;PVec:TVec;Range:integer):real;
var k:integer;
begin
k:=1;
if Range=4 then F_deriv:=12*pow(x,2)-6*PVec[k]*x-PVec[k+1]*2;
if Range=3 then F_deriv:=6*x-2*PVec[k];
end;
{Реализация метода хорд для решения характеристического уравнения}
procedure ChordMethood(var X,Y:real;x1,x2,eps:real;i,Range:integer;PVec:TVec);
var Ya,Yb,Yk:real;
Xk,Xn:real;
k:integer;
begin
Ya:=f(x1,i,PVec,Range);
Yb:=f(x2,i,PVec,Range);
Y:=F_deriv(x1,i,PVec,Range);{Вторая производная}
if Ya*Y>0 then
begin
Xk:=x1;Yk:=Ya;X:=x2; Y:=Yb;
end
else
begin
Xk:=x2;Yk:=Yb; X:=x1;Y:=Ya;
end;
repeat
Xn:=X;X:=Xn-(Y/(Y-Yk))*(Xn-Xk);
Y:=f(X,i,PVec,Range);
until abs(X-Xk)>=eps;
writeln('Lambda = ',X:5:4);
writeln('root Y= ',Y);
readln;
end;
{Реализация метода уединения и уточнения коренй посредством метода хорд}
procedure Root_limit(var alpha,beta:real;var LVec:TVec;var RootNum:integer;
i,Range:integer;PVec:TVec);
const step_h=0.09;
var
x1,x2,y1,y2:real;
Ya,Yb,Yk,Y:real;
Xk,Xn,X:real;
eps:real;
k:integer;
begin
k:=0;
x1:=alpha;
x2:=x1+step_h;
y1:=f(x1,i,PVec,Range);
while x2<beta do
begin
y2:=f(x2,i,PVec,Range);
if y1*y2<0 then
begin
TextColor(MainTextColor);
writeln('Корень лежит в этих пределах:[',x1:5:4,';',x2:5:4,']');
{Процедура уточнения корней характеристического уравнения}
ChordMethood(X,Y,x1,x2,eps,i,Range,PVec);
k:=k+1;
LVec[k]:=X;
end
else
x1:=x2;
x2:=x1+step_h;
y1:=y2;
end;
RootNum:=k;{Число действительных корней характеристического уравнения}
end;
{===================Тело программы=========================================}
var AMatrix,CEquival,BMatrix,VMatrix:TMatrix;
X_SelfVec,LVec,U_EMatrix:TVec;
P_CharacteristicParam,Pk,Pn,Lambda,Max:real;{Параметр p характеристического уравнения матрицы}
Range,k,k1,i,j,num:integer;
i0,m:integer;
Cols,Rows:integer;
PVec:TVec;
{Параметры характеристического уравнения уравнения}
Ya,Yb,Yk:real;
Xk,Xn,x1,x2:real;
X,Y:real;
alpha,beta,eps:real;
RootNum:integer;
begin
ClrScr;
TextColor(MainTextColor);
Pn:=0;
Pk:=0;
Read_Range(Range);{Процедура считывает порядок матрицы}
InputMatrix(AMatrix,Range);{Считываем исходную матрицу}
{==========================================================================}
PlotSameMatrix(CEquival,AMatrix,Range);
{Блок вычисления коэффицентов характеристического уравнения матрицы}
ClrScr;
TextColor(MainTextColor);
writeln('Коэффиценты характеристического уравнения');
for k:=1 to Range-1 do
begin
Pk:=Trace(Range,AMatrix)/k; {Pk - коэффицент характкристич. уравнения}
PVec[k]:=Pk;
write('Pk_',k,'=',Pk:9:4);
readln;
VInter(VMatrix,BMatrix,AMatrix,Range,Pk);
AConsistance(AMatrix,CEquival,VMatrix,Range);
GoToXY(39,1);
writeln('Матрица A',k+1,'.');
readln;
end;
Pn:=Trace(Range,AMatrix)/Range;
PVec[k+1]:=Pn; {Вектор параметров P}
writeln('P_',Range,'=',Pn:9:2);
readln;
ClrScr;
writeln('Вектор коэффицентов P');
for k:=1 to Range do
begin
GoToXY(OutPutI+ScaleI*k,OutPutJ);
TextColor(MainTextColor);
write(PVec[k]:8:3);
end;
readln;
{==================Блок вычисления собственных чисел матрицы===============}
ClrScr;
TextColor(MainTextColor);
writeln('**********************');
writeln('Ведите пределы, в которых располагаются корни уравнения.');
write('Enter alpha= ');
readln(alpha);
write('Enter beta= ');
readln(beta);
write('Enter eps=');
readln(eps);
Root_limit(alpha,beta,LVec,RootNum,i,Range,PVec);
ClrScr;
TextColor(MainTextColor);
write('Вектор собственных чисел');
for k:=1 to RootNum do
begin
GoToXY(OutPutI+ScaleI*k,OutPutJ);
write(LVec[k]:8:4);
end;
readln;
end.