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