home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / NRPAS13.ZIP / GOLDEN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-29  |  1.0 KB  |  47 lines
  1. FUNCTION golden(ax,bx,cx,tol: real; VAR xmin: real): real;
  2. (* Programs using routine GOLDEN must supply an external
  3. function func(x:real):real whose minimum is to be found. *)
  4. CONST
  5.    r=0.61803399;
  6. VAR
  7.    f0,f1,f2,f3,c: real;
  8.    x0,x1,x2,x3: real;
  9. BEGIN
  10.    c := 1.0-r;
  11.    x0 := ax;
  12.    x3 := cx;
  13.    IF (abs(cx-bx) > abs(bx-ax)) THEN BEGIN
  14.       x1 := bx;
  15.       x2 := bx+c*(cx-bx)
  16.    END ELSE BEGIN
  17.       x2 := bx;
  18.       x1 := bx-c*(bx-ax)
  19.    END;
  20.    f1 := func(x1);
  21.    f2 := func(x2);
  22.    WHILE (abs(x3-x0) > tol*(abs(x1)+abs(x2))) DO BEGIN
  23.       IF (f2 < f1) THEN BEGIN
  24.          x0 := x1;
  25.          x1 := x2;
  26.          x2 := r*x1+c*x3;
  27.          f0 := f1;
  28.          f1 := f2;
  29.          f2 := func(x2)
  30.       END ELSE BEGIN
  31.          x3 := x2;
  32.          x2 := x1;
  33.          x1 := r*x2+c*x0;
  34.          f3 := f2;
  35.          f2 := f1;
  36.          f1 := func(x1)
  37.       END
  38.    END;
  39.    IF (f1 < f2) THEN BEGIN
  40.       golden := f1;
  41.       xmin := x1
  42.    END ELSE BEGIN
  43.       golden := f2;
  44.       xmin := x2
  45.    END
  46. END;
  47.