Приложение 4. Текст модуля Library1.

unit Library1; interface type

Mat = array[1..20,1..21] of Real; Vec = array[1..101] of Real;

Xfn = function(X:Real):Real;

procedure Gauss(N:Integer; A:Mat; var X:Vec; var S:Real); procedure Zeidel(N:Integer; A:Mat; var X:Vec; var E:Real;

var M:Integer); procedure VvodA(var N:Integer; var A:Mat);

procedure Testing(N:Integer; A:Mat; X:Vec); procedure GRAM(N:Integer; var A:Mat; var X,Y:Vec;

var M,K:Integer);

procedure Newton(var X:Real; E:Real; F_div_df:Xfn); procedure Dix(A,B,E:Real; var X:Real; F:Xfn; var Kd:Integer); procedure Chord(A,B,E:Real; var X:Real; F:Xfn;

var Kd:Integer); procedure krest(x,y:longint);

procedure Grafic(nn:integer; var xx:vec; var yy:vec; n:integer; var x:vec; var y:vec);

function Power(Xx:Real; P:Integer):Real; function Deg_Rad(Gr:Real):Real;

implementation

uses crt, dos, graph;

function Power(Xx:Real; P:Integer):Real; var I:Integer; S:Real;

begin

if P=0 then Power:=1.0 else begin S:=1.0;

for i:=1 to P do S:=S*Xx; Power:=S;

end;

end;

function Deg_Rad(Gr:Real):Real; begin Deg_rad:=Gr*Pi/180.; end;

procedure krest(x,y:longint); begin

line(x-3,y,x+3,y); line(x,y-3,x,y+3);

end;

procedure Newton(var X:Real; E:Real; F_div_df : Xfn); var D,S:Real;

begin S:=X; repeat

S:=S-F_div_df(X); D:=Abs(S-X); X:=S;

until D<=E end;

procedure Dix(A,B,E:Real; var X:Real; F:Xfn; var Kd:Integer); var S,XX:Real;

begin

Kd:=0;

if F(A)*F(B)>0 then begin Kd:=1; exit; end;

if F(A)*F(B)=0 then begin X:=A; exit; end;

XX:=(A+B)/2; Repeat

if F(A)*F(XX)<0 then B:=XX else A:=XX;

X:=(A+B)/2.0;

S:=Abs(X-XX); XX:=X;

Until S<E; end;

procedure Chord(A,B,E:Real; var X:Real; F:Xfn; var Kd:Integer); var S,XX:Real;

begin Kd:=0;

XX:=(A+B)/2; Repeat

if (Abs((F(B)-F(A)))<E) and (Abs(B-A)<E) then begin X:=(A+B)/2; exit;

end

else X:=(F(B)*A-F(A)*B)/(F(B)-F(A)); if (X<A) or (X>B) then begin

Kd:=1;

exit;

end; if F(A)*F(X)<0 then B:=X

else A:=X;

S:=Abs(XX-X); XX:=X;

Until S<E; end;

procedure Testing(N:Integer; A:Mat; X:Vec); var

I,J : Integer;

S : Real; begin

Writeln;

Writeln('Проверка по невязке значений вектора правых частей СЛАУ'); Writeln;

for I:=1 to N do begin

S:=0.;

for J:=1 to N do S:=S+A[I,J]*X[J]; Writeln('i=',I:1,' заданное b=',A[I,N+1]:7:3); Writeln(' полученное b=',S:7:3);

Writeln;

end;

end;

procedure VvodA(var N:Integer; var A:Mat); var

I,J :Integer; begin

