?? comp_2.pas
字號:
unit comp_2;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;
type
TForm2 = class(TForm)
GroupBox1: TGroupBox;
cp: TButton;
qx: TButton;
sd: TSaveDialog;
jgxs: TMemo;
procedure FormCreate(Sender: TObject);
procedure cpClick(Sender: TObject);
procedure qxClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
procedure sjxs_1;
procedure sjxs_2;
Procedure comp;
procedure xcente;
procedure pricom;
procedure fxsegu;
function rmd() : real;
implementation
uses comp_1, comp_0, comp_FGH;
{$R *.DFM}
procedure TForm2.FormCreate(Sender: TObject);
begin
Form2.Left :=50;
Form2.Top :=50;
end;
procedure TForm2.cpClick(Sender: TObject);
begin
if sd.Execute then
begin
if fileexists(sd.filename) then
begin
if application.MessageBox('您確認要覆蓋此文件嗎？','警告',MB_YESNO)=idyes then
form1.WriteDataToFile(sd.filename);
end
else
begin
form1.WriteDataToFile(sd.filename);
end;
if application.MessageBox('要返回嗎？','提示',MB_YESNO)=idyes then
Form2.Close;
end;
end;
procedure TForm2.qxClick(Sender: TObject);
begin
Form2.Close;
end;
//=================優化算法程序=============================
procedure comp; // 主程序
var p1,i,j,temp1:integer;
sdx,phi:real;
label here;
begin
with form1.comple do begin
temp1:=0;
FFX;fx00:=fx;
here:
pricom;
with form2.jgxs.lines do
begin
add('-------------------------------------------------------------------------------');
add(' ');
add('二、計算過程__數據');
add('===============================================================================');
end;
repeat
ITE := ITE+1;
fxsegu;
lh:=1;
for i:=1 to n do xh[i]:=xcom[i,lh];
fxh:=fxk[lh];
LL:=kfh;
xcente;
ggx;
for i:=1 to n do x0[i]:=x[i];
for j:=1 to kg do
if gx[j]>0.0 then begin temp1:=1; break; end
else temp1:=0;
if temp1=1 then
for i:=1 to n do
begin x[i]:=xl[i];bl[i]:=xl[i];bu[i]:=x0[i];goto here; end;
FFX; fx0:=fx; phi:=1.3;
repeat
repeat
for i:=1 to n do begin xr[i]:=x0[i]+phi*(x0[i]-xh[i]);x[i]:=xr[i]; end;
ggx;
for j:=1 to kg do
if gx[j]>0.0 then begin temp1:=1;phi:=0.5*phi; break; end
else temp1:=0;
until (temp1=0);
FFX; fxr:=fx;
if(fxr>fxh) then phi:=0.5*phi;
until (fxr<=fxh);
for i:=1 to n do xcom[i,lh]:=xr[i];
fxk[lh]:=fxr;
fxsegu;
for p1:=1 to n do xl[p1]:=xcom[p1,kfh];
fxl:=fxk[kfh];
IF (ITE=1) or (ITE = ((ITE div 10)*10)) THEN
BEGIN
with form2.jgxs.lines do
begin
Add(' 復合形迭代次數 ITE = '+inttostr(ITE));
Add(' -----------------------------------------------------------------------------');
Add(' 設計變量迭代點 X:');
for i := 1 to n do Add(#9+#9+#9+'X['+inttostr(i)+']= '+formatfloat('0.000000E+00',XL[i]));
Add(' -----------------------------------------------------------------------------');
Add(' 目標函數值 F(X)= '+floattostr(FXL));
Add(' -----------------------------------------------------------------------------');
end;
END;
sdx:=0.0;
for p1:=1 to Kfh-1 do sdx:=sdx+(fxl-fxk[p1])*(fxl-fxk[p1]);
sdx:=sqrt(sdx/(Kfh-1));
until (sdx<=eps);
for i:=1 to n do x[i]:=xcom[i,kfh];
fx:=fxk[kfh];
ggx;
end;
end;
function rmd() : real;
var
rm35,rm36,rm37 :real;
begin
with form1.comple do begin
rm35:=exp(35.0*ln(2.0));
rm36:=2.0*rm35;
rm37:=2.0*rm36;
rm:=5.0*rm;
if rm>=rm37 then rm:=rm-rm37;
if rm>=rm36 then rm:=rm-rm36;
if rm>=rm35 then rm:=rm-rm35;
rmd:=rm/rm35;
end;
end;
procedure fxsegu;
var ii,kl,lp,lp1,kk:integer;w:real;
begin
with form1.comple do begin
for kk:=1 to kfh-1 do
begin
KL:=kfh-kk;
for lp:=1 to KL do
begin
lp1:=lp+1;
if(fxk[lp] <= fxk[lp1]) then
begin
w:=fxk[lp]; fxk[lp]:=fxk[lp1]; fxk[lp1]:=w;
for ii:=1 to n do
begin
x[ii]:=xcom[ii,lp]; xcom[ii,lp]:=xcom[ii,lp1];
xcom[ii,lp1]:=x[ii];
end;
end;
end;
end;
end;
end;
procedure xcente;
var ii,kk:integer;xs:real;
begin
with form1.comple do begin
for ii:=1 to n do
begin
xs:=0.0;
for kk:=1 to LL do if (kk<>LH) then xs:=xs+xcom[ii,kk];
if(LH<=0) then x[ii]:=xs/LL else x[ii]:=xs/(LL-1);
end;
end;
end;
//==================
procedure pricom;
//==================
var
p1,p2,p3,p4,p5,LL1,temp1:integer;
q:real;
begin
with form1.comple do begin
ggx;
repeat
temp1:=0;
for p1:=1 to kg do
begin
if(gx[p1]>0) then
begin
for p2:=1 to n do
begin
q:=rmd(); x[p2]:=bl[p2]+q*(bu[p2]-bl[p2]);
temp1:=1;
end;
ggx;break;
end;
end;
until (temp1=0);
for p1:=1 to n do xcom[p1,1]:=x[p1];
for p1:=2 to kfh do for p2:=1 to n do
begin
q:=rmd(); xcom[p2,p1]:=bl[p2]+q*(bu[p2]-bl[p2]);
end;
LH:=0;
for p1:=1 to Kfh-1 do
begin
LL:=p1; xcente; //ggx;
for p2:=1 to n do x0[p2]:=x[p2];fx0:=fx;
LL1:=LL+1;
for p2:=1 to n do x[p2]:=xcom[p2,LL1];
ggx;
repeat
// ggx;
temp1:=0;
for p3:=1 to kg do
begin
if gx[p3]>0.0 then
begin
temp1:=1;
break;
end;
end;
if temp1=1 then
begin
for p4:=1 to n do
begin
x[p4]:=x0[p4]+0.5*(x[p4]-x0[p4]);
end;
ggx;
end;
until (temp1=0);
for p5:=1 to n do xcom[p5,LL1]:=x[p5];
end;
for p1:=1 to Kfh do
begin
for p2:=1 to n do x[p2]:=xcom[p2,p1];
{ ggx;
for p2:=1 to kg do
if gx[p2]>0.0 then temp1:=1
else temp1:=0;
}
FFX;
fxk[p1]:=fx;
end;
end;
end;
//========================================================================
//========================================================================
//===========================================================================
procedure sjxs_1;
var
ii : integer;
jg:array[1..400] of string;
begin
with form1.comple do
begin
jg[1]:=floattostr(n);
jg[2]:=floattostr(kg);
jg[3]:=floattostr(kfh);
jg[4]:=floattostr(EPS);
with form2.jgxs.lines do
begin
clear;
add(' 常用優化方法 ——復合形法 懲罰函數法 ');
add(' ^^^^^^^^^^^^^^^^^^^^^^^^^^ ');
add(' ');
add('一、初始數據');
add('===============================================================================');
Add(' 設計變量個數 N = '+jg[1]);
Add(' -----------------------------------------------------------------------------');
Add(' 不等式約束個數 KG = '+jg[2]+' 復合形頂點個數 K = '+jg[3]);
Add(' -----------------------------------------------------------------------------');
Add(' 收斂精度 EPS = '+jg[4]);
Add(' -----------------------------------------------------------------------------');
Add(' 設計變量初始點 X0:');
for ii := 1 to n do Add(#9+#9+#9+'X['+inttostr(ii)+']='+floattostr(x[ii]));
Add(' -----------------------------------------------------------------------------');
Add(' 設計變量下界 BL:');
for ii := 1 to n do Add(#9+#9+#9+'BL['+inttostr(ii)+']='+floattostr(BL[ii]));
Add(' -----------------------------------------------------------------------------');
Add(' 設計變量上界 BU:');
for ii := 1 to n do Add(#9+#9+#9+'BU['+inttostr(ii)+']='+floattostr(BU[ii]));
Add(' -----------------------------------------------------------------------------');
Add(' 初始點目標函數值 F(X0)= '+floattostr(FX));
if kg>0 then
begin
Add(' -----------------------------------------------------------------------------');
Add(' 初始點處的不等約束函數值 G(X0):');
for ii := 1 to kg do Add(#9+#9+#9+#9+'GX['+inttostr(ii)+']= '+formatfloat('0.000000E+00',GX[ii]));
end;
end;
end;
end;
//99999999999999999999999999999999999999999999999999999999999999999
procedure sjxs_2;
var
ii : integer;
jg:array[1..400] of string;
begin
with form1.comple do
begin
jg[1]:=inttostr(ITE);
jg[2]:=inttostr(NFX);
with form2.jgxs.lines do
begin
add(' ');
add('三、優化結果__數據');
add('===============================================================================');
Add(' 復合形迭代次數 ITE = '+jg[1]+' 目標函數計算次數 IFX = '+jg[2]);
Add(' -----------------------------------------------------------------------------');
Add(' 設計變量最優點 X*:');
for ii := 1 to n do Add(#9+#9+#9+'X['+inttostr(ii)+']= '+formatfloat('0.000000E+00',X[ii]));
Add(' -----------------------------------------------------------------------------');
Add(' 最優值 F(X*)= '+floattostr(FX));
if kg>0 then
begin
Add(' -----------------------------------------------------------------------------');
Add(' 最優點處的不等約束函數值 G(X*):');
for ii := 1 to kg do Add(#9+#9+#9+#9+'GX['+inttostr(ii)+']= '+formatfloat('0.000000E+00',GX[ii]));
end;
Add('-------------------------------------------------------------------------------');
Add('--- STOP --- ');
end;
end;
end;
end.
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -