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 208