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 dgemm (transa transb m n k alpha a lda b ldb$ beta c ldc) 25 (declare (type (array double-float (*)) c b a) 26 (type (double-float) beta alpha) 27 (type (f2cl-lib:integer4) ldc ldb$ lda k n m) 28 (type (simple-string *) transb transa)) 29 (f2cl-lib:with-multi-array-data 30 ((transa character transa-%data% transa-%offset%) 31 (transb character transb-%data% transb-%offset%) 32 (a double-float a-%data% a-%offset%) 33 (b double-float b-%data% b-%offset%) 34 (c double-float c-%data% c-%offset%)) 35 (prog ((temp 0.0) (i 0) (info 0) (j 0) (l 0) (ncola 0) (nrowa 0) 36 (nrowb 0) (nota nil) (notb nil)) 37 (declare (type (double-float) temp) 38 (type (f2cl-lib:integer4) i info j l ncola nrowa nrowb) 39 (type f2cl-lib:logical nota notb)) 40 (setf nota (lsame transa "N")) 41 (setf notb (lsame transb "N")) 42 (cond 43 (nota 44 (setf nrowa m) 45 (setf ncola k)) 46 (t 47 (setf nrowa k) 48 (setf ncola m))) 49 (cond 50 (notb 51 (setf nrowb k)) 52 (t 53 (setf nrowb n))) 54 (setf info 0) 55 (cond 56 ((and (not nota) (not (lsame transa "C")) (not (lsame transa "T"))) 57 (setf info 1)) 58 ((and (not notb) (not (lsame transb "C")) (not (lsame transb "T"))) 59 (setf info 2)) 60 ((< m 0) 61 (setf info 3)) 62 ((< n 0) 63 (setf info 4)) 64 ((< k 0) 65 (setf info 5)) 66 ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nrowa))) 67 (setf info 8)) 68 ((< ldb$ 69 (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nrowb))) 70 (setf info 10)) 71 ((< ldc (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 m))) 72 (setf info 13))) 73 (cond 74 ((/= info 0) 75 (xerbla "DGEMM " info) 76 (go end_label))) 77 (if (or (= m 0) (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) 78 (go end_label)) 79 (cond 80 ((= alpha zero) 81 (cond 82 ((= beta zero) 83 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 84 ((> j n) nil) 85 (tagbody 86 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 87 ((> i m) nil) 88 (tagbody 89 (setf (f2cl-lib:fref c-%data% 90 (i j) 91 ((1 ldc) (1 *)) 92 c-%offset%) 93 zero) 94 label10)) 95 label20))) 96 (t 97 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 98 ((> j n) nil) 99 (tagbody 100 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 101 ((> i m) nil) 102 (tagbody 103 (setf (f2cl-lib:fref c-%data% 104 (i j) 105 ((1 ldc) (1 *)) 106 c-%offset%) 107 (* beta 108 (f2cl-lib:fref c-%data% 109 (i j) 110 ((1 ldc) (1 *)) 111 c-%offset%))) 112 label30)) 113 label40)))) 114 (go end_label))) 115 (cond 116 (notb 117 (cond 118 (nota 119 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 120 ((> j n) nil) 121 (tagbody 122 (cond 123 ((= beta zero) 124 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 125 ((> i m) nil) 126 (tagbody 127 (setf (f2cl-lib:fref c-%data% 128 (i j) 129 ((1 ldc) (1 *)) 130 c-%offset%) 131 zero) 132 label50))) 133 ((/= beta one) 134 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 135 ((> i m) nil) 136 (tagbody 137 (setf (f2cl-lib:fref c-%data% 138 (i j) 139 ((1 ldc) (1 *)) 140 c-%offset%) 141 (* beta 142 (f2cl-lib:fref c-%data% 143 (i j) 144 ((1 ldc) (1 *)) 145 c-%offset%))) 146 label60)))) 147 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 148 ((> l k) nil) 149 (tagbody 150 (cond 151 ((/= (f2cl-lib:fref b (l j) ((1 ldb$) (1 *))) zero) 152 (setf temp 153 (* alpha 154 (f2cl-lib:fref b-%data% 155 (l j) 156 ((1 ldb$) (1 *)) 157 b-%offset%))) 158 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 159 ((> i m) nil) 160 (tagbody 161 (setf (f2cl-lib:fref c-%data% 162 (i j) 163 ((1 ldc) (1 *)) 164 c-%offset%) 165 (+ 166 (f2cl-lib:fref c-%data% 167 (i j) 168 ((1 ldc) (1 *)) 169 c-%offset%) 170 (* temp 171 (f2cl-lib:fref a-%data% 172 (i l) 173 ((1 lda) (1 *)) 174 a-%offset%)))) 175 label70)))) 176 label80)) 177 label90))) 178 (t 179 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 180 ((> j n) nil) 181 (tagbody 182 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 183 ((> i m) nil) 184 (tagbody 185 (setf temp zero) 186 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 187 ((> l k) nil) 188 (tagbody 189 (setf temp 190 (+ temp 191 (* 192 (f2cl-lib:fref a-%data% 193 (l i) 194 ((1 lda) (1 *)) 195 a-%offset%) 196 (f2cl-lib:fref b-%data% 197 (l j) 198 ((1 ldb$) (1 *)) 199 b-%offset%)))) 200 label100)) 201 (cond 202 ((= beta zero) 203 (setf (f2cl-lib:fref c-%data% 204 (i j) 205 ((1 ldc) (1 *)) 206 c-%offset%) 207 (* alpha temp))) 208 (t 209 (setf (f2cl-lib:fref c-%data% 210 (i j) 211 ((1 ldc) (1 *)) 212 c-%offset%) 213 (+ (* alpha temp) 214 (* beta 215 (f2cl-lib:fref c-%data% 216 (i j) 217 ((1 ldc) (1 *)) 218 c-%offset%)))))) 219 label110)) 220 label120))))) 221 (t 222 (cond 223 (nota 224 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 225 ((> j n) nil) 226 (tagbody 227 (cond 228 ((= beta zero) 229 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 230 ((> i m) nil) 231 (tagbody 232 (setf (f2cl-lib:fref c-%data% 233 (i j) 234 ((1 ldc) (1 *)) 235 c-%offset%) 236 zero) 237 label130))) 238 ((/= beta one) 239 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 240 ((> i m) nil) 241 (tagbody 242 (setf (f2cl-lib:fref c-%data% 243 (i j) 244 ((1 ldc) (1 *)) 245 c-%offset%) 246 (* beta 247 (f2cl-lib:fref c-%data% 248 (i j) 249 ((1 ldc) (1 *)) 250 c-%offset%))) 251 label140)))) 252 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 253 ((> l k) nil) 254 (tagbody 255 (cond 256 ((/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero) 257 (setf temp 258 (* alpha 259 (f2cl-lib:fref b-%data% 260 (j l) 261 ((1 ldb$) (1 *)) 262 b-%offset%))) 263 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 264 ((> i m) nil) 265 (tagbody 266 (setf (f2cl-lib:fref c-%data% 267 (i j) 268 ((1 ldc) (1 *)) 269 c-%offset%) 270 (+ 271 (f2cl-lib:fref c-%data% 272 (i j) 273 ((1 ldc) (1 *)) 274 c-%offset%) 275 (* temp 276 (f2cl-lib:fref a-%data% 277 (i l) 278 ((1 lda) (1 *)) 279 a-%offset%)))) 280 label150)))) 281 label160)) 282 label170))) 283 (t 284 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 285 ((> j n) nil) 286 (tagbody 287 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 288 ((> i m) nil) 289 (tagbody 290 (setf temp zero) 291 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 292 ((> l k) nil) 293 (tagbody 294 (setf temp 295 (+ temp 296 (* 297 (f2cl-lib:fref a-%data% 298 (l i) 299 ((1 lda) (1 *)) 300 a-%offset%) 301 (f2cl-lib:fref b-%data% 302 (j l) 303 ((1 ldb$) (1 *)) 304 b-%offset%)))) 305 label180)) 306 (cond 307 ((= beta zero) 308 (setf (f2cl-lib:fref c-%data% 309 (i j) 310 ((1 ldc) (1 *)) 311 c-%offset%) 312 (* alpha temp))) 313 (t 314 (setf (f2cl-lib:fref c-%data% 315 (i j) 316 ((1 ldc) (1 *)) 317 c-%offset%) 318 (+ (* alpha temp) 319 (* beta 320 (f2cl-lib:fref c-%data% 321 (i j) 322 ((1 ldc) (1 *)) 323 c-%offset%)))))) 324 label190)) 325 label200)))))) 326 (go end_label) 327 end_label 328 (return 329 (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) 330 331(in-package #-gcl #:cl-user #+gcl "CL-USER") 332#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 333(eval-when (:load-toplevel :compile-toplevel :execute) 334 (setf (gethash 'fortran-to-lisp::dgemm fortran-to-lisp::*f2cl-function-info*) 335 (fortran-to-lisp::make-f2cl-finfo 336 :arg-types '((simple-string) (simple-string) 337 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 338 (fortran-to-lisp::integer4) (double-float) 339 (array double-float (*)) (fortran-to-lisp::integer4) 340 (array double-float (*)) (fortran-to-lisp::integer4) 341 (double-float) (array double-float (*)) 342 (fortran-to-lisp::integer4)) 343 :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil 344 nil) 345 :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) 346 347