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 dsyr2k (uplo trans 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) 28 (type (simple-string *) trans uplo)) 29 (f2cl-lib:with-multi-array-data 30 ((uplo character uplo-%data% uplo-%offset%) 31 (trans character trans-%data% trans-%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 ((temp1 0.0) (temp2 0.0) (i 0) (info 0) (j 0) (l 0) (nrowa 0) 36 (upper nil)) 37 (declare (type (double-float) temp1 temp2) 38 (type (f2cl-lib:integer4) i info j l nrowa) 39 (type f2cl-lib:logical upper)) 40 (cond 41 ((lsame trans "N") 42 (setf nrowa n)) 43 (t 44 (setf nrowa k))) 45 (setf upper (lsame uplo "U")) 46 (setf info 0) 47 (cond 48 ((and (not upper) (not (lsame uplo "L"))) 49 (setf info 1)) 50 ((and (not (lsame trans "N")) 51 (not (lsame trans "T")) 52 (not (lsame trans "C"))) 53 (setf info 2)) 54 ((< n 0) 55 (setf info 3)) 56 ((< k 0) 57 (setf info 4)) 58 ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nrowa))) 59 (setf info 7)) 60 ((< ldb$ 61 (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nrowa))) 62 (setf info 9)) 63 ((< ldc (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n))) 64 (setf info 12))) 65 (cond 66 ((/= info 0) 67 (xerbla "DSYR2K" info) 68 (go end_label))) 69 (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) 70 (go end_label)) 71 (cond 72 ((= alpha zero) 73 (cond 74 (upper 75 (cond 76 ((= beta zero) 77 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 78 ((> j n) nil) 79 (tagbody 80 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 81 ((> i j) nil) 82 (tagbody 83 (setf (f2cl-lib:fref c-%data% 84 (i j) 85 ((1 ldc) (1 *)) 86 c-%offset%) 87 zero) 88 label10)) 89 label20))) 90 (t 91 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 92 ((> j n) nil) 93 (tagbody 94 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 95 ((> i j) nil) 96 (tagbody 97 (setf (f2cl-lib:fref c-%data% 98 (i j) 99 ((1 ldc) (1 *)) 100 c-%offset%) 101 (* beta 102 (f2cl-lib:fref c-%data% 103 (i j) 104 ((1 ldc) (1 *)) 105 c-%offset%))) 106 label30)) 107 label40))))) 108 (t 109 (cond 110 ((= beta zero) 111 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 112 ((> j n) nil) 113 (tagbody 114 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) 115 ((> i n) nil) 116 (tagbody 117 (setf (f2cl-lib:fref c-%data% 118 (i j) 119 ((1 ldc) (1 *)) 120 c-%offset%) 121 zero) 122 label50)) 123 label60))) 124 (t 125 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 126 ((> j n) nil) 127 (tagbody 128 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) 129 ((> i n) nil) 130 (tagbody 131 (setf (f2cl-lib:fref c-%data% 132 (i j) 133 ((1 ldc) (1 *)) 134 c-%offset%) 135 (* beta 136 (f2cl-lib:fref c-%data% 137 (i j) 138 ((1 ldc) (1 *)) 139 c-%offset%))) 140 label70)) 141 label80)))))) 142 (go end_label))) 143 (cond 144 ((lsame trans "N") 145 (cond 146 (upper 147 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 148 ((> j n) nil) 149 (tagbody 150 (cond 151 ((= beta zero) 152 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 153 ((> i j) nil) 154 (tagbody 155 (setf (f2cl-lib:fref c-%data% 156 (i j) 157 ((1 ldc) (1 *)) 158 c-%offset%) 159 zero) 160 label90))) 161 ((/= beta one) 162 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 163 ((> i j) nil) 164 (tagbody 165 (setf (f2cl-lib:fref c-%data% 166 (i j) 167 ((1 ldc) (1 *)) 168 c-%offset%) 169 (* beta 170 (f2cl-lib:fref c-%data% 171 (i j) 172 ((1 ldc) (1 *)) 173 c-%offset%))) 174 label100)))) 175 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 176 ((> l k) nil) 177 (tagbody 178 (cond 179 ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) 180 (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) 181 (setf temp1 182 (* alpha 183 (f2cl-lib:fref b-%data% 184 (j l) 185 ((1 ldb$) (1 *)) 186 b-%offset%))) 187 (setf temp2 188 (* alpha 189 (f2cl-lib:fref a-%data% 190 (j l) 191 ((1 lda) (1 *)) 192 a-%offset%))) 193 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 194 ((> i j) nil) 195 (tagbody 196 (setf (f2cl-lib:fref c-%data% 197 (i j) 198 ((1 ldc) (1 *)) 199 c-%offset%) 200 (+ 201 (f2cl-lib:fref c-%data% 202 (i j) 203 ((1 ldc) (1 *)) 204 c-%offset%) 205 (* 206 (f2cl-lib:fref a-%data% 207 (i l) 208 ((1 lda) (1 *)) 209 a-%offset%) 210 temp1) 211 (* 212 (f2cl-lib:fref b-%data% 213 (i l) 214 ((1 ldb$) (1 *)) 215 b-%offset%) 216 temp2))) 217 label110)))) 218 label120)) 219 label130))) 220 (t 221 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 222 ((> j n) nil) 223 (tagbody 224 (cond 225 ((= beta zero) 226 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) 227 ((> i n) nil) 228 (tagbody 229 (setf (f2cl-lib:fref c-%data% 230 (i j) 231 ((1 ldc) (1 *)) 232 c-%offset%) 233 zero) 234 label140))) 235 ((/= beta one) 236 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) 237 ((> i n) nil) 238 (tagbody 239 (setf (f2cl-lib:fref c-%data% 240 (i j) 241 ((1 ldc) (1 *)) 242 c-%offset%) 243 (* beta 244 (f2cl-lib:fref c-%data% 245 (i j) 246 ((1 ldc) (1 *)) 247 c-%offset%))) 248 label150)))) 249 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 250 ((> l k) nil) 251 (tagbody 252 (cond 253 ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) 254 (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) 255 (setf temp1 256 (* alpha 257 (f2cl-lib:fref b-%data% 258 (j l) 259 ((1 ldb$) (1 *)) 260 b-%offset%))) 261 (setf temp2 262 (* alpha 263 (f2cl-lib:fref a-%data% 264 (j l) 265 ((1 lda) (1 *)) 266 a-%offset%))) 267 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) 268 ((> i n) nil) 269 (tagbody 270 (setf (f2cl-lib:fref c-%data% 271 (i j) 272 ((1 ldc) (1 *)) 273 c-%offset%) 274 (+ 275 (f2cl-lib:fref c-%data% 276 (i j) 277 ((1 ldc) (1 *)) 278 c-%offset%) 279 (* 280 (f2cl-lib:fref a-%data% 281 (i l) 282 ((1 lda) (1 *)) 283 a-%offset%) 284 temp1) 285 (* 286 (f2cl-lib:fref b-%data% 287 (i l) 288 ((1 ldb$) (1 *)) 289 b-%offset%) 290 temp2))) 291 label160)))) 292 label170)) 293 label180))))) 294 (t 295 (cond 296 (upper 297 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 298 ((> j n) nil) 299 (tagbody 300 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 301 ((> i j) nil) 302 (tagbody 303 (setf temp1 zero) 304 (setf temp2 zero) 305 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 306 ((> l k) nil) 307 (tagbody 308 (setf temp1 309 (+ temp1 310 (* 311 (f2cl-lib:fref a-%data% 312 (l i) 313 ((1 lda) (1 *)) 314 a-%offset%) 315 (f2cl-lib:fref b-%data% 316 (l j) 317 ((1 ldb$) (1 *)) 318 b-%offset%)))) 319 (setf temp2 320 (+ temp2 321 (* 322 (f2cl-lib:fref b-%data% 323 (l i) 324 ((1 ldb$) (1 *)) 325 b-%offset%) 326 (f2cl-lib:fref a-%data% 327 (l j) 328 ((1 lda) (1 *)) 329 a-%offset%)))) 330 label190)) 331 (cond 332 ((= beta zero) 333 (setf (f2cl-lib:fref c-%data% 334 (i j) 335 ((1 ldc) (1 *)) 336 c-%offset%) 337 (+ (* alpha temp1) (* alpha temp2)))) 338 (t 339 (setf (f2cl-lib:fref c-%data% 340 (i j) 341 ((1 ldc) (1 *)) 342 c-%offset%) 343 (+ 344 (* beta 345 (f2cl-lib:fref c-%data% 346 (i j) 347 ((1 ldc) (1 *)) 348 c-%offset%)) 349 (* alpha temp1) 350 (* alpha temp2))))) 351 label200)) 352 label210))) 353 (t 354 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 355 ((> j n) nil) 356 (tagbody 357 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) 358 ((> i n) nil) 359 (tagbody 360 (setf temp1 zero) 361 (setf temp2 zero) 362 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 363 ((> l k) nil) 364 (tagbody 365 (setf temp1 366 (+ temp1 367 (* 368 (f2cl-lib:fref a-%data% 369 (l i) 370 ((1 lda) (1 *)) 371 a-%offset%) 372 (f2cl-lib:fref b-%data% 373 (l j) 374 ((1 ldb$) (1 *)) 375 b-%offset%)))) 376 (setf temp2 377 (+ temp2 378 (* 379 (f2cl-lib:fref b-%data% 380 (l i) 381 ((1 ldb$) (1 *)) 382 b-%offset%) 383 (f2cl-lib:fref a-%data% 384 (l j) 385 ((1 lda) (1 *)) 386 a-%offset%)))) 387 label220)) 388 (cond 389 ((= beta zero) 390 (setf (f2cl-lib:fref c-%data% 391 (i j) 392 ((1 ldc) (1 *)) 393 c-%offset%) 394 (+ (* alpha temp1) (* alpha temp2)))) 395 (t 396 (setf (f2cl-lib:fref c-%data% 397 (i j) 398 ((1 ldc) (1 *)) 399 c-%offset%) 400 (+ 401 (* beta 402 (f2cl-lib:fref c-%data% 403 (i j) 404 ((1 ldc) (1 *)) 405 c-%offset%)) 406 (* alpha temp1) 407 (* alpha temp2))))) 408 label230)) 409 label240)))))) 410 (go end_label) 411 end_label 412 (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) 413 414(in-package #-gcl #:cl-user #+gcl "CL-USER") 415#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 416(eval-when (:load-toplevel :compile-toplevel :execute) 417 (setf (gethash 'fortran-to-lisp::dsyr2k 418 fortran-to-lisp::*f2cl-function-info*) 419 (fortran-to-lisp::make-f2cl-finfo 420 :arg-types '((simple-string) (simple-string) 421 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 422 (double-float) (array double-float (*)) 423 (fortran-to-lisp::integer4) (array double-float (*)) 424 (fortran-to-lisp::integer4) (double-float) 425 (array double-float (*)) (fortran-to-lisp::integer4)) 426 :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) 427 :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) 428 429