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 $")
10 ;;; Using Lisp CMU Common Lisp 19f (19F)
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))
17 (in-package :common-lisp-user
)
48 (declare (type f2cl-lib
:logical finish
)
49 (type (f2cl-lib:integer4
) iter nfun point ispt iypt maxfev info
50 bound npt cp i nfev inmc iycn iscn
)
51 (type (double-float) one zero gnorm stp1 ftol stp ys yy sq yr beta
53 (defun lbfgs (n m x f g diagco diag iprint eps xtol w iflag scache
)
54 (declare (type (array f2cl-lib
:integer4
(*)) iprint
)
55 (type f2cl-lib
:logical diagco
)
56 (type (double-float) xtol eps f
)
57 (type (array double-float
(*)) scache w diag g x
)
58 (type (f2cl-lib:integer4
) iflag m n
))
60 (symbol-macrolet ((gtol (lb3-gtol *lb3-common-block
*))
61 (lp (lb3-lp *lb3-common-block
*)))
62 (f2cl-lib:with-multi-array-data
63 ((x double-float x-%data% x-%offset%
)
64 (g double-float g-%data% g-%offset%
)
65 (diag double-float diag-%data% diag-%offset%
)
66 (w double-float w-%data% w-%offset%
)
67 (scache double-float scache-%data% scache-%offset%
)
68 (iprint f2cl-lib
:integer4 iprint-%data% iprint-%offset%
))
71 (if (= iflag
0) (go label10
))
72 (f2cl-lib:computed-goto
(label172 label100
) iflag
)
75 (if (or (<= n
0) (<= m
0)) (go label196
))
81 " GTOL IS LESS THAN OR EQUAL TO 1.D-04"
82 "~%" " IT HAS BEEN RESET TO 9.D-01"
87 (setf finish f2cl-lib
:%false%
)
90 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
95 (<= (f2cl-lib:fref diag-%data%
(i) ((1 n
)) diag-%offset%
)
99 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
103 (setf (f2cl-lib:fref diag-%data%
(i) ((1 n
)) diag-%offset%
)
105 (setf ispt
(f2cl-lib:int-add n
(f2cl-lib:int-mul
2 m
)))
106 (setf iypt
(f2cl-lib:int-add ispt
(f2cl-lib:int-mul n m
)))
107 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
111 (setf (f2cl-lib:fref w-%data%
112 ((f2cl-lib:int-add ispt i
))
120 (f2cl-lib:int-mul
2 m
))))
122 (* (- (f2cl-lib:fref g-%data%
(i) ((1 n
)) g-%offset%
))
123 (f2cl-lib:fref diag-%data%
130 (ret-val var-0 var-1 var-2 var-3 var-4
)
132 (declare (ignore var-1 var-2 var-3 var-4
))
136 (setf stp1
(/ one gnorm
))
140 (>= (f2cl-lib:fref iprint-%data%
(1) ((1 2)) iprint-%offset%
) 0)
141 (lb1 iprint iter nfun gnorm n m x f g stp finish
))
143 (setf iter
(f2cl-lib:int-add iter
1))
145 (setf bound
(f2cl-lib:int-sub iter
1))
146 (if (= iter
1) (go label165
))
147 (if (> iter m
) (setf bound m
))
150 (ret-val var-0 var-1 var-2 var-3 var-4
)
152 (f2cl-lib:array-slice w
163 (f2cl-lib:int-mul
2 m
)))))
165 (f2cl-lib:array-slice w
176 (f2cl-lib:int-mul
2 m
)))))
178 (declare (ignore var-1 var-2 var-3 var-4
))
186 (ret-val var-0 var-1 var-2 var-3 var-4
)
188 (f2cl-lib:array-slice w
199 (f2cl-lib:int-mul
2 m
)))))
201 (f2cl-lib:array-slice w
212 (f2cl-lib:int-mul
2 m
)))))
214 (declare (ignore var-1 var-2 var-3 var-4
))
218 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
222 (setf (f2cl-lib:fref diag-%data%
(i) ((1 n
)) diag-%offset%
)
230 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
235 (<= (f2cl-lib:fref diag-%data%
(i) ((1 n
)) diag-%offset%
)
239 (if (= point
0) (setf cp m
))
240 (setf (f2cl-lib:fref w-%data%
241 ((f2cl-lib:int-add n cp
))
246 (f2cl-lib:int-mul
2 m
)
248 (f2cl-lib:int-mul
2 m
))))
251 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
255 (setf (f2cl-lib:fref w-%data%
264 (f2cl-lib:int-mul
2 m
))))
266 (- (f2cl-lib:fref g-%data%
(i) ((1 n
)) g-%offset%
)))))
268 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
271 (setf cp
(f2cl-lib:int-sub cp
1))
272 (if (= cp -
1) (setf cp
(f2cl-lib:int-sub m
1)))
275 (ret-val var-0 var-1 var-2 var-3 var-4
)
277 (f2cl-lib:array-slice w
280 (f2cl-lib:int-mul cp n
)
293 (declare (ignore var-1 var-2 var-3 var-4
))
297 (setf inmc
(f2cl-lib:int-add n m cp
1))
298 (setf iycn
(f2cl-lib:int-add iypt
(f2cl-lib:int-mul cp n
)))
299 (setf (f2cl-lib:fref w-%data%
308 (f2cl-lib:int-mul
2 m
))))
311 (f2cl-lib:fref w-%data%
312 ((f2cl-lib:int-add n cp
1))
321 (f2cl-lib:int-mul
2 m
))))
324 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5
)
327 (f2cl-lib:fref w-%data%
336 (f2cl-lib:int-mul
2 m
))))
338 (f2cl-lib:array-slice w
349 (f2cl-lib:int-mul
2 m
)))))
351 (declare (ignore var-1 var-2 var-3 var-4 var-5
))
355 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
359 (setf (f2cl-lib:fref w-%data%
368 (f2cl-lib:int-mul
2 m
))))
371 (f2cl-lib:fref diag-%data%
(i) ((1 n
)) diag-%offset%
)
372 (f2cl-lib:fref w-%data%
382 (f2cl-lib:int-mul
2 m
))))
384 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
389 (ret-val var-0 var-1 var-2 var-3 var-4
)
391 (f2cl-lib:array-slice w
394 (f2cl-lib:int-mul cp n
)
407 (declare (ignore var-1 var-2 var-3 var-4
))
413 (f2cl-lib:fref w-%data%
414 ((f2cl-lib:int-add n cp
1))
423 (f2cl-lib:int-mul
2 m
))))
426 (setf inmc
(f2cl-lib:int-add n m cp
1))
429 (f2cl-lib:fref w-%data%
439 (f2cl-lib:int-mul
2 m
))))
442 (setf iscn
(f2cl-lib:int-add ispt
(f2cl-lib:int-mul cp n
)))
443 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5
)
445 (f2cl-lib:array-slice w
456 (f2cl-lib:int-mul
2 m
)))))
458 (declare (ignore var-2 var-3 var-4 var-5
))
463 (setf cp
(f2cl-lib:int-add cp
1))
464 (if (= cp m
) (setf cp
0))
466 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
470 (setf (f2cl-lib:fref w-%data%
471 ((f2cl-lib:int-add ispt
472 (f2cl-lib:int-mul point
482 (f2cl-lib:int-mul
2 m
))))
484 (f2cl-lib:fref w-%data%
494 (f2cl-lib:int-mul
2 m
))))
499 (if (= iter
1) (setf stp stp1
))
500 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
504 (setf (f2cl-lib:fref w-%data%
513 (f2cl-lib:int-mul
2 m
))))
515 (f2cl-lib:fref g-%data%
(i) ((1 n
)) g-%offset%
))))
518 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
521 (f2cl-lib:array-slice w
523 ((+ ispt
(f2cl-lib:int-mul point n
) 1))
532 (f2cl-lib:int-mul
2 m
)))))
533 stp ftol xtol maxfev info nfev diag
)
534 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-6 var-7 var-8
540 ((= info
(f2cl-lib:int-sub
1))
543 (if (/= info
1) (go label190
))
544 (setf nfun
(f2cl-lib:int-add nfun nfev
))
545 (setf npt
(f2cl-lib:int-mul point n
))
546 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
549 (setf (f2cl-lib:fref w-%data%
550 ((f2cl-lib:int-add ispt npt i
))
558 (f2cl-lib:int-mul
2 m
))))
561 (f2cl-lib:fref w-%data%
562 ((f2cl-lib:int-add ispt npt i
))
571 (f2cl-lib:int-mul
2 m
))))
574 (setf (f2cl-lib:fref w-%data%
575 ((f2cl-lib:int-add iypt npt i
))
583 (f2cl-lib:int-mul
2 m
))))
585 (- (f2cl-lib:fref g-%data%
(i) ((1 n
)) g-%offset%
)
586 (f2cl-lib:fref w-%data%
596 (f2cl-lib:int-mul
2 m
))))
598 (setf point
(f2cl-lib:int-add point
1))
599 (if (= point m
) (setf point
0))
603 (ret-val var-0 var-1 var-2 var-3 var-4
)
605 (declare (ignore var-1 var-2 var-3 var-4
))
612 (ret-val var-0 var-1 var-2 var-3 var-4
)
614 (declare (ignore var-1 var-2 var-3 var-4
))
618 (setf xnorm
(f2cl-lib:dmax1
1.0 xnorm
))
619 (if (<= (/ gnorm xnorm
) eps
) (setf finish f2cl-lib
:%true%
))
621 (>= (f2cl-lib:fref iprint-%data%
(1) ((1 2)) iprint-%offset%
) 0)
622 (lb1 iprint iter nfun gnorm n m x f g stp finish
))
623 (f2cl-lib:fdo
(i 1 (f2cl-lib:int-add i
1))
626 (setf (f2cl-lib:fref scache-%data%
(i) ((1 n
)) scache-%offset%
)
627 (f2cl-lib:fref x-%data%
(i) ((1 n
)) x-%offset%
))
638 ("~%" " IFLAG= -1 " "~%"
639 " LINE SEARCH FAILED. SEE"
640 " DOCUMENTATION OF ROUTINE MCSRCH" "~%"
641 " ERROR RETURN" " OF LINE SEARCH: INFO= " 1
643 " POSSIBLE CAUSES: FUNCTION OR GRADIENT ARE INCORRECT"
644 "~%" " OR INCORRECT TOLERANCES" "~%")
651 ("~%" " IFLAG= -2" "~%" " THE" 1 (("~5D"))
652 "-TH DIAGONAL ELEMENT OF THE" "~%"
653 " INVERSE HESSIAN APPROXIMATION IS NOT POSITIVE"
661 ("~%" " IFLAG= -3" "~%"
662 " IMPROPER INPUT PARAMETERS (N OR M"
663 " ARE NOT POSITIVE)" "~%")))
667 (values n nil nil nil nil nil nil nil nil nil nil iflag nil
))))))))
669 (in-package #:cl-user
)
670 #+#.
(cl:if
(cl:find-package
'#:f2cl
) '(and) '(or))
671 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
672 (setf (gethash 'fortran-to-lisp
::lbfgs fortran-to-lisp
::*f2cl-function-info
*)
673 (fortran-to-lisp::make-f2cl-finfo
674 :arg-types
'((fortran-to-lisp::integer4
) (fortran-to-lisp::integer4
)
675 (array double-float
(*)) (double-float)
676 (array double-float
(*)) fortran-to-lisp
::logical
677 (array double-float
(*))
678 (array fortran-to-lisp
::integer4
(2)) (double-float)
679 (double-float) (array double-float
(*))
680 (fortran-to-lisp::integer4
) (array double-float
(*)))
681 :return-values
'(fortran-to-lisp::n nil nil nil nil nil nil nil nil
682 nil nil fortran-to-lisp
::iflag nil
)
683 :calls
'(fortran-to-lisp::mcsrch fortran-to-lisp
::lb1
))))