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