IPB
ЛогинПароль:

> Внимание! Действует предмодерация

Подраздел FAQ (ЧАВО, ЧАстые ВОпросы) предназначен для размещения готовых рабочих программ, реализаций алгоритмов. Это нечто вроде справочника, он наполнялся в течение 2000х годов. Ваши вопросы, особенно просьбы решить задачу, не пройдут предмодерацию. Те, кто наполнял раздел, уже не заходят на форум, а с теми, кто на форуме сейчас, лучше начинать общение в других разделах. В частности, решение задач — здесь.

 
 Ответить  Открыть новую тему 
> Численные методы решения уравнений, + визуализация
сообщение
Сообщение #1





Группа: Пользователи
Сообщений: 7

Репутация: -  0  +


Метод дихотомии (деления отрезка пополам)
Цитата
Программа находит корень уравнения F(x) = 0, где F(x) - непрерывная на отрезке [a,b] функция, удовлетворяющая условию F(a)*F(B)<0. Для нахождения корня отрезок [a,b] делится пополам и выбирается тот полуинтервал, на концах которого знаки F(x) разные. Затем процесс деления повторяется до тех пор, пока длина интервала не станет меньше Eps.


{$n+}
Uses Crt;

Function f(x: Double): Double;
 Begin
   f := 1 / (Exp(x * Ln(2))) - 10 + 0.5*Sqr(x)
 End;

Var
 x, Eps, a, b, c: Double;
 n: Integer;

begin
 ClrScr;
 Writeln('Введите значения a и b'); Read(a, b);
 WriteLn('Введите точность Eps'); Read(Eps);

 n := 0;
 Repeat
   c := (a + b) / 2;
   If (f(a) * f©) < 0 Then b := c
   Else a := c;
   Inc(n)
 Until (b - a) <= Eps;

 x := (a + b) / 2;
 WriteLn('Корень равен  x=', x:10:7);
 WriteLn('Количество делений = ',n);
 ReadKey
end.



Метод хорд

{$n+}
Uses Crt;
Var
 x, Eps, a, b, c: Double;
 n: Integer;

Function f(x: Double): Double;
 Begin
   f := 1 / (Exp(x * Ln(2))) - 10 + 0.5*Sqr(x)
 End;

Function Chord(a, b: Double): Double;
 Begin
   Chord := (f(b)*a - f(a)*b) / (f(b) - f(a))
 End;

begin
 ClrScr;
 Writeln('Введите значения a и b');
 Read(a, b);

 WriteLn('Введите точность Eps');
 Read(Eps);

 ClrScr;
 n := 0;
 Repeat
   C := Chord(a, b);
   If f(a)*f© > 0 Then a := c
   Else b := c;
   Inc(n)
 Until Abs(Chord(a, b) - C) < Eps;

 x := c;
 WriteLn('Корень равен x=', x:10:7);
 WriteLn('Количество итераций =  ',n);
 ReadKey
end.



Метод Ньютона (касательных)
Цитата
Действительный корень x уравнения F(x) = 0 вычисляется методом Ньютона по итерационному уравнению:
Xk+1 = Xk - F(Xk)/F'(Xk)


{$n+}
Function newton(start, Eps: Extended): Extended;
 Var
   X, prev: Extended;

 { Заданная функция }
 Function F(Arg: Extended): Extended;
   Begin
     F := Sqr(Arg) - 2
   End;

 { Производная заданной функции }
 Function Deriv(Arg: Extended): Extended;
   Begin
     Deriv := 2 * Arg
   End;

 Begin
   X := start;
   Repeat
     prev := X;
     X := prev - F(prev) / Deriv(prev);
   Until Abs(X - prev) <= Eps;
   newton := X
 End;

Var a, Eps: Extended;

begin
 WriteLn('Введите начальное приближение a');
 Read(a);
 WriteLn('Введите точность Eps');
 Read(Eps);

 WriteLn('Корень равен x= ', newton(a, Eps):10:7);
end.



Метод Ньютона с аппроксимацией производной

Цитата
Если вычисление производной в методе Ньютона затруднено, можно заменить ее вычисление оценкой:
F'(X)= (F(X+h)-F(X))/h

