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