III. Программный код (листинг программы)
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
Tar=array[0..100,0..1] of real;
TDar=array[0..200,0..1] of real;
const
a=0.4;
b=4;
h=0.2;
accur=0.000001; // погрешность начальной табуляции
accur2=0.0001; // погрешность вычисления интегралов
accur3=0.01; // погрешность вычисления обр. функции
function tab(xi,e:real):real;
var sum,ch:real; n:integer;
begin
n:=1;
sum:=0;
ch:=-xi*xi/4;
while abs(ch)>e do begin
sum:=sum+ch;
n:=n+1;
ch:=-ch*xi*xi*(n-1)/(2*n-1)/(2*n*n);
end;
tab:=sum;
end;
function Lag_mult(i:integer; x:real):real;
var j,n:integer; xi,xj,pr:real;
begin
n:=round((b-a)/h);
xi:=a+h*i;
pr:=1;
for j:=0 to i-1 do begin
xj:=a+h*j;
pr:=pr*(x-xj)/(xi-xj);
end;
for j:=i+1 to n do begin
xj:=a+h*j;
pr:=pr*(x-xj)/(xi-xj);
end;
Lag_mult:=pr;
end;
function Lag_mult2(i:integer; x:real):real;
var j,n:integer; xi,xj,pr:real;
begin
n:=round((b-a)/h);
xi:=((b-a)/2)*cos((2*i-1)*pi/(2*n))+(b+a)/2;
pr:=1;
for j:=1 to i-1 do begin
xj:=((b-a)/2)*cos((2*j-1)*pi/(2*n))+(b+a)/2;
pr:=pr*(x-xj)/(xi-xj);
end;
for j:=i+1 to n do begin
xj:=((b-a)/2)*cos((2*j-1)*pi/(2*n))+(b+a)/2;
pr:=pr*(x-xj)/(xi-xj);
end;
Lag_mult2:=pr;
end;
function fRect(x:real; N:integer):real;
var i:integer; su,h:real;
begin
su:=0;
h:=x/N;
for i:=1 to N do
su:=su+h*(cos(i*h-h/2)-1)/(i*h-h/2);
fRect:=su;
end;
function fTrapez(x:real; N:integer):real;
var i:integer; su,h:real;
begin
su:=0;
h:=x/N;
for i:=2 to N do
su:=su+h*((cos(i*h)-1)/(i*h)+(cos((i-1)*h)-1)/((i-1)*h))/2;
fTrapez:=su+(cos(h)-1)/2;
end;
function fSimps(x:real; N:integer):real;
var i:integer; su,h:real;
begin
su:=0;
h:=x/N;
for i:=1 to N-1 do
su:=su+h/6*((cos(i*h)-1)/(i*h)+4*(cos(i*h+h/2)-1)/(h*(i+1/2))+(cos((i+1)*h)-1)/((i+1)*h));
fSimps:=su+h/6*(4*(cos(h/2)-1)/(h/2)+(cos(h)-1)/h);
end;
function fGauss(x:real; N:integer):real;
var i:integer; su,h,sopr1,sopr2:real;
begin
su:=0;
h:=x/N;
sopr1:=h/2*(1-1/sqrt(3));
sopr2:=h/2*(1+1/sqrt(3));
for i:=0 to N-1 do
su:=su+h/2*((cos(i*h+sopr1)-1)/(i*h+sopr1)+(cos(i*h+sopr2)-1)/(i*h+sopr2));
fGauss:=su;
end;
function mSek(z,e,F:real): real;
function der(xi,ie:real):real;
var sum,ch:real; n:integer;
begin
n:=1;
sum:=0;
ch:=-xi/2;
while abs(ch)>ie do begin
sum:=sum+ch;
n:=n+1;
ch:=-ch*xi*xi/(2*n)/(2*n-1);
end;
der:=sum;
end;
var
zk2,zk1,zk,tb,tb1,tb2:real;
begin
zk2:=z;
tb2:=tab(zk2,e);
zk1:=zk2-(tb2-F)/der(zk2,e);
tb1:=tab(zk1,e);
repeat
zk:=zk1-(tb1-F)*(zk1-zk2)/(tb1-tb2);
tb:=tab(zk,e);
zk2:=zk1;
tb2:=tb1;
zk1:=zk;
tb1:=tb;
until abs(tb-F)<e;
mSek:=zk;
end;
var sp,sc:Tar;
s:TDar;
pogr,pogr_i,pLag:real;
n,p,i,k:integer;
f:TextFile;
begin
AssignFile(f,'out.txt');
ReWrite(f);
writeln(f,'Табулирование исходной функции:');
n:=round((b-a)/h);
for i:=0 to 2*n do begin
s[i,0]:=a+i*h/2;
s[i,1]:=tab(s[i,0],accur);
end;
for i:=0 to n do
write(f,s[2*i,0]:4:2,' ');
writeln(f);
for i:=0 to n do
write(f,s[2*i,1]:8:6,' ');
writeln(f);
writeln(f,'============================================');
//-----------Табулирование исходной функции-------------//
//----------по специальным узлам интерполяции-----------//
for i:=1 to n do begin
sc[i,0]:=((b-a)/2)*cos((2*i-1)*pi/(2*n))+(b+a)/2;
sc[i,1]:=tab(sc[i,0],accur);
end;
//-----Погрешности полинома Лагранжа в двух случаях-----//
//-------s2 содержит значения табуляции в точках,-------//
//-------соответствующих узлам начальной табуляции------//
//--------------------и между ними----------------------//
for i:=1 to n do
write(f,s[2*i-1,0]:4:2,' ');
writeln(f);
pogr:=0;
writeln(f,'Погрешность интерполяционного полинома Лагранжа, построенного по начальным узлам табуляции.');
writeln(f,'Погрешность считается по точкам, находящимся между узлами начальной табуляции:');
for i:=1 to n do begin
pLag:=0;
for k:=0 to n do
pLag:=pLag+s[2*k,1]*Lag_mult(k,s[2*i-1,0]);
pogr_i:=abs(s[2*i-1,1]-pLag);
write(f,pogr_i:10:8,' ');
if pogr < pogr_i then pogr:=pogr_i;
end;
writeln(f);
writeln(f,'Наибольшая:');
writeln(f,pogr:10:8);
pogr:=0;
writeln(f,'Погрешность интерполяционного полинома Лагранжа по спец. узлам интерполяции.');
writeln(f,'Погрешность считается по точкам, находящимся между узлами начальной табуляции:');
for i:=1 to n do begin
pLag:=0;
for k:=1 to n do
pLag:=pLag+sc[k,1]*Lag_mult2(k,s[2*i-1,0]);
pogr_i:=abs(s[2*i-1,1]-pLag);
write(f,pogr_i:10:8,' ');
if pogr < pogr_i then pogr:=pogr_i;
end;
writeln(f);
writeln(f,'Наибольшая:');
writeln(f,pogr:10:8);
writeln(f,'============================================');
//---Приближённые вычисления интегралов по 4-м методам--//
//---------sp содержит приближённые значения------------//
writeln(f,'Приближённые значения по формуле цетральных прямоугольников:');
for i:=0 to n do begin
p:=4;
while abs(fRect(s[2*i,0],p)-fRect(s[2*i,0],2*p))>accur2 do
p:=p*2;
sp[i,1]:=fRect(s[2*i,0],2*p);
sp[i,0]:=2*p;
end;
for i:=0 to n do
write(f,sp[i,1]:8:6,' ');
writeln(f);
writeln(f,'Погрешность метода равна:');
for i:=0 to n do
write(f,abs(s[2*i,1]-sp[i,1]):8:6,' ');
writeln(f);
for i:=0 to n do
write(f,sp[i,0]:4:0,' ');
writeln(f);
writeln(f);
writeln(f,'Приближённые значения по формуле трапеции [(cos(t)-1)/t при t~0 равно 0]:');
for i:=0 to n do begin
p:=4;
while abs(fTrapez(s[2*i,0],p)-fTrapez(s[2*i,0],2*p))>accur2 do
p:=p*2;
sp[i,1]:=fTrapez(s[2*i,0],2*p);
sp[i,0]:=p*2;
end;
for i:=0 to n do
write(f,sp[i,1]:8:6,' ');
writeln(f);
writeln(f,'Погрешность метода равна:');
for i:=0 to n do
write(f,abs(s[2*i,1]-sp[i,1]):8:6,' ');
writeln(f);
for i:=0 to n do
write(f,sp[i,0]:4:0,' ');
writeln(f);
writeln(f);
writeln(f,'Приближённые значения по формуле Симпсона:');
for i:=0 to n do begin
p:=4;
while abs(fSimps(s[2*i,0],p)-fSimps(s[2*i,0],2*p))>accur2 do
p:=p*2;
sp[i,1]:=fSimps(s[2*i,0],2*p);
sp[i,0]:=p*2;
end;
for i:=0 to n do
write(f,sp[i,1]:8:6,' ');
writeln(f);
writeln(f,'Погрешность метода равна:');
for i:=0 to n do
write(f,abs(s[2*i,1]-sp[i,1]):8:6,' ');
writeln(f);
for i:=0 to n do
write(f,sp[i,0]:4:0,' ');
writeln(f);
writeln(f);
writeln(f,'Приближённые значения по формуле Гаусса:');
for i:=0 to n do begin
p:=4;
while abs(fGauss(s[2*i,0],p)-fGauss(s[2*i,0],2*p))>accur2 do
p:=p*2;
sp[i,1]:=fGauss(s[2*i,0],2*p);
sp[i,0]:=p*2;
end;
for i:=0 to n do
write(f,sp[i,1]:8:6,' ');
writeln(f);
writeln(f,'Погрешность метода равна:');
for i:=0 to n do
write(f,abs(s[2*i,1]-sp[i,1]):8:6,' ');
writeln(f);
for i:=0 to n do
write(f,sp[i,0]:4:0,' ');
writeln(f);
writeln(f,'============================================');
writeln(f,'Вычисление обратной функции:');
for i:=0 to n do s[2*i,0]:=s[2*i,1];
for i:=1 to n-1 do s[2*i,0]:=s[0,0]+i/n*(s[2*n,0]-s[0,0]);
for i:=0 to n do
write(f,s[2*i,0]:4:2,' ');
writeln(f);
for i:=0 to n do begin
s[2*i,1]:= mSek(a+i*h,accur3,s[2*i,0]);
write(f,s[2*i,1]:8:6,' ');
end;
writeln(f);
for i:=0 to n do begin
s[2*i,0]:= tab(s[2*i,1], accur3);
write(f, s[2*i,0]:8:6,' ');
end;
writeln(f);
CloseFile(f);
end.