{$n+}
Function newton(start, Eps: Extended): Extended;
 Var
   X, prev: Extended;

 Function noDeriv(Arg: Extended): Extended;

   Function F(Arg: Extended): Extended;
     Begin
       F := 1 / (Exp(arg * Ln(2))) - 10 + 0.5*Sqr(arg)
     End;

   Begin
     noDeriv := -2 * Eps * F(Arg) / (F(Arg + eps) - F(Arg - eps))
   End;

 Begin
   X := start;
   Repeat
     prev := X;
     X := prev + noDeriv(prev)
   Until Abs(X - prev) <= Eps;
   newton := X
 End;

Var a, Eps: Extended;

begin
 WriteLn('Введите начальное приближение a');
 Read(a);
 WriteLn('Введите точность Eps');
 Read(Eps);

 WriteLn('Корень равен x= ', newton(a, Eps):10:7);
end.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


Уникальный
**

Группа: Пользователи
Сообщений: 64
Пол: Мужской

Репутация: -  2  +


Метод половинного деления

Программа как и положено по теории находит сначала отрезки где функция меняет знак на противоположный (то есть - где лежит корень), потом находит этот корень и в заключении строит график.

Исходный код
uses crt, graph;

const
d1=-100; { Отрезок проверки }
d2=100;

var
x:real;
a:array [1..2, 1..255] of real;
b:boolean;
i,n:byte;
y1,y2,dr,md,maxx,maxy,maxx2,maxy2:integer;

function f(x:real):real;
begin { Нужная функция }
f:=sin(x/20)*20;
end;

procedure search(a,b:real; var x:real);
const e=0.0001; { e - Точность }
begin
repeat
x:=(a+b)/2;
if f(a)*f(x)>0 then a:=x else b:=x;
until abs(f(x))<e;
end;

begin
clrscr;
{
Определение отрезков в которых функция меняет знак
на противоположный, то есть отрезки где лежит корень
}
x:=d1;
if f(d1)>0 then b:=true;

repeat
if b=true then begin
if f(x)<0 then begin
n:=n+1;
a[2,n]:=x;

repeat
x:=x-0.1;
until f(x)>0;

a[1,n]:=x;
x:=a[2,n];
b:=false;
end;
end;

if b=false then begin
if f(x)>0 then begin
n:=n+1;
a[2,n]:=x;

repeat
x:=x-0.1;
until f(x)<0;
a[1,n]:=x;
x:=a[2,n];
b:=true;
end;
end;
x:=x+0.1;
until x>d2;

if n=0 then writeln('Корней нет !!!')
else begin
writeln('В уравнении F(x) на отрезке [',d1,',',d2,'] найдено ',
n,' корн(-ей/-я/-ь)');
for i:=1 to n do begin
search(a[1,i],a[2,i],x);
writeln('X',i,' = ',x:5:3);
end;
end;

writeln('Нажмите клавишу "Enter" для построения');
readln;
dr:=9;
md:=2;
initgraph(dr,md,'c:\bp\bgi');{c:\bp - папка куда установлен TP7.0}
setcolor(12);

maxx:=getmaxx;
maxy:=getmaxy;
maxx2:=maxx div 2;
maxy2:=maxy div 2;

{ось OY}
line(maxx2,0,maxx2,maxy);
line((maxx2)-4,10,maxx2,0);
line((maxx2)+4,10,maxx2,0);
line((maxx2)+10,5,maxx2+14,9);
line((maxx2)+14,9,maxx2+18,5);
line((maxx2)+14,9,maxx2+14,14);
{ось OX}
line(0,maxy2,maxx,maxy2);
line(maxx-10,maxy2-4,maxx,maxy2);
line(maxx-10,maxy2+4,maxx,maxy2);
line(maxx-15,maxy2-12,maxx-7,maxy2-20);
line(maxx-15,maxy2-20,maxx-7,maxy2-12);

{График уравнения}
x:=d1;
setcolor(15);
repeat
y1:=maxy2-round(f(x-1));
y2:=maxy2-round(f(x));
if (y1>0) and (y1<maxy) and (y2>0) and (y2<maxy) then
line((round(x-1)+maxx2),y1,round(x)+maxx2,y2);
x:=x+1;
until x>d2;
readln;
closegraph;
end.


Эскизы прикрепленных изображений
Прикрепленное изображение

--------------------
Век живи, век учи С © by Jahnerus
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3


Пионер
**

Группа: Пользователи
Сообщений: 81
Пол: Мужской
Реальное имя: Шурик

Репутация: -  0  +


Программа демонстрирует графический способ нахождения корней методом хорд!
Исходный код
program Metod_hord_graph;
uses
crt, graph;

var
gd, gm : integer;
maxY, minY, x1, x2, x3, y1, y2: real;

