share/lbfgs/sdrive.lisp

   1 ;;; Compiled by f2cl version 2.0 beta Date: 2006/01/11 22:57:58
   2 ;;; Using Lisp SBCL 0.9.9
   3 ;;;
   4 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
   5 ;;;           (:coerce-assigns :as-needed) (:array-type ':array)
   6 ;;;           (:array-slicing t) (:declare-common nil)
   7 ;;;           (:float-format single-float))
   8
   9 (in-package :common-lisp-user)
  10
  11
  12 (defun fgcompute (f g x n)
  13   (declare (type f2cl-lib:integer4 n)
  14            (type (array double-float (*)) x g)
  15            (type double-float f))
  16   (f2cl-lib:with-multi-array-data
  17       ((g double-float g-%data% g-%offset%)
  18        (x double-float x-%data% x-%offset%))
  19     (prog ((t1 0.0d0) (t2 0.0d0) (j 0))
  20       (declare (type f2cl-lib:integer4 j) (type double-float t2 t1))
  21       (setf f 0.0d0)
  22       (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 2))
  23                     ((> j n) nil)
  24         (tagbody
  25           (setf t1 (- 1.0d0 (f2cl-lib:fref x-%data% (j) ((1 n)) x-%offset%)))
  26           (setf t2
  27                   (* 10.0d0
  28                      (-
  29                       (f2cl-lib:fref x-%data%
  30                                      ((f2cl-lib:int-add j 1))
  31                                      ((1 n))
  32                                      x-%offset%)
  33                       (expt (f2cl-lib:fref x-%data% (j) ((1 n)) x-%offset%)
  34                             2))))
  35           (f2cl-lib:fset
  36            (f2cl-lib:fref g-%data% ((f2cl-lib:int-add j 1)) ((1 n)) g-%offset%)
  37            (* 20.0d0 t2))
  38           (f2cl-lib:fset (f2cl-lib:fref g-%data% (j) ((1 n)) g-%offset%)
  39                          (* -2.0d0
  40                             (+
  41                              (* (f2cl-lib:fref x-%data% (j) ((1 n)) x-%offset%)
  42                                 (f2cl-lib:fref g-%data%
  43                                                ((f2cl-lib:int-add j 1))
  44                                                ((1 n))
  45                                                g-%offset%))
  46                              t1)))
  47           (setf f (+ f (expt t1 2) (expt t2 2)))
  48          label30))
  49       (go end_label)
  50      end_label
  51       (return (values f nil nil nil)))))
  52
  53 ;;; Compiled by f2cl version 2.0 beta Date: 2006/01/11 22:57:58
  54 ;;; Using Lisp SBCL 0.9.9
  55 ;;;
  56 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  57 ;;;           (:coerce-assigns :as-needed) (:array-type ':array)
  58 ;;;           (:array-slicing t) (:declare-common nil)
  59 ;;;           (:float-format single-float))
  60
  61 (in-package :common-lisp-user)
  62
  63
  64 (let* ((ndim 2000)
  65        (msave 7)
  66        (nwork (+ (* ndim (+ (* 2 msave) 1)) (* 2 msave)))
  67        (nfevalmax 42))
  68   (declare (type f2cl-lib:integer4 ndim))
  69   (declare (type f2cl-lib:integer4 msave))
  70   (declare (type f2cl-lib:integer4 nwork))
  71   (declare (type f2cl-lib:integer4 nfevalmax))
  72   (defun sdrive ()
  73     (let ()
  74       (symbol-macrolet ((stpmax (lb3-stpmax *lb3-common-block*))
  75                         (stpmin (lb3-stpmin *lb3-common-block*))
  76                         (gtol (lb3-gtol *lb3-common-block*))
  77                         (lp (lb3-lp *lb3-common-block*))
  78                         (mp (lb3-mp *lb3-common-block*)))
  79         (f2cl-lib:with-multi-array-data
  80             nil
  81           (prog ((scache (make-array ndim :element-type 'double-float))
  82                  (w (make-array nwork :element-type 'double-float))
  83                  (diag (make-array ndim :element-type 'double-float))
  84                  (g (make-array ndim :element-type 'double-float))
  85                  (x (make-array ndim :element-type 'double-float)) (t2 0.0d0)
  86                  (t1 0.0d0) (xtol 0.0d0) (eps 0.0d0) (f 0.0d0) (j 0) (m 0)
  87                  (n 0) (icall 0) (iflag 0)
  88                  (iprint (make-array 2 :element-type 'f2cl-lib:integer4))
  89                  (diagco nil))
  90             (declare (type (array double-float (*)) scache w diag g x)
  91                      (type double-float t2 t1 xtol eps f)
  92                      (type f2cl-lib:integer4 j m n icall iflag)
  93                      (type (array f2cl-lib:integer4 (2)) iprint)
  94                      (type f2cl-lib:logical diagco))
  95             (setf n 100)
  96             (setf m 5)
  97             (f2cl-lib:fset (f2cl-lib:fref iprint (1) ((1 2))) 1)
  98             (f2cl-lib:fset (f2cl-lib:fref iprint (2) ((1 2))) 0)
  99             (setf diagco f2cl-lib:%false%)
 100             (setf eps 1.d-5)
 101             (setf xtol 1.d-16)
 102             (setf icall 0)
 103             (setf iflag 0)
 104             (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 2))
 105                           ((> j n) nil)
 106               (tagbody
 107                 (f2cl-lib:fset (f2cl-lib:fref x (j) ((1 ndim))) -1.2d0)
 108                 (f2cl-lib:fset
 109                  (f2cl-lib:fref x ((f2cl-lib:int-add j 1)) ((1 ndim)))
 110                  1.0d0)
 111                label10))
 112            label20
 113             (multiple-value-bind
 114                 (var-0 var-1 var-2 var-3)
 115                 (fgcompute f g x n)
 116               (declare (ignore var-1 var-2 var-3))
 117               (setf f var-0))
 118             (multiple-value-bind
 119                 (var-0 var-1
 120                        var-2
 121                        var-3
 122                        var-4
 123                        var-5
 124                        var-6
 125                        var-7
 126                        var-8
 127                        var-9
 128                        var-10
 129                        var-11
 130                        var-12)
 131                 (lbfgs n m x f g diagco diag iprint eps xtol w iflag scache)
 132               (declare
 133                (ignore var-2 var-4 var-5 var-6 var-7 var-8 var-10 var-12))
 134               (setf n var-0)
 135               (setf m var-1)
 136               (setf f var-3)
 137               (setf xtol var-9)
 138               (setf iflag var-11))
 139             (if (<= iflag 0) (go label50))
 140             (setf icall (f2cl-lib:int-add icall 1))
 141             (if (>= icall nfevalmax) (go label50))
 142             (go label20)
 143            label50
 144             (f2cl-lib:fformat 6
 145                               ("SEARCH TERMINATED AFTER " 1 (("~4D"))
 146                                " FUNCTION EVALUATIONS" " (LIMIT: " 1 (("~4D"))
 147                                ")" "~%" "CURRENT SOLUTION VECTOR: " "~%")
 148                               icall
 149                               nfevalmax)
 150             (f2cl-lib:fformat 6
 151                               (4 ("~2@T" 1 (("~22,15,2,1,'*,,'DE"))) "~%")
 152                               (do ((i 1 (f2cl-lib:int-add i 1))
 153                                    (ret nil
 154                                         (append ret
 155                                                 (list
 156                                                  (f2cl-lib:fref x
 157                                                                 (i)
 158                                                                 ((1 ndim)))))))
 159                                   ((> i n) ret)
 160                                 (declare (type f2cl-lib:integer4 i))))
 161             (f2cl-lib:fformat 6 ("SOLUTION CACHE: " "~%") nil)
 162             (f2cl-lib:fformat 6
 163                               (4 ("~2@T" 1 (("~22,15,2,1,'*,,'DE"))) "~%")
 164                               (do ((i 1 (f2cl-lib:int-add i 1))
 165                                    (ret nil
 166                                         (append ret
 167                                                 (list
 168                                                  (f2cl-lib:fref scache
 169                                                                 (i)
 170                                                                 ((1 ndim)))))))
 171                                   ((> i n) ret)
 172                                 (declare (type f2cl-lib:integer4 i))))
 173             (multiple-value-bind
 174                 (var-0 var-1 var-2 var-3)
 175                 (fgcompute f g x n)
 176               (declare (ignore var-1 var-2 var-3))
 177               (setf f var-0))
 178             (f2cl-lib:fformat 6
 179                               ("F(CURRENT SOLUTION VECTOR) = " 1
 180                                (("~22,15,2,1,'*,,'DE")) "~%")
 181                               f)
 182             (multiple-value-bind
 183                 (var-0 var-1 var-2 var-3)
 184                 (fgcompute f g scache n)
 185               (declare (ignore var-1 var-2 var-3))
 186               (setf f var-0))
 187             (f2cl-lib:fformat 6
 188                               ("F(SOLUTION CACHE) = " 1
 189                                (("~22,15,2,1,'*,,'DE")) "~%")
 190                               f)
 191            end_label
 192             (return nil)))))))
 193