Ask Question

Name:
Title:
Your Question:

Answer Question

Name:
Your Answer:
User Submitted Source Code!


Description:
  4et45rt
Language: PASCAL
Code:
Type vector = record
                 x: double;
                 y: double;
                 z: double;
              end;
Const eps=1.0E-5;
var  y : array [0..4] of vector;
     z : array [1..3] of vector;
     d,x1,xk,xk1,y0,y1 : vector;
     i,j,NN,k,n : integer;
     func,lyambda,ddist : double;
     a,b : array [1..3] of vector;
     f : text;
      ipr:integer;

procedure Init (var x0 : vector ; xa,xb,xc : double) ;
begin
  x0.x:=xa ;
  x0.y:=xb ;
  x0.z:=xc ;
end ;

procedure Plus (var a1 : vector ; a0:vector;lia:double;dd:vector) ;
begin
  a1.x:=a0.x+lia*dd.x ;
  a1.y:=a0.y+lia*dd.y ;
  a1.z:=a0.z+lia*dd.z ;
end ;

procedure Norm (var fd : vector ) ;
var  fn : double ;
begin
  fn:=sqrt(sqr(fd.x)+sqr(fd.y)+sqr(fd.z)) ;
  fd.x:=fd.x/fn ;
  fd.y:=fd.y/fn ;
  fd.z:=fd.z/fn ;
end ;

function Dist ( f1,f2 : vector ) : double;
begin
  Dist:=sqrt(sqr(f1.x-f2.x)+sqr(f1.y-f2.y)+sqr(f1.z-f2.z)) ;
end ;

procedure mono(x0:vector);
const
      l=1.0e-6 ;
      eps1=0.01;
var
   bbb : boolean;
   aa,bb,c,myu,h,cc,RR1,RR2,RR3,Z0,Z1,Z2,AA0,BB0 : double ;
   f1 : array [0..100] of double;

 function xx ( x : double ) : double ;
 begin
   xx:=x0.x+x*d.x ;
 end ;
 function yy ( x : double ) : double ;
 begin
   yy:=x0.y+x*d.y ;
 end ;
 function zz ( x : double ) : double ;
 begin
   zz:=x0.z+x*d.z ;
 end ;

 function Q ( x : double ) : double ;
 var x1,y1,z1,qqq : double;
 begin
   NN:=NN+1;
   x1:=xx(x);
   y1:=yy(x);
   z1:=zz(x);

   {         ‡ ¤ вм дг­ЄжЁо !!!!      }


   qqq:=10*x1*x1*sqr(sqr(x1))-20*y1*sqr(x1)*x1+10*sqr(y1)+
   sqr(x1)-2*x1+2*sqr(z1);

   If bbb then writeln(f,'nnN= ',NN,' ',x1:10:8,' ',y1:10:8,' ',
   z1:10:8, ' R= ',qqq);
   q:=qqq;
  end;
begin
  if nn=0 then begin bbb:=True; writeln(f,'Џ® ­ Їа ў«Ґ­Ёо Ё§ X0 :')
               end
          else bbb:=False;
  h:=0.6;
    aa:=0 ;
  bb:=aa+h ;
  RR1:=Q(aa) ;
  RR2:=Q(bb) ;
  if ipr=1 then begin
  if RR1<RR2 then
  begin
    h:=-h ;  cc:=aa ;
    aa:=bb ; bb:=cc ;     RR3:=RR1 ;
    RR1:=RR2 ;  RR2:=RR3 ;
  end ;
  RR3:=Q(bb+h) ;
  while RR3<=RR2 do
  begin
    aa:=bb ;
    bb:=aa+h ;
    RR2:=RR3 ;
    RR3:=Q(bb+h) ;
  end ;
  bb:=bb+h ;
  if aa>bb then
  begin
    c:=aa ;
    aa:=bb ;
    bb:=c ;
  end ;
  end;

  if ipr=0 then begin
  if RR1>RR2 then begin
  RR3:=Q(bb+h) ;
  while RR3 <= RR2 do
  begin
    aa:=bb ;
    bb:=aa+h ;
    RR2:=RR3 ;
    RR3:=Q(bb+h) ;
  end ;
  bb:=bb+h;
    end;
    end;

       {-------------- ”€ЃЋЌЂ——€ ---------------}
 f1[0]:=1;
 f1[1]:=1;
 i:=1;
 while  (bb-aa)/eps1>f1[i] do begin
 i:=i+1;
 f1[i]:=f1[i-1]+f1[i-2];
 end;
    lyambda:=aa+f1[i-2]*(bb-aa)/f1[i] ;
    myu:=aa+f1[i-1]*(bb-aa)/f1[i] ;
    RR1:=Q(lyambda) ;
    RR2:=Q(myu) ;

 for k:=i-1 downto 2 do
  begin
    if RR1<=RR2 then begin
               bb:=myu ;
               myu:=lyambda;
                rr2:=rr1;
                lyambda:=aa+f1[k-2]*(bb-aa)/f1[k] ;
                rr1:=q(lyambda);
                end
               else   begin
               aa:=lyambda;
               lyambda:=myu;
               RR1:=RR2;

               myu:=aa+f1[k-1]*(bb-aa)/f1[k] ;
               rr2:=q(myu);
               end;
  end ;
  lyambda:=aa/2+bb/2;
end ;


     {  - Gradient !!!! }

   procedure grad ( x : vector ) ;
 begin
   d.x:=-(60*sqr(sqr(x.x))*x.x-60*sqr(x.x)*x.y+2*x.x-2);
   d.y:=-(-20*x.x*x.x*x.x+20*x.y);
   d.z:=-(2*x.z);
    end ;

  procedure rasp(x:vector);
  begin
    func:=10*sqr(sqr(x.x))*x.x*x.x-20*x.y*sqr(x.x)*x.x+
    10*sqr(x.y)+sqr(x.x)-2*x.x+2*sqr(x.z);

    nn:=nn+1;
    writeln(f,'N ',NN:4,' ',x.x:8:6,' ',x.y:8:6,'  R=',func);
    writeln(NN:4,' ',x.x:10:8,' ',x.y:10:8,' ',x.z:10:8,'   R=',func);
  end;



 procedure step1;
 begin
  grad(xk);
    ipr:=0;
   norm(d);
    mono(xk);
    Plus(y[j],xk,lyambda,d);
    rasp(y[j]);
   end;


   procedure step2;
 begin
  grad(y[j]);
     ipr:=0;
       norm(d);
    mono(y[j]);
    Plus(z[j],y[j],lyambda,d);
    rasp(z[j]);
   end;

   procedure step3;
 begin
  d.x:=z[j].x-y[j-1].x;
  d.y:=z[j].y-y[j-1].y;
  d.z:=z[j].z-y[j-1].z;
    ipr:=1;
    norm(d);
    mono(z[j]);
    Plus(y[j+1],z[j],lyambda,d);
    rasp(y[j+1]);
   end;


begin
 NN:=0;
 assign(f,'parcas.rez');
 rewrite(f);
 Clrscr;
 Init(xk,-3,-4,2);
 y[0]:=xk;
 k:=1;
 j:=1;
 n:=3;
 repeat

 step1;
 while j<=n do
 begin
   step2;
   step3;
   j:=j+1;
 end;

   xk1:=y[n+1];

   ddist:=dist(xk,xk1);
   xk:=xk1;k:=k+1;j:=1;y[0]:=xk1;
  Until ddist<eps;
  close(f);
  writeln(nn) ;
  writeln('R= ',func) ;
end.
          
Comments: