1;;; Compiled by f2cl version: 2;;; ("f2cl1.l,v 2edcbd958861 2012/05/30 03:34:52 toy $" 3;;; "f2cl2.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $" 4;;; "f2cl3.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $" 5;;; "f2cl4.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $" 6;;; "f2cl5.l,v 3fe93de3be82 2012/05/06 02:17:14 toy $" 7;;; "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $" 8;;; "macros.l,v 3fe93de3be82 2012/05/06 02:17:14 toy $") 9 10;;; Using Lisp CMU Common Lisp 20d (20D 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 :blas) 18 19 20(let* ((one 1.0) (zero 0.0)) 21 (declare (type (double-float 1.0 1.0) one) 22 (type (double-float 0.0 0.0) zero) 23 (ignorable one zero)) 24 (defun dgemv (trans m n alpha a lda x incx beta y incy) 25 (declare (type (array double-float (*)) y x a) 26 (type (double-float) beta alpha) 27 (type (f2cl-lib:integer4) incy incx lda n m) 28 (type (simple-string *) trans)) 29 (f2cl-lib:with-multi-array-data 30 ((trans character trans-%data% trans-%offset%) 31 (a double-float a-%data% a-%offset%) 32 (x double-float x-%data% x-%offset%) 33 (y double-float y-%data% y-%offset%)) 34 (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) 35 (lenx 0) (leny 0) (temp 0.0)) 36 (declare (type (f2cl-lib:integer4) i info ix iy j jx jy kx ky lenx 37 leny) 38 (type (double-float) temp)) 39 (setf info 0) 40 (cond 41 ((and (not (lsame trans "N")) 42 (not (lsame trans "T")) 43 (not (lsame trans "C"))) 44 (setf info 1)) 45 ((< m 0) 46 (setf info 2)) 47 ((< n 0) 48 (setf info 3)) 49 ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 m))) 50 (setf info 6)) 51 ((= incx 0) 52 (setf info 8)) 53 ((= incy 0) 54 (setf info 11))) 55 (cond 56 ((/= info 0) 57 (xerbla "DGEMV " info) 58 (go end_label))) 59 (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) 60 (go end_label)) 61 (cond 62 ((lsame trans "N") 63 (setf lenx n) 64 (setf leny m)) 65 (t 66 (setf lenx m) 67 (setf leny n))) 68 (cond 69 ((> incx 0) 70 (setf kx 1)) 71 (t 72 (setf kx 73 (f2cl-lib:int-sub 1 74 (f2cl-lib:int-mul 75 (f2cl-lib:int-sub lenx 1) 76 incx))))) 77 (cond 78 ((> incy 0) 79 (setf ky 1)) 80 (t 81 (setf ky 82 (f2cl-lib:int-sub 1 83 (f2cl-lib:int-mul 84 (f2cl-lib:int-sub leny 1) 85 incy))))) 86 (cond 87 ((/= beta one) 88 (cond 89 ((= incy 1) 90 (cond 91 ((= beta zero) 92 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 93 ((> i leny) nil) 94 (tagbody 95 (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) 96 zero) 97 label10))) 98 (t 99 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 100 ((> i leny) nil) 101 (tagbody 102 (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) 103 (* beta 104 (f2cl-lib:fref y-%data% 105 (i) 106 ((1 *)) 107 y-%offset%))) 108 label20))))) 109 (t 110 (setf iy ky) 111 (cond 112 ((= beta zero) 113 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 114 ((> i leny) nil) 115 (tagbody 116 (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) 117 zero) 118 (setf iy (f2cl-lib:int-add iy incy)) 119 label30))) 120 (t 121 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 122 ((> i leny) nil) 123 (tagbody 124 (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) 125 (* beta 126 (f2cl-lib:fref y-%data% 127 (iy) 128 ((1 *)) 129 y-%offset%))) 130 (setf iy (f2cl-lib:int-add iy incy)) 131 label40)))))))) 132 (if (= alpha zero) (go end_label)) 133 (cond 134 ((lsame trans "N") 135 (setf jx kx) 136 (cond 137 ((= incy 1) 138 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 139 ((> j n) nil) 140 (tagbody 141 (cond 142 ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) 143 (setf temp 144 (* alpha 145 (f2cl-lib:fref x-%data% 146 (jx) 147 ((1 *)) 148 x-%offset%))) 149 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 150 ((> i m) nil) 151 (tagbody 152 (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) 153 (+ 154 (f2cl-lib:fref y-%data% 155 (i) 156 ((1 *)) 157 y-%offset%) 158 (* temp 159 (f2cl-lib:fref a-%data% 160 (i j) 161 ((1 lda) (1 *)) 162 a-%offset%)))) 163 label50)))) 164 (setf jx (f2cl-lib:int-add jx incx)) 165 label60))) 166 (t 167 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 168 ((> j n) nil) 169 (tagbody 170 (cond 171 ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) 172 (setf temp 173 (* alpha 174 (f2cl-lib:fref x-%data% 175 (jx) 176 ((1 *)) 177 x-%offset%))) 178 (setf iy ky) 179 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 180 ((> i m) nil) 181 (tagbody 182 (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) 183 (+ 184 (f2cl-lib:fref y-%data% 185 (iy) 186 ((1 *)) 187 y-%offset%) 188 (* temp 189 (f2cl-lib:fref a-%data% 190 (i j) 191 ((1 lda) (1 *)) 192 a-%offset%)))) 193 (setf iy (f2cl-lib:int-add iy incy)) 194 label70)))) 195 (setf jx (f2cl-lib:int-add jx incx)) 196 label80))))) 197 (t 198 (setf jy ky) 199 (cond 200 ((= incx 1) 201 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 202 ((> j n) nil) 203 (tagbody 204 (setf temp zero) 205 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 206 ((> i m) nil) 207 (tagbody 208 (setf temp 209 (+ temp 210 (* 211 (f2cl-lib:fref a-%data% 212 (i j) 213 ((1 lda) (1 *)) 214 a-%offset%) 215 (f2cl-lib:fref x-%data% 216 (i) 217 ((1 *)) 218 x-%offset%)))) 219 label90)) 220 (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) 221 (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) 222 (* alpha temp))) 223 (setf jy (f2cl-lib:int-add jy incy)) 224 label100))) 225 (t 226 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 227 ((> j n) nil) 228 (tagbody 229 (setf temp zero) 230 (setf ix kx) 231 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 232 ((> i m) nil) 233 (tagbody 234 (setf temp 235 (+ temp 236 (* 237 (f2cl-lib:fref a-%data% 238 (i j) 239 ((1 lda) (1 *)) 240 a-%offset%) 241 (f2cl-lib:fref x-%data% 242 (ix) 243 ((1 *)) 244 x-%offset%)))) 245 (setf ix (f2cl-lib:int-add ix incx)) 246 label110)) 247 (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) 248 (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) 249 (* alpha temp))) 250 (setf jy (f2cl-lib:int-add jy incy)) 251 label120)))))) 252 (go end_label) 253 end_label 254 (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) 255 256(in-package #-gcl #:cl-user #+gcl "CL-USER") 257#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 258(eval-when (:load-toplevel :compile-toplevel :execute) 259 (setf (gethash 'fortran-to-lisp::dgemv fortran-to-lisp::*f2cl-function-info*) 260 (fortran-to-lisp::make-f2cl-finfo 261 :arg-types '((simple-string) (fortran-to-lisp::integer4) 262 (fortran-to-lisp::integer4) (double-float) 263 (array double-float (*)) (fortran-to-lisp::integer4) 264 (array double-float (*)) (fortran-to-lisp::integer4) 265 (double-float) (array double-float (*)) 266 (fortran-to-lisp::integer4)) 267 :return-values '(nil nil nil nil nil nil nil nil nil nil nil) 268 :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) 269 270