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 (f2cl-lib:cmplx 0.0 0.0))) 21 (declare (type (double-float 1.0 1.0) one) 22 (type (f2cl-lib:complex16) zero) 23 (ignorable one zero)) 24 (defun zher2k (uplo trans n k alpha a lda b ldb$ beta c ldc) 25 (declare (type (double-float) beta) 26 (type (array f2cl-lib:complex16 (*)) c b a) 27 (type (f2cl-lib:complex16) alpha) 28 (type (f2cl-lib:integer4) ldc ldb$ lda k n) 29 (type (simple-string *) trans uplo)) 30 (f2cl-lib:with-multi-array-data 31 ((uplo character uplo-%data% uplo-%offset%) 32 (trans character trans-%data% trans-%offset%) 33 (a f2cl-lib:complex16 a-%data% a-%offset%) 34 (b f2cl-lib:complex16 b-%data% b-%offset%) 35 (c f2cl-lib:complex16 c-%data% c-%offset%)) 36 (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) 37 (nrowa 0) (upper nil)) 38 (declare (type (f2cl-lib:complex16) temp1 temp2) 39 (type (f2cl-lib:integer4) i info j l nrowa) 40 (type f2cl-lib:logical upper)) 41 (cond 42 ((lsame trans "N") 43 (setf nrowa n)) 44 (t 45 (setf nrowa k))) 46 (setf upper (lsame uplo "U")) 47 (setf info 0) 48 (cond 49 ((and (not upper) (not (lsame uplo "L"))) 50 (setf info 1)) 51 ((and (not (lsame trans "N")) (not (lsame trans "C"))) 52 (setf info 2)) 53 ((< n 0) 54 (setf info 3)) 55 ((< k 0) 56 (setf info 4)) 57 ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nrowa))) 58 (setf info 7)) 59 ((< ldb$ 60 (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nrowa))) 61 (setf info 9)) 62 ((< ldc (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n))) 63 (setf info 12))) 64 (cond 65 ((/= info 0) 66 (xerbla "ZHER2K" info) 67 (go end_label))) 68 (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) 69 (go end_label)) 70 (cond 71 ((= alpha zero) 72 (cond 73 (upper 74 (cond 75 ((= beta (f2cl-lib:dble zero)) 76 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 77 ((> j n) nil) 78 (tagbody 79 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 80 ((> i j) nil) 81 (tagbody 82 (setf (f2cl-lib:fref c-%data% 83 (i j) 84 ((1 ldc) (1 *)) 85 c-%offset%) 86 zero) 87 label10)) 88 label20))) 89 (t 90 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 91 ((> j n) nil) 92 (tagbody 93 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 94 ((> i 95 (f2cl-lib:int-add j 96 (f2cl-lib:int-sub 1))) 97 nil) 98 (tagbody 99 (setf (f2cl-lib:fref c-%data% 100 (i j) 101 ((1 ldc) (1 *)) 102 c-%offset%) 103 (* beta 104 (f2cl-lib:fref c-%data% 105 (i j) 106 ((1 ldc) (1 *)) 107 c-%offset%))) 108 label30)) 109 (setf (f2cl-lib:fref c-%data% 110 (j j) 111 ((1 ldc) (1 *)) 112 c-%offset%) 113 (coerce 114 (* beta 115 (f2cl-lib:dble 116 (f2cl-lib:fref c-%data% 117 (j j) 118 ((1 ldc) (1 *)) 119 c-%offset%))) 120 'f2cl-lib:complex16)) 121 label40))))) 122 (t 123 (cond 124 ((= beta (f2cl-lib:dble zero)) 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 zero) 136 label50)) 137 label60))) 138 (t 139 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 140 ((> j n) nil) 141 (tagbody 142 (setf (f2cl-lib:fref c-%data% 143 (j j) 144 ((1 ldc) (1 *)) 145 c-%offset%) 146 (coerce 147 (* beta 148 (f2cl-lib:dble 149 (f2cl-lib:fref c-%data% 150 (j j) 151 ((1 ldc) (1 *)) 152 c-%offset%))) 153 'f2cl-lib:complex16)) 154 (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) 155 (f2cl-lib:int-add i 1)) 156 ((> i n) nil) 157 (tagbody 158 (setf (f2cl-lib:fref c-%data% 159 (i j) 160 ((1 ldc) (1 *)) 161 c-%offset%) 162 (* beta 163 (f2cl-lib:fref c-%data% 164 (i j) 165 ((1 ldc) (1 *)) 166 c-%offset%))) 167 label70)) 168 label80)))))) 169 (go end_label))) 170 (cond 171 ((lsame trans "N") 172 (cond 173 (upper 174 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 175 ((> j n) nil) 176 (tagbody 177 (cond 178 ((= beta (f2cl-lib:dble zero)) 179 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 180 ((> i j) nil) 181 (tagbody 182 (setf (f2cl-lib:fref c-%data% 183 (i j) 184 ((1 ldc) (1 *)) 185 c-%offset%) 186 zero) 187 label90))) 188 ((/= beta one) 189 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 190 ((> i 191 (f2cl-lib:int-add j 192 (f2cl-lib:int-sub 1))) 193 nil) 194 (tagbody 195 (setf (f2cl-lib:fref c-%data% 196 (i j) 197 ((1 ldc) (1 *)) 198 c-%offset%) 199 (* beta 200 (f2cl-lib:fref c-%data% 201 (i j) 202 ((1 ldc) (1 *)) 203 c-%offset%))) 204 label100)) 205 (setf (f2cl-lib:fref c-%data% 206 (j j) 207 ((1 ldc) (1 *)) 208 c-%offset%) 209 (coerce 210 (* beta 211 (f2cl-lib:dble 212 (f2cl-lib:fref c-%data% 213 (j j) 214 ((1 ldc) (1 *)) 215 c-%offset%))) 216 'f2cl-lib:complex16))) 217 (t 218 (setf (f2cl-lib:fref c-%data% 219 (j j) 220 ((1 ldc) (1 *)) 221 c-%offset%) 222 (coerce 223 (f2cl-lib:dble 224 (f2cl-lib:fref c-%data% 225 (j j) 226 ((1 ldc) (1 *)) 227 c-%offset%)) 228 'f2cl-lib:complex16)))) 229 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 230 ((> l k) nil) 231 (tagbody 232 (cond 233 ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) 234 (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) 235 (setf temp1 236 (* alpha 237 (f2cl-lib:dconjg 238 (f2cl-lib:fref b-%data% 239 (j l) 240 ((1 ldb$) (1 *)) 241 b-%offset%)))) 242 (setf temp2 243 (coerce 244 (f2cl-lib:dconjg 245 (* alpha 246 (f2cl-lib:fref a-%data% 247 (j l) 248 ((1 lda) (1 *)) 249 a-%offset%))) 250 'f2cl-lib:complex16)) 251 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 252 ((> i 253 (f2cl-lib:int-add j 254 (f2cl-lib:int-sub 255 1))) 256 nil) 257 (tagbody 258 (setf (f2cl-lib:fref c-%data% 259 (i j) 260 ((1 ldc) (1 *)) 261 c-%offset%) 262 (+ 263 (f2cl-lib:fref c-%data% 264 (i j) 265 ((1 ldc) (1 *)) 266 c-%offset%) 267 (* 268 (f2cl-lib:fref a-%data% 269 (i l) 270 ((1 lda) (1 *)) 271 a-%offset%) 272 temp1) 273 (* 274 (f2cl-lib:fref b-%data% 275 (i l) 276 ((1 ldb$) (1 *)) 277 b-%offset%) 278 temp2))) 279 label110)) 280 (setf (f2cl-lib:fref c-%data% 281 (j j) 282 ((1 ldc) (1 *)) 283 c-%offset%) 284 (coerce 285 (+ 286 (f2cl-lib:dble 287 (f2cl-lib:fref c-%data% 288 (j j) 289 ((1 ldc) (1 *)) 290 c-%offset%)) 291 (f2cl-lib:dble 292 (+ 293 (* 294 (f2cl-lib:fref a-%data% 295 (j l) 296 ((1 lda) (1 *)) 297 a-%offset%) 298 temp1) 299 (* 300 (f2cl-lib:fref b-%data% 301 (j l) 302 ((1 ldb$) (1 *)) 303 b-%offset%) 304 temp2)))) 305 'f2cl-lib:complex16)))) 306 label120)) 307 label130))) 308 (t 309 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 310 ((> j n) nil) 311 (tagbody 312 (cond 313 ((= beta (f2cl-lib:dble zero)) 314 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) 315 ((> i n) nil) 316 (tagbody 317 (setf (f2cl-lib:fref c-%data% 318 (i j) 319 ((1 ldc) (1 *)) 320 c-%offset%) 321 zero) 322 label140))) 323 ((/= beta one) 324 (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) 325 (f2cl-lib:int-add i 1)) 326 ((> i n) nil) 327 (tagbody 328 (setf (f2cl-lib:fref c-%data% 329 (i j) 330 ((1 ldc) (1 *)) 331 c-%offset%) 332 (* beta 333 (f2cl-lib:fref c-%data% 334 (i j) 335 ((1 ldc) (1 *)) 336 c-%offset%))) 337 label150)) 338 (setf (f2cl-lib:fref c-%data% 339 (j j) 340 ((1 ldc) (1 *)) 341 c-%offset%) 342 (coerce 343 (* beta 344 (f2cl-lib:dble 345 (f2cl-lib:fref c-%data% 346 (j j) 347 ((1 ldc) (1 *)) 348 c-%offset%))) 349 'f2cl-lib:complex16))) 350 (t 351 (setf (f2cl-lib:fref c-%data% 352 (j j) 353 ((1 ldc) (1 *)) 354 c-%offset%) 355 (coerce 356 (f2cl-lib:dble 357 (f2cl-lib:fref c-%data% 358 (j j) 359 ((1 ldc) (1 *)) 360 c-%offset%)) 361 'f2cl-lib:complex16)))) 362 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 363 ((> l k) nil) 364 (tagbody 365 (cond 366 ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) 367 (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) 368 (setf temp1 369 (* alpha 370 (f2cl-lib:dconjg 371 (f2cl-lib:fref b-%data% 372 (j l) 373 ((1 ldb$) (1 *)) 374 b-%offset%)))) 375 (setf temp2 376 (coerce 377 (f2cl-lib:dconjg 378 (* alpha 379 (f2cl-lib:fref a-%data% 380 (j l) 381 ((1 lda) (1 *)) 382 a-%offset%))) 383 'f2cl-lib:complex16)) 384 (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) 385 (f2cl-lib:int-add i 1)) 386 ((> i n) nil) 387 (tagbody 388 (setf (f2cl-lib:fref c-%data% 389 (i j) 390 ((1 ldc) (1 *)) 391 c-%offset%) 392 (+ 393 (f2cl-lib:fref c-%data% 394 (i j) 395 ((1 ldc) (1 *)) 396 c-%offset%) 397 (* 398 (f2cl-lib:fref a-%data% 399 (i l) 400 ((1 lda) (1 *)) 401 a-%offset%) 402 temp1) 403 (* 404 (f2cl-lib:fref b-%data% 405 (i l) 406 ((1 ldb$) (1 *)) 407 b-%offset%) 408 temp2))) 409 label160)) 410 (setf (f2cl-lib:fref c-%data% 411 (j j) 412 ((1 ldc) (1 *)) 413 c-%offset%) 414 (coerce 415 (+ 416 (f2cl-lib:dble 417 (f2cl-lib:fref c-%data% 418 (j j) 419 ((1 ldc) (1 *)) 420 c-%offset%)) 421 (f2cl-lib:dble 422 (+ 423 (* 424 (f2cl-lib:fref a-%data% 425 (j l) 426 ((1 lda) (1 *)) 427 a-%offset%) 428 temp1) 429 (* 430 (f2cl-lib:fref b-%data% 431 (j l) 432 ((1 ldb$) (1 *)) 433 b-%offset%) 434 temp2)))) 435 'f2cl-lib:complex16)))) 436 label170)) 437 label180))))) 438 (t 439 (cond 440 (upper 441 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 442 ((> j n) nil) 443 (tagbody 444 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 445 ((> i j) nil) 446 (tagbody 447 (setf temp1 zero) 448 (setf temp2 zero) 449 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 450 ((> l k) nil) 451 (tagbody 452 (setf temp1 453 (+ temp1 454 (* 455 (f2cl-lib:dconjg 456 (f2cl-lib:fref a-%data% 457 (l i) 458 ((1 lda) (1 *)) 459 a-%offset%)) 460 (f2cl-lib:fref b-%data% 461 (l j) 462 ((1 ldb$) (1 *)) 463 b-%offset%)))) 464 (setf temp2 465 (+ temp2 466 (* 467 (f2cl-lib:dconjg 468 (f2cl-lib:fref b-%data% 469 (l i) 470 ((1 ldb$) (1 *)) 471 b-%offset%)) 472 (f2cl-lib:fref a-%data% 473 (l j) 474 ((1 lda) (1 *)) 475 a-%offset%)))) 476 label190)) 477 (cond 478 ((= i j) 479 (cond 480 ((= beta (f2cl-lib:dble zero)) 481 (setf (f2cl-lib:fref c-%data% 482 (j j) 483 ((1 ldc) (1 *)) 484 c-%offset%) 485 (coerce 486 (f2cl-lib:dble 487 (+ (* alpha temp1) 488 (* (f2cl-lib:dconjg alpha) temp2))) 489 'f2cl-lib:complex16))) 490 (t 491 (setf (f2cl-lib:fref c-%data% 492 (j j) 493 ((1 ldc) (1 *)) 494 c-%offset%) 495 (coerce 496 (+ 497 (* beta 498 (f2cl-lib:dble 499 (f2cl-lib:fref c-%data% 500 (j j) 501 ((1 ldc) (1 *)) 502 c-%offset%))) 503 (f2cl-lib:dble 504 (+ (* alpha temp1) 505 (* (f2cl-lib:dconjg alpha) temp2)))) 506 'f2cl-lib:complex16))))) 507 (t 508 (cond 509 ((= beta (f2cl-lib:dble zero)) 510 (setf (f2cl-lib:fref c-%data% 511 (i j) 512 ((1 ldc) (1 *)) 513 c-%offset%) 514 (+ (* alpha temp1) 515 (* (f2cl-lib:dconjg alpha) temp2)))) 516 (t 517 (setf (f2cl-lib:fref c-%data% 518 (i j) 519 ((1 ldc) (1 *)) 520 c-%offset%) 521 (+ 522 (* beta 523 (f2cl-lib:fref c-%data% 524 (i j) 525 ((1 ldc) (1 *)) 526 c-%offset%)) 527 (* alpha temp1) 528 (* (f2cl-lib:dconjg alpha) temp2))))))) 529 label200)) 530 label210))) 531 (t 532 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 533 ((> j n) nil) 534 (tagbody 535 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) 536 ((> i n) nil) 537 (tagbody 538 (setf temp1 zero) 539 (setf temp2 zero) 540 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 541 ((> l k) nil) 542 (tagbody 543 (setf temp1 544 (+ temp1 545 (* 546 (f2cl-lib:dconjg 547 (f2cl-lib:fref a-%data% 548 (l i) 549 ((1 lda) (1 *)) 550 a-%offset%)) 551 (f2cl-lib:fref b-%data% 552 (l j) 553 ((1 ldb$) (1 *)) 554 b-%offset%)))) 555 (setf temp2 556 (+ temp2 557 (* 558 (f2cl-lib:dconjg 559 (f2cl-lib:fref b-%data% 560 (l i) 561 ((1 ldb$) (1 *)) 562 b-%offset%)) 563 (f2cl-lib:fref a-%data% 564 (l j) 565 ((1 lda) (1 *)) 566 a-%offset%)))) 567 label220)) 568 (cond 569 ((= i j) 570 (cond 571 ((= beta (f2cl-lib:dble zero)) 572 (setf (f2cl-lib:fref c-%data% 573 (j j) 574 ((1 ldc) (1 *)) 575 c-%offset%) 576 (coerce 577 (f2cl-lib:dble 578 (+ (* alpha temp1) 579 (* (f2cl-lib:dconjg alpha) temp2))) 580 'f2cl-lib:complex16))) 581 (t 582 (setf (f2cl-lib:fref c-%data% 583 (j j) 584 ((1 ldc) (1 *)) 585 c-%offset%) 586 (coerce 587 (+ 588 (* beta 589 (f2cl-lib:dble 590 (f2cl-lib:fref c-%data% 591 (j j) 592 ((1 ldc) (1 *)) 593 c-%offset%))) 594 (f2cl-lib:dble 595 (+ (* alpha temp1) 596 (* (f2cl-lib:dconjg alpha) temp2)))) 597 'f2cl-lib:complex16))))) 598 (t 599 (cond 600 ((= beta (f2cl-lib:dble zero)) 601 (setf (f2cl-lib:fref c-%data% 602 (i j) 603 ((1 ldc) (1 *)) 604 c-%offset%) 605 (+ (* alpha temp1) 606 (* (f2cl-lib:dconjg alpha) temp2)))) 607 (t 608 (setf (f2cl-lib:fref c-%data% 609 (i j) 610 ((1 ldc) (1 *)) 611 c-%offset%) 612 (+ 613 (* beta 614 (f2cl-lib:fref c-%data% 615 (i j) 616 ((1 ldc) (1 *)) 617 c-%offset%)) 618 (* alpha temp1) 619 (* (f2cl-lib:dconjg alpha) temp2))))))) 620 label230)) 621 label240)))))) 622 (go end_label) 623 end_label 624 (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) 625 626(in-package #-gcl #:cl-user #+gcl "CL-USER") 627#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 628(eval-when (:load-toplevel :compile-toplevel :execute) 629 (setf (gethash 'fortran-to-lisp::zher2k 630 fortran-to-lisp::*f2cl-function-info*) 631 (fortran-to-lisp::make-f2cl-finfo 632 :arg-types '((simple-string) (simple-string) 633 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 634 (fortran-to-lisp::complex16) 635 (array fortran-to-lisp::complex16 (*)) 636 (fortran-to-lisp::integer4) 637 (array fortran-to-lisp::complex16 (*)) 638 (fortran-to-lisp::integer4) (double-float) 639 (array fortran-to-lisp::complex16 (*)) 640 (fortran-to-lisp::integer4)) 641 :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) 642 :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) 643 644