share/lbfgs/lb2.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 t)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package :common-lisp-user)
  18
  19
  20 (defstruct (lb3
  21              (:predicate is-lb3-p))
  22   (mp 0 :type (f2cl-lib:integer4))
  23   (lp 0 :type (f2cl-lib:integer4))
  24   (gtol 0.0 :type (double-float))
  25   (stpmin 0.0 :type (double-float))
  26   (stpmax 0.0 :type (double-float)))
  27
  28
  29 (defparameter *lb3-common-block*
  30   (let* ()
  31     (declare (ignorable))
  32     (make-lb3)))
  33
  34
  35 (defun /blockdata-lb2/ ()
  36   (let ()
  37     (symbol-macrolet ((stpmax (lb3-stpmax *lb3-common-block*))
  38                       (stpmin (lb3-stpmin *lb3-common-block*))
  39                       (gtol (lb3-gtol *lb3-common-block*))
  40                       (lp (lb3-lp *lb3-common-block*))
  41                       (mp (lb3-mp *lb3-common-block*)))
  42       (setf mp 6)
  43       (setf lp 6)
  44       (setf gtol 0.9)
  45       (setf stpmin 1.0e-20)
  46       (setf stpmax 1.0e20))))
  47
  48 (in-package #:cl-user)
  49 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
  50 (eval-when (:load-toplevel :compile-toplevel :execute)
  51   (setf (gethash 'fortran-to-lisp::/blockdata-lb2/
  52                  fortran-to-lisp::*f2cl-function-info*)
  53           (fortran-to-lisp::make-f2cl-finfo :arg-types 'nil
  54                                             :return-values 'nil
  55                                             :calls 'nil)))
  56