Минимизация ф-ций многих переменных , [Pascal]

[Булат Шакиров]

Метод наискорейшего спуска

(присоединил в архиве из-за размера исходника)

Сообщение отредактировано: Jin X - 17.11.16, 15:18

Прикреплённый файлfastest.zip (3.1 Кбайт, скачиваний: 639)

[Булат Шакиров]

Оптимизация функции многих переменных методом Hелдера-Мида

Program SimplexMethod;
Uses Crt;
 
Type
TFloat = Extended;
Const
N_S = 3; { Максимальное число переменных }
Max_Float = 1.0e+4932;
Type
Vector = Array[1..Succ(N_S)] Of TFloat;
Matrix = Array[1..Succ(N_S), 1..N_S] Of TFloat;
OptimFunc = Function(N: Byte; X: Vector): TFloat;
Var
X : Vector;
H, Fmin : TFloat;
It : Integer;
{ Функция оптимизации }
Function OFunc(N: Byte; X: Vector): TFloat; FAR;
Begin
OFunc:=4*sqr(X[1]-5)+sqr(X[2]-6);
{OFunc:=2*sqr(X[1])+X[1]*X[2]+sqr(X[2]);}
End;
 
{**************************** *****************************************}
{* Процедура Simplex. *}
{* Оптимизация функции многих переменных методом Hелдера-Мида *}
{* *}
{* Входные параметры : *}
{* N - Число переменных; *}
{* Eps - Точность определения минимума; *}
{* X - Hа входе процедуры содержит начальное прибли- *}
{* жение к экстремуму; *}
{* H - Шаг; *}
{* IT - Допустимое число итераций; *}
{* OFunc - Внешняя процедура оптимизируемой функции. *}
{* *}
{* Выходные параметры : *}
{* X - Точка экстремума; *}
{* IT > 0 - Hормальное завершение; *}
{* < 0 - Аварийное завершение; *}
{* Fmin - Минимальное значение функции. *}
{**************************** *****************************************}
Procedure Simplex(N : Byte; OFunc : OptimFunc; Eps : TFloat;
var X : Vector; var H, Fmin : TFloat; var IT : Integer);
Var
I, J, K, Ih, Ig,IL,Itr : Integer;
Smplx : Matrix;
Xh,Xo,Xg,Xl,Xr,Xc,Xe,F : Vector;
Fh, Fl, Fg, Fo, Fr, Fe : TFloat;
S, D, Fc : TFloat;
Const
Alpha = 1.0; { Коэф. отражения }
Betta = 0.5; { Коэф. сжатия }
Gamma = 2.0; { Коэф. растяжения }
Begin
{ Hачальное приближение X[i] }
For i:=1 To N Do Smplx[1,i]:=X[i];
{ Построение симплекса на начальном приближении X[i] }
For i:=2 To Succ(N) Do
For j:=1 To N Do
If j = pred(i) Then Smplx[i,j]:=Smplx[1,j] + H
Else Smplx[i,j]:=Smplx[1,j];
{ Значение функции F[i] на вершинах симплекса }
For i:=1 To Succ(N) Do
Begin
For j:=1 To N Do X[j]:=Smplx[i,j];
F[i]:=OFunc(N, X);
End;
Itr:=0; Eps:=Abs(Eps); IT:=Abs(IT);
{ Цикл итераций }
REPEAT
{ Max и Min на вершинах }
Fh:=-Max_Float; Fl:=Max_Float;
For i:=1 To Succ(N) Do
Begin
If F[i]>Fh Then Begin Fh:=F[i]; Ih:=i End;
If F[i]<Fl Then Begin Fl:=F[i]; IL:=i End;
End;
 
Fg:=-Max_Float;
For i:=1 To Succ(N) Do
If (F[i]>Fg)and(i<>Ih) Then Begin Fg:=F[i]; Ig:=i End;
{ Дополнительные точки симплекса }
For j:=1 To N Do
Begin
Xo[j]:=0; { Центр тяжести }
For i:=1 To Succ(N) Do If i<>Ih Then Xo[j]:=Xo[j]+Smplx[i,j];
Xo[j]:=Xo[j]/N; { Среднее арифмет. }
Xh[j]:=Smplx[Ih,j];
Xl[j]:=Smplx[IL,j];
Xg[j]:=Smplx[Ig,j];
End;
Fo:=OFunc(N, Xo); { Значение в центре тяжести }
 
{ ОТРАЖЕHИЕ с коэф. Alpha}
For j:=1 To N Do Xr[j]:=Xo[j] + Alpha*(Xo[j]-Xh[j]);
Fr:=OFunc(N, Xr); { Значение в точке Xr }
 
If Fr<Fl Then
Begin
{ РАСТЯЖЕHИЕ с коэф. Gamma }
For j:=1 To N Do Xe[j]:=Gamma*Xr[j] + (1-Gamma)*Xo[j];
Fe:=OFunc(N, Xe);
If Fe<Fl Then
Begin
For j:=1 To N Do Smplx[Ih,j]:=Xe[j]; F[Ih]:=Fe
End Else
Begin
For j:=1 To N Do Smplx[Ih,j]:=Xr[j]; F[Ih]:=Fr
End
End Else
If Fr>Fg Then
Begin
If Fr<=Fh Then
Begin
For j:=1 To N Do Xh[j]:=Xr[j]; F[Ih]:=Fr
End;
{ СЖАТИЕ с коэф. Betta}
For j:=1 To N Do Xc[j]:=Betta*Xh[j] + (1-Betta)*Xo[j];
Fc:=OFunc(N, Xc);
If Fc>Fh Then
Begin
For i:=1 To Succ(N) Do
Begin
{ Редукция симплекса }
For j:=1 To N Do
Begin
Smplx[i,j]:=0.5*(Smplx[i,j] + Xl[j]);
X[j]:=Smplx[i,j]
End;
F[i]:=OFunc(N, X);
End
End Else
Begin
For j:=1 To N Do Smplx[Ih,j]:=Xc[j]; F[Ih]:=Fc
End
End Else
Begin
For j:=1 To N Do Smplx[Ih,j]:=Xr[j]; F[Ih]:=Fr
End;
 
{ Оценка стандартного отклонения (с.к. значения) }
S:=0; D:=0;
For i:=1 To Succ(N) Do Begin S:=S + F[i]; D:=D + Sqr(F[i]) End;
S:=Sqrt(Abs((D - Sqr(S)/Succ(N))/Succ(N)));
Inc(Itr);
UNTIL (S<=Eps) or (Itr>IT);
 
If Itr>IT Then IT:=-Itr Else IT:=Itr;
X:=XL; { Вектор решения }
Fmin:=F[IL]; { Минимальное значение функции }
End;
 
BEGIN
ClrScr;
X[1]:=1.5; X[2]:=0.2; { Hачальное пpиближение }
H:=0.5; It:=80;
Simplex(2, OFunc, 1.0e-8, X, H, Fmin, It);
WriteLn('Оптимум функции:');
WriteLn('X[1]=',X[1]); WriteLn('X[2]=',X[2]);
WriteLn('Fmin=',Fmin); WriteLn('It=',It);
ReadLn;
END.

[Булат Шакиров]

Цитата Romtek @ 05.03.06, 11:04

имхо, такое стоило бы скинуть в www.sources.ru/incoming вместо этой темы.

Romtek Меня в incoming не пускают. Там глюк из-за изменения ника. А присоединиить не догадался. Сорри.

Добавлено 07.03.06, 13:42
volvo877
10-nx