share/lbfgs/mcsrch.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 (let ((dg 0.0)
  21       (dgm 0.0)
  22       (dginit 0.0)
  23       (dgtest 0.0)
  24       (dgx 0.0)
  25       (dgxm 0.0)
  26       (dgy 0.0)
  27       (dgym 0.0)
  28       (finit 0.0)
  29       (ftest1 0.0)
  30       (fm 0.0)
  31       (fx 0.0)
  32       (fxm 0.0)
  33       (fy 0.0)
  34       (fym 0.0)
  35       (p5 0.5)
  36       (p66 0.66)
  37       (stx 0.0)
  38       (sty 0.0)
  39       (stmin 0.0)
  40       (stmax 0.0)
  41       (width 0.0)
  42       (width1 0.0)
  43       (xtrapf 4.0)
  44       (zero 0.0)
  45       (brackt nil)
  46       (stage1 nil)
  47       (infoc 0)
  48       (j 0))
  49   (declare (type (double-float) dg dgm dginit dgtest dgx dgxm dgy dgym finit
  50                                 ftest1 fm fx fxm fy fym p5 p66 stx sty stmin
  51                                 stmax width width1 xtrapf zero)
  52            (type f2cl-lib:logical brackt stage1)
  53            (type (f2cl-lib:integer4) infoc j))
  54   (defun mcsrch (n x f g s stp ftol xtol maxfev info nfev wa)
  55     (declare (type (double-float) xtol ftol stp f)
  56              (type (array double-float (*)) wa s g x)
  57              (type (f2cl-lib:integer4) nfev info maxfev n))
  58     (let ()
  59       (symbol-macrolet ((stpmax (lb3-stpmax *lb3-common-block*))
  60                         (stpmin (lb3-stpmin *lb3-common-block*))
  61                         (gtol (lb3-gtol *lb3-common-block*))
  62                         (lp (lb3-lp *lb3-common-block*)))
  63         (f2cl-lib:with-multi-array-data
  64             ((x double-float x-%data% x-%offset%)
  65              (g double-float g-%data% g-%offset%)
  66              (s double-float s-%data% s-%offset%)
  67              (wa double-float wa-%data% wa-%offset%))
  68           (prog ()
  69             (declare)
  70             (if (= info -1) (go label45))
  71             (setf infoc 1)
  72             (if
  73              (or (<= n 0)
  74                  (<= stp zero)
  75                  (< ftol zero)
  76                  (< gtol zero)
  77                  (< xtol zero)
  78                  (< stpmin zero)
  79                  (< stpmax stpmin)
  80                  (<= maxfev 0))
  81              (go end_label))
  82             (setf dginit zero)
  83             (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  84                           ((> j n) nil)
  85               (tagbody
  86                 (setf dginit
  87                         (+ dginit
  88                            (* (f2cl-lib:fref g-%data% (j) ((1 n)) g-%offset%)
  89                               (f2cl-lib:fref s-%data%
  90                                              (j)
  91                                              ((1 n))
  92                                              s-%offset%))))
  93                label10))
  94             (cond
  95               ((>= dginit zero)
  96                (f2cl-lib:fformat lp
  97                                  ("~%"
  98                                   "  THE SEARCH DIRECTION IS NOT A DESCENT DIRECTION"
  99                                   "~%"))
 100                (go end_label)))
 101             (setf brackt f2cl-lib:%false%)
 102             (setf stage1 f2cl-lib:%true%)
 103             (setf nfev 0)
 104             (setf finit f)
 105             (setf dgtest (* ftol dginit))
 106             (setf width (- stpmax stpmin))
 107             (setf width1 (/ width p5))
 108             (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 109                           ((> j n) nil)
 110               (tagbody
 111                 (setf (f2cl-lib:fref wa-%data% (j) ((1 n)) wa-%offset%)
 112                         (f2cl-lib:fref x-%data% (j) ((1 n)) x-%offset%))
 113                label20))
 114             (setf stx zero)
 115             (setf fx finit)
 116             (setf dgx dginit)
 117             (setf sty zero)
 118             (setf fy finit)
 119             (setf dgy dginit)
 120            label30
 121             (cond
 122               (brackt
 123                (setf stmin (min stx sty))
 124                (setf stmax (max stx sty)))
 125               (t
 126                (setf stmin stx)
 127                (setf stmax (+ stp (* xtrapf (- stp stx))))))
 128             (setf stp (max stp stpmin))
 129             (setf stp (min stp stpmax))
 130             (if
 131              (or (and brackt (or (<= stp stmin) (>= stp stmax)))
 132                  (>= nfev (f2cl-lib:int-sub maxfev 1))
 133                  (= infoc 0)
 134                  (and brackt (<= (- stmax stmin) (* xtol stmax))))
 135              (setf stp stx))
 136             (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 137                           ((> j n) nil)
 138               (tagbody
 139                 (setf (f2cl-lib:fref x-%data% (j) ((1 n)) x-%offset%)
 140                         (+ (f2cl-lib:fref wa-%data% (j) ((1 n)) wa-%offset%)
 141                            (* stp
 142                               (f2cl-lib:fref s-%data%
 143                                              (j)
 144                                              ((1 n))
 145                                              s-%offset%))))
 146                label40))
 147             (setf info -1)
 148             (go end_label)
 149            label45
 150             (setf info 0)
 151             (setf nfev (f2cl-lib:int-add nfev 1))
 152             (setf dg zero)
 153             (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 154                           ((> j n) nil)
 155               (tagbody
 156                 (setf dg
 157                         (+ dg
 158                            (* (f2cl-lib:fref g-%data% (j) ((1 n)) g-%offset%)
 159                               (f2cl-lib:fref s-%data%
 160                                              (j)
 161                                              ((1 n))
 162                                              s-%offset%))))
 163                label50))
 164             (setf ftest1 (+ finit (* stp dgtest)))
 165             (if
 166              (or (and brackt (or (<= stp stmin) (>= stp stmax))) (= infoc 0))
 167              (setf info 6))
 168             (if (and (= stp stpmax) (<= f ftest1) (<= dg dgtest))
 169                 (setf info 5))
 170             (if (and (= stp stpmin) (or (> f ftest1) (>= dg dgtest)))
 171                 (setf info 4))
 172             (if (>= nfev maxfev) (setf info 3))
 173             (if (and brackt (<= (- stmax stmin) (* xtol stmax))) (setf info 2))
 174             (if (and (<= f ftest1) (<= (f2cl-lib:dabs dg) (* gtol (- dginit))))
 175                 (setf info 1))
 176             (if (/= info 0) (go end_label))
 177             (if (and stage1 (<= f ftest1) (>= dg (* (min ftol gtol) dginit)))
 178                 (setf stage1 f2cl-lib:%false%))
 179             (cond
 180               ((and stage1 (<= f fx) (> f ftest1))
 181                (setf fm (- f (* stp dgtest)))
 182                (setf fxm (- fx (* stx dgtest)))
 183                (setf fym (- fy (* sty dgtest)))
 184                (setf dgm (- dg dgtest))
 185                (setf dgxm (- dgx dgtest))
 186                (setf dgym (- dgy dgtest))
 187                (multiple-value-bind
 188                      (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
 189                       var-9 var-10 var-11 var-12)
 190                    (mcstep stx fxm dgxm sty fym dgym stp fm dgm brackt stmin
 191                     stmax infoc)
 192                  (declare (ignore var-7 var-8 var-10 var-11))
 193                  (setf stx var-0)
 194                  (setf fxm var-1)
 195                  (setf dgxm var-2)
 196                  (setf sty var-3)
 197                  (setf fym var-4)
 198                  (setf dgym var-5)
 199                  (setf stp var-6)
 200                  (setf brackt var-9)
 201                  (setf infoc var-12))
 202                (setf fx (+ fxm (* stx dgtest)))
 203                (setf fy (+ fym (* sty dgtest)))
 204                (setf dgx (+ dgxm dgtest))
 205                (setf dgy (+ dgym dgtest)))
 206               (t
 207                (multiple-value-bind
 208                      (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
 209                       var-9 var-10 var-11 var-12)
 210                    (mcstep stx fx dgx sty fy dgy stp f dg brackt stmin stmax
 211                     infoc)
 212                  (declare (ignore var-7 var-8 var-10 var-11))
 213                  (setf stx var-0)
 214                  (setf fx var-1)
 215                  (setf dgx var-2)
 216                  (setf sty var-3)
 217                  (setf fy var-4)
 218                  (setf dgy var-5)
 219                  (setf stp var-6)
 220                  (setf brackt var-9)
 221                  (setf infoc var-12))))
 222             (cond
 223               (brackt
 224                (if (>= (f2cl-lib:dabs (- sty stx)) (* p66 width1))
 225                    (setf stp (+ stx (* p5 (- sty stx)))))
 226                (setf width1 width)
 227                (setf width (f2cl-lib:dabs (- sty stx)))))
 228             (go label30)
 229            end_label
 230             (return
 231              (values nil nil nil nil nil stp nil nil nil info nfev nil))))))))
 232
 233 (in-package #:cl-user)
 234 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 235 (eval-when (:load-toplevel :compile-toplevel :execute)
 236   (setf (gethash 'fortran-to-lisp::mcsrch
 237                  fortran-to-lisp::*f2cl-function-info*)
 238           (fortran-to-lisp::make-f2cl-finfo
 239            :arg-types '((fortran-to-lisp::integer4) (array double-float (*))
 240                         (double-float) (array double-float (*))
 241                         (array double-float (*)) (double-float) (double-float)
 242                         (double-float) (fortran-to-lisp::integer4)
 243                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 244                         (array double-float (*)))
 245            :return-values '(nil nil nil nil nil fortran-to-lisp::stp nil nil
 246                             nil fortran-to-lisp::info fortran-to-lisp::nfev
 247                             nil)
 248            :calls '(fortran-to-lisp::mcstep))))
 249