Код: Выделить всё
program parabola;
uses crt;
var niz,verh,toch:real;
Function func (x :real) : real;
begin
func :=x*cos(x);{Zadaite zdes svoiu funkciu}
end;
Function sign(ch:real):integer;
begin
if ch=0 then
begin
sign:= 0
end
else
if ch > 0 then sign := 1 else sign := -1;
end;
Function zeroin (ax, bx, tol : real) : real;
Label 20, 30;
var a,b,c,d,e,eps,fa,fb,fc,tol1,xm,p,q,r,s:real;
dn : boolean;
begin eps := 1.0;
dn := false;
repeat
eps := eps / 2.0;
tol1 := 1.0 + eps;
until tol1 <= 1.0;
a := ax;
b := bx;
fa := func (a);
fb := func (b);
20: c := a;
FC := FA;
d := b - a;
e := d;
repeat
if abs (FC) < abs (FB) then
begin a := b;
b := c; c := a;
fa := fb; fb := fc;
fc := fa;
end;
{*** ПРОВЕРКА СХОДИМОСТИ ***}
tol1 := 2.0*eps*abs(b) + 0.5*tol;
xm := 0.5 * (c-b);
if abs (xm) <= tol1 then dn := true
else
if fb=0.0 then dn := true
else
begin
{*** ВОПРОС О НЕОБХОДИМОСТИ БИСЕКЦИИ ***}
if (abs(e)>=tol1) and
(abs(fa)>abs(fb)) then
begin
{*** ПРОВЕРКА НА КВАДРАТИЧ. ИНТЕРПОЛЯЦИЮ ***}
if a<>c then
begin
q := fa / fc; r := fb / fc;
c := fb / fa;
p:= s*(2.0*xm*q*(q-r)- (b-a)*(r-1.0));
q := (q-1.0)*(r-1.0)*(s-1.0);
end
else
begin s := fb / fa;
p := 2.0*xm*s;
q := 1.0 - s;
end;
{*** ВЫБОР ЗНАКА ДЛЯ Q ***}
if p > 0.0 then q := -q;
p := abs (p);
{** ВОПРОС О ПРИМЕНИМОСТИ МЕТОДА ИНТЕРПОЛЯЦИИ **}
if ((2.0*p) < (3.0*xm*q-abs(Tol1*q)))
and (p < (abs(0.5*e*q))) then
begin e := d;
d := p/q; goto 30;
end;
end;
d := xm;
e := d;
30: a := b;
fa := fb;
if abs(d) > tol1 then b := b + d;
if abs(d) <= Tol1 then
b := b + sign(Tol1)*xm;
fb := func (b);
if (fb*(fc / abs(fc))) > 0.0 then goto 20;
end;
until dn;
zeroin := b;
end;
begin
clrscr;
writeln('Zadaite granicy intervala, gde budet proizveden poisk nulia funkcii:');
write(' a -> ');
readln(niz);
write(' b -> ');
readln(verh);
write('Zadaite granicu pogreshnosti vychislenii: ');
readln(toch);
clrscr;
writeln('Interval: ot ',niz:5:2,' do ',verh:5:2);
writeln('Tochnosti: ',toch:10:8);
writeln('x= ',zeroin(niz,verh,toch):10:6);
writeln('F(x)= ',func(zeroin(niz,verh,toch)):10:8);
readln;
end.