const
k3 = 3;{ Koeficenti }
k2 = -7;
k1 = -6;
k0 = 2; {}
grmaxX = 5; { Granici }
grminX = -5;

{---}
function f(x: real): real;
begin
f := k3*(x*x*x)+k2*(x*x)+k1*(x)+k0;
end;
{---}

function RealToScr(p: real; xory: boolean): integer;
var
i: integer;
ch: boolean;
rr: real;
begin
ch := false;
if xory then begin
rr := grminx;
for i := 0 to 645 do begin
if abs(rr-p) < 0.1 then begin
ch := true;
RealToScr := i;
end;
rr := rr + ((abs(grmaxx) + abs(grminx))/640 );
end;
end
else begin
rr := maxy;
for i := 0 to 479 do begin
if abs(rr-p) < 1 then begin
ch := true;
RealToScr := i;
end;
rr := rr - ((abs(maxy) + abs(miny))/480 );
end;
end;
if not(ch) then realtoscr := 10000;
end;
{---}

var
i, tx, ty: integer;
x: real;
s: string;

begin
{Graphic initialization}
gd := vga; gm := vgahi;
initgraph(gd,gm,'c:\programs\language\bp\bgi');
{}
maxY := f(grmaxX);
minY := f(grminX);
x1 := 1;
x2 := 5;
{ }

x := grminx;

for i := 0 to 639 do begin
putpixel(i,realtoscr(0,false),red);
end;

moveto(realtoscr(x,true),realtoscr(f(x),false));
repeat
x := x + 0.01;
tx :=realtoscr(x,true);
ty :=realtoscr(f(x),false);
if (tx <> 10000) and (ty <> 10000) then lineto(tx,ty);
delay(100);
until abs(x - grmaxx )<1E-5;

outtextxy(0,3,'Press any key !');
readkey;
setfillstyle(1,black);
bar(0, 0, 620, 10);

repeat
setcolor(green);
line(realtoscr(x1,true),realtoscr(f(x1),false),
realtoscr(x2,true),realtoscr(f(x2),false));
y1 := f(x1);
y2 := f(x2);
x3 := ((x1 * y2) - (x2 * y1)) / (y2 - y1);
if f(x3) < 0
then x1 := x3
else x2 := x3;
delay(10000);

until (abs(f(x3)) < 1);
str(x3 :2:5,s);
s := 'x = ' + s;
setcolor(white);
outtextxy(0,5,s);
readkey;
end.


Эскизы прикрепленных изображений
Прикрепленное изображение
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


Профи
****

Группа: Пользователи
Сообщений: 660
Пол: Мужской
Реальное имя: Михаил

Репутация: -  11  +


Метод итераций. Модернизирован так, чтобы лучше и быстрее сходился. Для этого функция F(x) делится на коэффициент M, который является численным значением производной функции F(x) в каждой точке итерационного приближения. И все равно, главное во всех методах итерационных приближений - это начальное приближение, т.е. то самое первое значение x, с которого стартует метод итераций.

Код
program ITERAT;
uses crt;

const max_iter=100;   {максимальное количество итераций}

var
 i :integer;
 x,x0,eps,M :real;

function F(x:real):real; {функция}
 begin
   F:=5*x*x-exp(1-x)-4;
 end;

begin {основная программа}
 clrscr;
 write('Введите приближенное значение x='); readln(x);
 write('Введите точность вычислений eps='); readln(eps);

 i:=0;
 repeat
   M:=-(F(x+eps)-F(x-eps))/(2*eps); {коэффициент для улучшения сходимости}
   x0:=x;
   x:=x0+F(x0)/M; {сердце метода итераций}
   inc(i);
   writeln('--- Итерация ',i:3,'   x=',x);
   writeln('F(x)=',F(x),'    точность=',abs(x-x0));
 until (abs(x-x0)<=eps)or(i>max_iter);

 if (abs(x-x0)<=eps) then writeln('Ответ: X=',x)
 else writeln('Ответ не найден! За ',max_iter:0,' шагов итерация не сошлась.');

end.


Чтобы получить метод простых итераций, уберите строчку:
Код
   M:=-(F(x+eps)-F(x-eps))/(2*eps); {коэффициент для улучшения сходимости}


И вместо строчки:
Код
   x:=x0+F(x0)/M; {сердце метода итераций}


Наберите:
Код
   x:=x0+F(x0); {сердце метода итераций}


--------------------
Никогда не жадничай. Свои проблемы с любовью дари людям!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 22.11.2024 22:20
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name