share/lbfgs/mcstep.lisp

   1 ;;; Compiled by f2cl version:
   2 ;;; ("f2cl1.l,v 1.215 2009/04/07 22:05:21 rtoy Exp $"
   3 ;;;  "f2cl2.l,v 1.37 2008/02/22 22:19:33 rtoy Exp $"
   4 ;;;  "f2cl3.l,v 1.6 2008/02/22 22:19:33 rtoy Exp $"
   5 ;;;  "f2cl4.l,v 1.7 2008/02/22 22:19:34 rtoy Exp $"
   6 ;;;  "f2cl5.l,v 1.200 2009/01/19 02:38:17 rtoy Exp $"
   7 ;;;  "f2cl6.l,v 1.48 2008/08/24 00:56:27 rtoy Exp $"
   8 ;;;  "macros.l,v 1.112 2009/01/08 12:57:19 rtoy Exp $")
   9
  10 ;;; Using Lisp CMU Common Lisp 19f (19F)
  11 ;;;
  12 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  13 ;;;           (:coerce-assigns :as-needed) (:array-type ':array)
  14 ;;;           (:array-slicing t) (:declare-common nil)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package :common-lisp-user)
  18
  19
  20 (defun mcstep (stx fx dx sty fy dy stp fp dp brackt stpmin stpmax info)
  21   (declare (type (f2cl-lib:integer4) info)
  22            (type f2cl-lib:logical brackt)
  23            (type (double-float) stpmax stpmin dp fp stp dy fy sty dx fx stx))
  24   (prog ((gamma 0.0) (p 0.0) (q 0.0) (r 0.0) (s 0.0) (sgnd 0.0) (stpc 0.0)
  25          (stpf 0.0) (stpq 0.0) (theta 0.0) (bound nil))
  26     (declare (type f2cl-lib:logical bound)
  27              (type (double-float) theta stpq stpf stpc sgnd s r q p gamma))
  28     (setf info 0)
  29     (if
  30      (or (and brackt (or (<= stp (min stx sty)) (>= stp (max stx sty))))
  31          (>= (* dx (- stp stx)) 0.0)
  32          (< stpmax stpmin))
  33      (go end_label))
  34     (setf sgnd (* dp (/ dx (f2cl-lib:dabs dx))))
  35     (cond
  36       ((> fp fx)
  37        (setf info 1)
  38        (setf bound f2cl-lib:%true%)
  39        (setf theta (+ (/ (* 3 (- fx fp)) (- stp stx)) dx dp))
  40        (setf s
  41                (max (f2cl-lib:dabs theta)
  42                     (f2cl-lib:dabs dx)
  43                     (f2cl-lib:dabs dp)))
  44        (setf gamma
  45                (* s
  46                   (f2cl-lib:dsqrt
  47                    (- (expt (/ theta s) 2) (* (/ dx s) (/ dp s))))))
  48        (if (< stp stx) (setf gamma (- gamma)))
  49        (setf p (+ (- gamma dx) theta))
  50        (setf q (+ (- gamma dx) gamma dp))
  51        (setf r (/ p q))
  52        (setf stpc (+ stx (* r (- stp stx))))
  53        (setf stpq
  54                (+ stx
  55                   (* (/ (/ dx (+ (/ (- fx fp) (- stp stx)) dx)) 2)
  56                      (- stp stx))))
  57        (cond
  58          ((< (f2cl-lib:dabs (+ stpc (- stx))) (f2cl-lib:dabs (+ stpq (- stx))))
  59           (setf stpf stpc))
  60          (t
  61           (setf stpf (+ stpc (/ (- stpq stpc) 2)))))
  62        (setf brackt f2cl-lib:%true%))
  63       ((< sgnd 0.0)
  64        (setf info 2)
  65        (setf bound f2cl-lib:%false%)
  66        (setf theta (+ (/ (* 3 (- fx fp)) (- stp stx)) dx dp))
  67        (setf s
  68                (max (f2cl-lib:dabs theta)
  69                     (f2cl-lib:dabs dx)
  70                     (f2cl-lib:dabs dp)))
  71        (setf gamma
  72                (* s
  73                   (f2cl-lib:dsqrt
  74                    (- (expt (/ theta s) 2) (* (/ dx s) (/ dp s))))))
  75        (if (> stp stx) (setf gamma (- gamma)))
  76        (setf p (+ (- gamma dp) theta))
  77        (setf q (+ (- gamma dp) gamma dx))
  78        (setf r (/ p q))
  79        (setf stpc (+ stp (* r (- stx stp))))
  80        (setf stpq (+ stp (* (/ dp (- dp dx)) (- stx stp))))
  81        (cond
  82          ((> (f2cl-lib:dabs (+ stpc (- stp))) (f2cl-lib:dabs (+ stpq (- stp))))
  83           (setf stpf stpc))
  84          (t
  85           (setf stpf stpq)))
  86        (setf brackt f2cl-lib:%true%))
  87       ((< (f2cl-lib:dabs dp) (f2cl-lib:dabs dx))
  88        (setf info 3)
  89        (setf bound f2cl-lib:%true%)
  90        (setf theta (+ (/ (* 3 (- fx fp)) (- stp stx)) dx dp))
  91        (setf s
  92                (max (f2cl-lib:dabs theta)
  93                     (f2cl-lib:dabs dx)
  94                     (f2cl-lib:dabs dp)))
  95        (setf gamma
  96                (* s
  97                   (f2cl-lib:dsqrt
  98                    (max 0.0 (- (expt (/ theta s) 2) (* (/ dx s) (/ dp s)))))))
  99        (if (> stp stx) (setf gamma (- gamma)))
 100        (setf p (+ (- gamma dp) theta))
 101        (setf q (+ gamma (- dx dp) gamma))
 102        (setf r (/ p q))
 103        (cond
 104          ((and (< r 0.0) (/= gamma 0.0))
 105           (setf stpc (+ stp (* r (- stx stp)))))
 106          ((> stp stx)
 107           (setf stpc stpmax))
 108          (t
 109           (setf stpc stpmin)))
 110        (setf stpq (+ stp (* (/ dp (- dp dx)) (- stx stp))))
 111        (cond
 112          (brackt
 113           (cond
 114             ((< (f2cl-lib:dabs (+ stp (- stpc)))
 115                 (f2cl-lib:dabs (+ stp (- stpq))))
 116              (setf stpf stpc))
 117             (t
 118              (setf stpf stpq))))
 119          (t
 120           (cond
 121             ((> (f2cl-lib:dabs (+ stp (- stpc)))
 122                 (f2cl-lib:dabs (+ stp (- stpq))))
 123              (setf stpf stpc))
 124             (t
 125              (setf stpf stpq))))))
 126       (t
 127        (setf info 4)
 128        (setf bound f2cl-lib:%false%)
 129        (cond
 130          (brackt
 131           (setf theta (+ (/ (* 3 (- fp fy)) (- sty stp)) dy dp))
 132           (setf s
 133                   (max (f2cl-lib:dabs theta)
 134                        (f2cl-lib:dabs dy)
 135                        (f2cl-lib:dabs dp)))
 136           (setf gamma
 137                   (* s
 138                      (f2cl-lib:dsqrt
 139                       (- (expt (/ theta s) 2) (* (/ dy s) (/ dp s))))))
 140           (if (> stp sty) (setf gamma (- gamma)))
 141           (setf p (+ (- gamma dp) theta))
 142           (setf q (+ (- gamma dp) gamma dy))
 143           (setf r (/ p q))
 144           (setf stpc (+ stp (* r (- sty stp))))
 145           (setf stpf stpc))
 146          ((> stp stx)
 147           (setf stpf stpmax))
 148          (t
 149           (setf stpf stpmin)))))
 150     (cond
 151       ((> fp fx)
 152        (setf sty stp)
 153        (setf fy fp)
 154        (setf dy dp))
 155       (t
 156        (cond
 157          ((< sgnd 0.0)
 158           (setf sty stx)
 159           (setf fy fx)
 160           (setf dy dx)))
 161        (setf stx stp)
 162        (setf fx fp)
 163        (setf dx dp)))
 164     (setf stpf (min stpmax stpf))
 165     (setf stpf (max stpmin stpf))
 166     (setf stp stpf)
 167     (cond
 168       ((and brackt bound)
 169        (cond
 170          ((> sty stx)
 171           (setf stp (min (+ stx (* 0.66 (- sty stx))) stp)))
 172          (t
 173           (setf stp (max (+ stx (* 0.66 (- sty stx))) stp))))))
 174     (go end_label)
 175    end_label
 176     (return (values stx fx dx sty fy dy stp nil nil brackt nil nil info))))
 177
 178 (in-package #:cl-user)
 179 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 180 (eval-when (:load-toplevel :compile-toplevel :execute)
 181   (setf (gethash 'fortran-to-lisp::mcstep
 182                  fortran-to-lisp::*f2cl-function-info*)
 183           (fortran-to-lisp::make-f2cl-finfo
 184            :arg-types '((double-float) (double-float) (double-float)
 185                         (double-float) (double-float) (double-float)
 186                         (double-float) (double-float) (double-float)
 187                         fortran-to-lisp::logical (double-float) (double-float)
 188                         (fortran-to-lisp::integer4))
 189            :return-values '(fortran-to-lisp::stx fortran-to-lisp::fx
 190                             fortran-to-lisp::dx fortran-to-lisp::sty
 191                             fortran-to-lisp::fy fortran-to-lisp::dy
 192                             fortran-to-lisp::stp nil nil
 193                             fortran-to-lisp::brackt nil nil
 194                             fortran-to-lisp::info)
 195            :calls 'nil)))
 196