share/colnew/lisp/factrb.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 factrb (w ipivot d nrow ncol last$ info)
  21   (declare (type (f2cl-lib:integer4) info last$ ncol nrow)
  22            (type (array f2cl-lib:integer4 (*)) ipivot)
  23            (type (array double-float (*)) d w))
  24   (f2cl-lib:with-multi-array-data
  25       ((w double-float w-%data% w-%offset%)
  26        (d double-float d-%data% d-%offset%)
  27        (ipivot f2cl-lib:integer4 ipivot-%data% ipivot-%offset%))
  28     (prog ((dabs$ 0.0) (dmax1$ 0.0) (colmax 0.0) (t$ 0.0) (s 0.0) (i 0) (j 0)
  29            (k 0) (l 0) (kp1 0))
  30       (declare (type (f2cl-lib:integer4) kp1 l k j i)
  31                (type (double-float) s t$ colmax dmax1$ dabs$))
  32       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  33                     ((> i nrow) nil)
  34         (tagbody
  35           (setf (f2cl-lib:fref d-%data% (i) ((1 nrow)) d-%offset%) 0.0)
  36          label10))
  37       (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  38                     ((> j ncol) nil)
  39         (tagbody
  40           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  41                         ((> i nrow) nil)
  42             (tagbody
  43               (setf (f2cl-lib:fref d-%data% (i) ((1 nrow)) d-%offset%)
  44                       (f2cl-lib:dmax1
  45                        (f2cl-lib:fref d-%data% (i) ((1 nrow)) d-%offset%)
  46                        (f2cl-lib:dabs
  47                         (f2cl-lib:fref w-%data%
  48                                        (i j)
  49                                        ((1 nrow) (1 ncol))
  50                                        w-%offset%))))
  51              label20))))
  52      label20
  53       (setf k 1)
  54      label30
  55       (if (= (f2cl-lib:fref d-%data% (k) ((1 nrow)) d-%offset%) 0.0)
  56           (go label90))
  57       (if (= k nrow) (go label80))
  58       (setf l k)
  59       (setf kp1 (f2cl-lib:int-add k 1))
  60       (setf colmax
  61               (/
  62                (f2cl-lib:dabs
  63                 (f2cl-lib:fref w-%data% (k k) ((1 nrow) (1 ncol)) w-%offset%))
  64                (f2cl-lib:fref d-%data% (k) ((1 nrow)) d-%offset%)))
  65       (f2cl-lib:fdo (i kp1 (f2cl-lib:int-add i 1))
  66                     ((> i nrow) nil)
  67         (tagbody
  68           (if
  69            (<=
  70             (f2cl-lib:dabs
  71              (f2cl-lib:fref w-%data% (i k) ((1 nrow) (1 ncol)) w-%offset%))
  72             (* colmax (f2cl-lib:fref d-%data% (i) ((1 nrow)) d-%offset%)))
  73            (go label40))
  74           (setf colmax
  75                   (/
  76                    (f2cl-lib:dabs
  77                     (f2cl-lib:fref w-%data%
  78                                    (i k)
  79                                    ((1 nrow) (1 ncol))
  80                                    w-%offset%))
  81                    (f2cl-lib:fref d-%data% (i) ((1 nrow)) d-%offset%)))
  82           (setf l i)
  83          label40))
  84       (setf (f2cl-lib:fref ipivot-%data% (k) ((1 nrow)) ipivot-%offset%) l)
  85       (setf t$ (f2cl-lib:fref w-%data% (l k) ((1 nrow) (1 ncol)) w-%offset%))
  86       (setf s (f2cl-lib:fref d-%data% (l) ((1 nrow)) d-%offset%))
  87       (if (= l k) (go label50))
  88       (setf (f2cl-lib:fref w-%data% (l k) ((1 nrow) (1 ncol)) w-%offset%)
  89               (f2cl-lib:fref w-%data% (k k) ((1 nrow) (1 ncol)) w-%offset%))
  90       (setf (f2cl-lib:fref w-%data% (k k) ((1 nrow) (1 ncol)) w-%offset%) t$)
  91       (setf (f2cl-lib:fref d-%data% (l) ((1 nrow)) d-%offset%)
  92               (f2cl-lib:fref d-%data% (k) ((1 nrow)) d-%offset%))
  93       (setf (f2cl-lib:fref d-%data% (k) ((1 nrow)) d-%offset%) s)
  94      label50
  95       (if
  96        (<=
  97         (+ (f2cl-lib:dabs t$)
  98            (f2cl-lib:fref d-%data% (k) ((1 nrow)) d-%offset%))
  99         (f2cl-lib:fref d-%data% (k) ((1 nrow)) d-%offset%))
 100        (go label90))
 101       (setf t$ (/ -1.0 t$))
 102       (f2cl-lib:fdo (i kp1 (f2cl-lib:int-add i 1))
 103                     ((> i nrow) nil)
 104         (tagbody
 105          label60
 106           (setf (f2cl-lib:fref w-%data% (i k) ((1 nrow) (1 ncol)) w-%offset%)
 107                   (*
 108                    (f2cl-lib:fref w-%data%
 109                                   (i k)
 110                                   ((1 nrow) (1 ncol))
 111                                   w-%offset%)
 112                    t$))))
 113       (f2cl-lib:fdo (j kp1 (f2cl-lib:int-add j 1))
 114                     ((> j ncol) nil)
 115         (tagbody
 116           (setf t$
 117                   (f2cl-lib:fref w-%data%
 118                                  (l j)
 119                                  ((1 nrow) (1 ncol))
 120                                  w-%offset%))
 121           (if (= l k) (go label62))
 122           (setf (f2cl-lib:fref w-%data% (l j) ((1 nrow) (1 ncol)) w-%offset%)
 123                   (f2cl-lib:fref w-%data%
 124                                  (k j)
 125                                  ((1 nrow) (1 ncol))
 126                                  w-%offset%))
 127           (setf (f2cl-lib:fref w-%data% (k j) ((1 nrow) (1 ncol)) w-%offset%)
 128                   t$)
 129          label62
 130           (if (= t$ 0.0) (go label70))
 131           (f2cl-lib:fdo (i kp1 (f2cl-lib:int-add i 1))
 132                         ((> i nrow) nil)
 133             (tagbody
 134              label64
 135               (setf (f2cl-lib:fref w-%data%
 136                                    (i j)
 137                                    ((1 nrow) (1 ncol))
 138                                    w-%offset%)
 139                       (+
 140                        (f2cl-lib:fref w-%data%
 141                                       (i j)
 142                                       ((1 nrow) (1 ncol))
 143                                       w-%offset%)
 144                        (*
 145                         (f2cl-lib:fref w-%data%
 146                                        (i k)
 147                                        ((1 nrow) (1 ncol))
 148                                        w-%offset%)
 149                         t$)))))
 150          label70))
 151       (setf k kp1)
 152       (if (<= k last$) (go label30))
 153       (go end_label)
 154      label80
 155       (if
 156        (>
 157         (+
 158          (f2cl-lib:dabs
 159           (f2cl-lib:fref w-%data% (nrow nrow) ((1 nrow) (1 ncol)) w-%offset%))
 160          (f2cl-lib:fref d-%data% (nrow) ((1 nrow)) d-%offset%))
 161         (f2cl-lib:fref d-%data% (nrow) ((1 nrow)) d-%offset%))
 162        (go end_label))
 163      label90
 164       (setf info k)
 165       (go end_label)
 166      end_label
 167       (return (values nil nil nil nil nil nil info)))))
 168
 169 (in-package #:cl-user)
 170 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 171 (eval-when (:load-toplevel :compile-toplevel :execute)
 172   (setf (gethash 'fortran-to-lisp::factrb
 173                  fortran-to-lisp::*f2cl-function-info*)
 174           (fortran-to-lisp::make-f2cl-finfo
 175            :arg-types '((array double-float (*))
 176                         (array fortran-to-lisp::integer4 (*))
 177                         (array double-float (*)) (fortran-to-lisp::integer4)
 178                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 179                         (fortran-to-lisp::integer4))
 180            :return-values '(nil nil nil nil nil nil fortran-to-lisp::info)
 181            :calls 'nil)))
 182