share/colnew/lisp/dgesl.lisp

   1 ;;; Compiled by f2cl version:
   2 ;;; ("f2cl1.l,v 1.221 2010/05/26 19:25:52 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.204 2010/02/23 05:21:30 rtoy Exp $"
   7 ;;;  "f2cl6.l,v 1.48 2008/08/24 00:56:27 rtoy Exp $"
   8 ;;;  "macros.l,v 1.114 2010/05/17 01:42:14 rtoy Exp $")
   9
  10 ;;; Using Lisp CMU Common Lisp CVS Head 2010-05-25 18:21:07 (20A Unicode)
  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 :colnew)
  18
  19
  20 (defun dgesl (a lda n ipvt b job)
  21   (declare (type (array double-float (*)) b)
  22            (type (array f2cl-lib:integer4 (*)) ipvt)
  23            (type (f2cl-lib:integer4) job n lda)
  24            (type (array double-float (*)) a))
  25   (f2cl-lib:with-multi-array-data
  26       ((a double-float a-%data% a-%offset%)
  27        (ipvt f2cl-lib:integer4 ipvt-%data% ipvt-%offset%)
  28        (b double-float b-%data% b-%offset%))
  29     (prog ((k 0) (kb 0) (l 0) (nm1 0) (t$ 0.0))
  30       (declare (type (double-float) t$) (type (f2cl-lib:integer4) nm1 l kb k))
  31       (setf nm1 (f2cl-lib:int-sub n 1))
  32       (if (/= job 0) (go label50))
  33       (if (< nm1 1) (go label30))
  34       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  35                     ((> k nm1) nil)
  36         (tagbody
  37           (setf l (f2cl-lib:fref ipvt-%data% (k) ((1 1)) ipvt-%offset%))
  38           (setf t$ (f2cl-lib:fref b-%data% (l) ((1 1)) b-%offset%))
  39           (if (= l k) (go label10))
  40           (setf (f2cl-lib:fref b-%data% (l) ((1 1)) b-%offset%)
  41                   (f2cl-lib:fref b-%data% (k) ((1 1)) b-%offset%))
  42           (setf (f2cl-lib:fref b-%data% (k) ((1 1)) b-%offset%) t$)
  43          label10
  44           (daxpy (f2cl-lib:int-sub n k) t$
  45            (f2cl-lib:array-slice a double-float ((+ k 1) k) ((1 lda) (1 1))) 1
  46            (f2cl-lib:array-slice b double-float ((+ k 1)) ((1 1))) 1)
  47          label20))
  48      label30
  49       (f2cl-lib:fdo (kb 1 (f2cl-lib:int-add kb 1))
  50                     ((> kb n) nil)
  51         (tagbody
  52           (setf k (f2cl-lib:int-sub (f2cl-lib:int-add n 1) kb))
  53           (setf (f2cl-lib:fref b-%data% (k) ((1 1)) b-%offset%)
  54                   (/ (f2cl-lib:fref b-%data% (k) ((1 1)) b-%offset%)
  55                      (f2cl-lib:fref a-%data%
  56                                     (k k)
  57                                     ((1 lda) (1 1))
  58                                     a-%offset%)))
  59           (setf t$ (- (f2cl-lib:fref b-%data% (k) ((1 1)) b-%offset%)))
  60           (daxpy (f2cl-lib:int-sub k 1) t$
  61            (f2cl-lib:array-slice a double-float (1 k) ((1 lda) (1 1))) 1
  62            (f2cl-lib:array-slice b double-float (1) ((1 1))) 1)
  63          label40))
  64       (go label100)
  65      label50
  66       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  67                     ((> k n) nil)
  68         (tagbody
  69           (setf t$
  70                   (ddot (f2cl-lib:int-sub k 1)
  71                    (f2cl-lib:array-slice a double-float (1 k) ((1 lda) (1 1)))
  72                    1 (f2cl-lib:array-slice b double-float (1) ((1 1))) 1))
  73           (setf (f2cl-lib:fref b-%data% (k) ((1 1)) b-%offset%)
  74                   (/ (- (f2cl-lib:fref b-%data% (k) ((1 1)) b-%offset%) t$)
  75                      (f2cl-lib:fref a-%data%
  76                                     (k k)
  77                                     ((1 lda) (1 1))
  78                                     a-%offset%)))
  79          label60))
  80       (if (< nm1 1) (go label90))
  81       (f2cl-lib:fdo (kb 1 (f2cl-lib:int-add kb 1))
  82                     ((> kb nm1) nil)
  83         (tagbody
  84           (setf k (f2cl-lib:int-sub n kb))
  85           (setf (f2cl-lib:fref b-%data% (k) ((1 1)) b-%offset%)
  86                   (+ (f2cl-lib:fref b-%data% (k) ((1 1)) b-%offset%)
  87                      (ddot (f2cl-lib:int-sub n k)
  88                       (f2cl-lib:array-slice a
  89                                             double-float
  90                                             ((+ k 1) k)
  91                                             ((1 lda) (1 1)))
  92                       1 (f2cl-lib:array-slice b double-float ((+ k 1)) ((1 1)))
  93                       1)))
  94           (setf l (f2cl-lib:fref ipvt-%data% (k) ((1 1)) ipvt-%offset%))
  95           (if (= l k) (go label70))
  96           (setf t$ (f2cl-lib:fref b-%data% (l) ((1 1)) b-%offset%))
  97           (setf (f2cl-lib:fref b-%data% (l) ((1 1)) b-%offset%)
  98                   (f2cl-lib:fref b-%data% (k) ((1 1)) b-%offset%))
  99           (setf (f2cl-lib:fref b-%data% (k) ((1 1)) b-%offset%) t$)
 100          label70
 101          label80))
 102      label90
 103      label100
 104       (go end_label)
 105      end_label
 106       (return (values nil nil nil nil nil nil)))))
 107
 108 (in-package #-gcl #:cl-user #+gcl "CL-USER")
 109 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 110 (eval-when (:load-toplevel :compile-toplevel :execute)
 111   (setf (gethash 'fortran-to-lisp::dgesl fortran-to-lisp::*f2cl-function-info*)
 112           (fortran-to-lisp::make-f2cl-finfo
 113            :arg-types '((array double-float (*)) (fortran-to-lisp::integer4)
 114                         (fortran-to-lisp::integer4)
 115                         (array fortran-to-lisp::integer4 (1))
 116                         (array double-float (1)) (fortran-to-lisp::integer4))
 117            :return-values '(nil nil nil nil nil nil)
 118            :calls '(fortran-to-lisp::ddot fortran-to-lisp::daxpy))))
 119