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