share/colnew/lisp/gblock.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 gblock (h gi nrow irow wi vi kd rhsz rhsdmz ipvtw mode)
  21   (declare (type (array f2cl-lib:integer4 (*)) ipvtw)
  22            (type (array double-float (*)) rhsdmz rhsz wi)
  23            (type (f2cl-lib:integer4) mode kd irow nrow)
  24            (type (array double-float (*)) vi gi)
  25            (type double-float h))
  26   (let ((colord-m
  27          (make-array 20
  28                      :element-type 'f2cl-lib:integer4
  29                      :displaced-to (colord-part-0 *colord-common-block*)
  30                      :displaced-index-offset 5))
  31         (colbas-b
  32          (make-array 28
  33                      :element-type 'double-float
  34                      :displaced-to (colbas-part-0 *colbas-common-block*)
  35                      :displaced-index-offset 0)))
  36     (symbol-macrolet ((k (aref (colord-part-0 *colord-common-block*) 0))
  37                       (ncomp (aref (colord-part-0 *colord-common-block*) 1))
  38                       (mstar (aref (colord-part-0 *colord-common-block*) 2))
  39                       (mmax (aref (colord-part-0 *colord-common-block*) 4))
  40                       (m colord-m)
  41                       (b colbas-b))
  42       (f2cl-lib:with-multi-array-data
  43           ((gi double-float gi-%data% gi-%offset%)
  44            (vi double-float vi-%data% vi-%offset%)
  45            (wi double-float wi-%data% wi-%offset%)
  46            (rhsz double-float rhsz-%data% rhsz-%offset%)
  47            (rhsdmz double-float rhsdmz-%data% rhsdmz-%offset%)
  48            (ipvtw f2cl-lib:integer4 ipvtw-%data% ipvtw-%offset%))
  49         (prog ((jcomp 0) (ll 0) (jd 0) (rsum 0.0) (ind 0) (jcol 0) (id 0)
  50                (mj 0) (icomp 0) (ir 0) (j 0) (l 0) (fact 0.0)
  51                (basm (make-array 5 :element-type 'double-float))
  52                (hb (make-array 28 :element-type 'double-float)))
  53           (declare (type (array double-float (28)) hb)
  54                    (type (array double-float (5)) basm)
  55                    (type double-float fact rsum)
  56                    (type (f2cl-lib:integer4) l j ir icomp mj id jcol ind jd ll
  57                                              jcomp))
  58           (setf fact 1.0)
  59           (setf (f2cl-lib:fref basm (1) ((1 5))) 1.0)
  60           (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
  61                         ((> l mmax) nil)
  62             (tagbody
  63               (setf fact (/ (* fact h) (f2cl-lib:dfloat l)))
  64               (setf (f2cl-lib:fref basm ((f2cl-lib:int-add l 1)) ((1 5))) fact)
  65               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  66                             ((> j k) nil)
  67                 (tagbody
  68                  label20
  69                   (setf (f2cl-lib:fref hb (j l) ((1 7) (1 4)))
  70                           (* fact (f2cl-lib:fref b (j l) ((1 7) (1 4)))))))
  71              label30))
  72           (f2cl-lib:computed-goto (label40 label110) mode)
  73          label40
  74           (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  75                         ((> j mstar) nil)
  76             (tagbody
  77               (f2cl-lib:fdo (ir 1 (f2cl-lib:int-add ir 1))
  78                             ((> ir mstar) nil)
  79                 (tagbody
  80                   (setf (f2cl-lib:fref gi-%data%
  81                                        ((f2cl-lib:int-add
  82                                          (f2cl-lib:int-sub irow 1)
  83                                          ir)
  84                                         j)
  85                                        ((1 nrow) (1 1))
  86                                        gi-%offset%)
  87                           0.0)
  88                  label50
  89                   (setf (f2cl-lib:fref gi-%data%
  90                                        ((f2cl-lib:int-add
  91                                          (f2cl-lib:int-sub irow 1)
  92                                          ir)
  93                                         (f2cl-lib:int-add mstar j))
  94                                        ((1 nrow) (1 1))
  95                                        gi-%offset%)
  96                           0.0)))
  97              label60
  98               (setf (f2cl-lib:fref gi-%data%
  99                                    ((f2cl-lib:int-add (f2cl-lib:int-sub irow 1)
 100                                                       j)
 101                                     (f2cl-lib:int-add mstar j))
 102                                    ((1 nrow) (1 1))
 103                                    gi-%offset%)
 104                       1.0)))
 105           (setf ir irow)
 106           (f2cl-lib:fdo (icomp 1 (f2cl-lib:int-add icomp 1))
 107                         ((> icomp ncomp) nil)
 108             (tagbody
 109               (setf mj (f2cl-lib:fref m (icomp) ((1 20))))
 110               (setf ir (f2cl-lib:int-add ir mj))
 111               (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
 112                             ((> l mj) nil)
 113                 (tagbody
 114                   (setf id (f2cl-lib:int-sub ir l))
 115                   (f2cl-lib:fdo (jcol 1 (f2cl-lib:int-add jcol 1))
 116                                 ((> jcol mstar) nil)
 117                     (tagbody
 118                       (setf ind icomp)
 119                       (setf rsum 0.0)
 120                       (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 121                                     ((> j k) nil)
 122                         (tagbody
 123                           (setf rsum
 124                                   (- rsum
 125                                      (* (f2cl-lib:fref hb (j l) ((1 7) (1 4)))
 126                                         (f2cl-lib:fref vi-%data%
 127                                                        (ind jcol)
 128                                                        ((1 kd) (1 1))
 129                                                        vi-%offset%))))
 130                          label70
 131                           (setf ind (f2cl-lib:int-add ind ncomp))))
 132                       (setf (f2cl-lib:fref gi-%data%
 133                                            (id jcol)
 134                                            ((1 nrow) (1 1))
 135                                            gi-%offset%)
 136                               rsum)
 137                      label80))
 138                   (setf jd (f2cl-lib:int-sub id irow))
 139                   (f2cl-lib:fdo (ll 1 (f2cl-lib:int-add ll 1))
 140                                 ((> ll l) nil)
 141                     (tagbody
 142                       (setf (f2cl-lib:fref gi-%data%
 143                                            (id (f2cl-lib:int-add jd ll))
 144                                            ((1 nrow) (1 1))
 145                                            gi-%offset%)
 146                               (-
 147                                (f2cl-lib:fref gi-%data%
 148                                               (id (f2cl-lib:int-add jd ll))
 149                                               ((1 nrow) (1 1))
 150                                               gi-%offset%)
 151                                (f2cl-lib:fref basm (ll) ((1 5)))))
 152                      label85))
 153                  label90))
 154              label100))
 155           (go end_label)
 156          label110
 157           (dgesl wi kd kd ipvtw rhsdmz 0)
 158           (setf ir irow)
 159           (f2cl-lib:fdo (jcomp 1 (f2cl-lib:int-add jcomp 1))
 160                         ((> jcomp ncomp) nil)
 161             (tagbody
 162               (setf mj (f2cl-lib:fref m (jcomp) ((1 20))))
 163               (setf ir (f2cl-lib:int-add ir mj))
 164               (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
 165                             ((> l mj) nil)
 166                 (tagbody
 167                   (setf ind jcomp)
 168                   (setf rsum 0.0)
 169                   (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 170                                 ((> j k) nil)
 171                     (tagbody
 172                       (setf rsum
 173                               (+ rsum
 174                                  (* (f2cl-lib:fref hb (j l) ((1 7) (1 4)))
 175                                     (f2cl-lib:fref rhsdmz-%data%
 176                                                    (ind)
 177                                                    ((1 1))
 178                                                    rhsdmz-%offset%))))
 179                      label120
 180                       (setf ind (f2cl-lib:int-add ind ncomp))))
 181                   (setf (f2cl-lib:fref rhsz-%data%
 182                                        ((f2cl-lib:int-sub ir l))
 183                                        ((1 1))
 184                                        rhsz-%offset%)
 185                           rsum)
 186                  label130))
 187              label140))
 188           (go end_label)
 189          end_label
 190           (return (values nil nil nil nil nil nil nil nil nil nil nil)))))))
 191
 192 (in-package #-gcl #:cl-user #+gcl "CL-USER")
 193 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 194 (eval-when (:load-toplevel :compile-toplevel :execute)
 195   (setf (gethash 'fortran-to-lisp::gblock
 196                  fortran-to-lisp::*f2cl-function-info*)
 197           (fortran-to-lisp::make-f2cl-finfo
 198            :arg-types '(double-float (array double-float (*))
 199                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 200                         (array double-float (1)) (array double-float (*))
 201                         (fortran-to-lisp::integer4) (array double-float (1))
 202                         (array double-float (1))
 203                         (array fortran-to-lisp::integer4 (1))
 204                         (fortran-to-lisp::integer4))
 205            :return-values '(nil nil nil nil nil nil nil nil nil nil nil)
 206            :calls '(fortran-to-lisp::dgesl))))
 207