Writeln;	Ввод данных для решения СЛАУ');
Writeln('
Write('Порядок СЛАУ		N='); Readln(N);
Writeln;	Ввод значений коэффициентов матрицы		a[i,j]');
Writeln('
Writeln('	и элементов вектора правой части		b[i)]');
Writeln('-------------------------------------------------			');
Writeln('	i - индекс строки, j - индекс столбца;');
Writeln('-------------------------------------------------			');
for I:=1 to N do
begin
for J:=1 to N do
begin
Write('a[',I:2,',',J:2,']='); Readln(A[I,J]);
end;		b[',I:2,']='); Readln(A[I,N+1]);
Write('
end;

Writeln;

end;

procedure Gauss(N:Integer; A:Mat; var X:Vec; var S:Real); Var

I,J,K,L,K1,N1 : Integer; R : real;

begin N1:=N+1;

for K:=1 to N do begin K1:=K+1; S:=A[K,K]; J:=K;

for I:=K1 to N do begin R:=A[I,K];

if Abs(R) > Abs(S) then begin S:=R; J:=I; end;

end;

if S=0.0 then Exit;

if J<> K then for I:=K to N1 do begin R:=A[K,I]; A[K,I]:=A[J,I]; A[J,I]:=R

end;

for J:=K1 to N1 do A[K,J]:=A[K,J]/S; for I:=K1 to N do

begin R:=A[I,K];

for J:=K1 to N1 do A[I,J]:=A[I,J]-A[K,J]*R; end;

end;

if S<>0.0 then for I:=N downto 1 do begin

S:=A[I,N1];

for J:=I+1 to N do S:=S-A[I,J]*X[J]; X[I]:=S;

end;

end;

procedure Zeidel(N:Integer; A:Mat; var X:Vec; var E:Real; var M:Integer);

var

Ig,I,J : Integer;

	S : Real;
begin
	if E=0. then
	begin	Итерациoнный допуск равен 0. !');
	Writeln('
	Writeln('	Аварийное завершение процесса !');
	Exit;
	end;
	Ig:=0;
	for I:=1 to N do
	for J:=1 to N do if A[I,J]>A[I,I] then Ig:=Ig+1;
	if Ig>0 then
	begin
	Writeln('!!! Возможен расходящийся итерационный процесс !!!');
	Writeln('	Необходимо поменять строки местами так,');
	Writeln('	чтобы на главной диагонали располагались');
	Writeln(' наибольшие по абсолютному значению элементы строк!');
	Writeln('	(Для продолжения нажмите Enter).');
	Readln;
(*	end;
	начальное приближение *)
	for I:=1 to N do	X[I]:=A[I,N+1]/A[I,I];
(*	M:=0;
	итерационный процесс *)
repeat
	Ig:=0;
	M:=M+1;
	for I:=1 to N do
	begin
	S:=A[I,N+1];
	for J:=1 to N do if J<>I then S:=S-A[I,J]*X[J];
	S:=S/A[I,I];
	if Abs(S-X[I])>=E then Ig:=Ig+1;
	X[I]:=S;
	end;
	Write('m=',M:3);
	for I:=1 to N do Write(' x[',I:1,']=',X[I]:8:3);
	Writeln;
until Ig=0;
end;

procedure Gram(N:Integer; var A:Mat; var X,Y:Vec; var M,K:Integer); var

I1,Pp,I,J,L : Integer; S : Real;

begin M:=K+1;

for I:=1 to M do begin

for J:=1 to M do

begin S:=0.0; Pp:=I+J-2;

for L:=1 to N do S:=S+Power(X[L],Pp); A[I,J]:=S;

end; I1:=I-1; S:=0.0;

for L:=1 to N do S:=S+Y[L]*Power(X[L],I1); A[I,M+1]:=S;

end;

end;

procedure Grafic(NN:Integer; var XX:Vec; var YY:Vec;

N:Integer; var X:Vec; var Y:Vec);

var

GrDriver,GrMode,ErrCode : Integer; I,Ig,Xw,Yw : Integer; Xg,Yg : Longint;

Xmin,Xmax,Ymin,Ymax,X1,Y1 : Real;

Path,Num:string;

C:char;

S:SearchRec; begin

ClrScr;

{*** установка графики ***}

GrDriver := Detect; Path := '';

InitGraph(GrDriver,GrMode,Path); ErrCode := GraphResult;

if ErrCode <> GrOk then Halt(1);

{*** расчет рабочих переменных ***}

for I:=1 to NN do begin

if(I=1) or (Xmin>Xx[i]) then Xmin:=Xx[i]; if(I=1) or (Xmax<Xx[i]) then Xmax:=Xx[i]; if(I=1) or (Ymin>Yy[i]) then Ymin:=Yy[i]; if(I=1) or (Ymax<Yy[i]) then Ymax:=Yy[i]; end;

for I:=1 to N do begin

if Xmin>X[i] then Xmin:=X[i]; if Xmax<X[i] then Xmax:=X[i]; if Ymin>Y[i] then Ymin:=Y[i]; if Ymax<Y[i] then Ymax:=Y[i]; end;

{*** сетка ***}

SetColor(15);

Bar(0,0,GetMaxX,GetMaxY);

Xw:=540; SetLineStyle(1,$81,0); Setcolor(7);

for I:=0 to 10 do begin Ig:=25+42*i;

Line(65,Ig,65+Xw,Ig);

end;

for I:=0 to 10 do begin

Ig:=65+(Xw div 10)*i; Line(Ig,25,Ig,445); end;

Setcolor(0); SetLineStyle(0,$81,2);

if (Xmin<=0)and(Xmax>=0) then begin

Xg:=65+round(Xw*(-Xmin)/(Xmax-Xmin)); Line(Xg,25,Xg,445);

end;

if (Xmin<=0)and(Xmax>=0) then begin

Yg:=445-round(420*(-Ymin)/(Ymax-Ymin)); Line(65,Yg,65+Xw,Yg);

end;

Setcolor(0);

SetTextJustify(1,2); OutTextXY(600,465,'Аргумент');

for I:=0 to 5 do begin

X1:=(Xmax-Xmin)/5*I+Xmin; Str(X1:5:3,Num); Xg:=65+(Xw div 5)*I; OutTextXY(Xg,450,Num) end;

SetTextJustify(2,1); OutTextXY(70,10,'Функция'); for I:=0 to 5 do

begin Y1:=(Ymax-Ymin)/5*I+Ymin; Str(Y1:5:3,Num); Yg:=445-84*I; OutTextXY(60,Yg,Num) end;

{*** рисование линии ***}

setcolor(0); SetLineStyle(0,$81,0);

Xg:=65+round(Xw*(X[1]-Xmin)/(Xmax-Xmin)); Yg:=445-round(420*(Y[1]-Ymin)/(Ymax-Ymin)); moveto(Xg,Yg);

for I:=2 to N do begin

Xg:=65+round(Xw*(X[i]-Xmin)/(Xmax-Xmin)); Yg:=445-round(420*(Y[i]-Ymin)/(Ymax-Ymin)); Lineto(Xg,Yg);

end;

{*** рисование маркеров (крест) ***}

setcolor(0);

setlinestyle(0,12,1); for I:=1 to NN do

begin Xg:=65+round(Xw*(XX[i]-Xmin)/(Xmax-Xmin)); Yg:=445-round(420*(YY[i]-Ymin)/(Ymax-Ymin)); Krest(Xg,Yg);

end;

repeat until keypressed; C:=readkey;

closegraph;

end;

begin end.