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* ((zero 0.0) (one 1.0) (two 2.0) (half 0.5) (eight 8.0)) 21 (declare (type (double-float 0.0 0.0) zero) 22 (type (double-float 1.0 1.0) one) 23 (type (double-float 2.0 2.0) two) 24 (type (double-float 0.5 0.5) half) 25 (type (double-float 8.0 8.0) eight) 26 (ignorable zero one two half eight)) 27 (let ((bswpiv 28 (make-array 4 :element-type 't :initial-contents '(nil t nil t))) 29 (xswpiv 30 (make-array 4 :element-type 't :initial-contents '(nil nil t t))) 31 (locu22 32 (make-array 4 33 :element-type 'f2cl-lib:integer4 34 :initial-contents '(4 3 2 1))) 35 (locl21 36 (make-array 4 37 :element-type 'f2cl-lib:integer4 38 :initial-contents '(2 1 4 3))) 39 (locu12 40 (make-array 4 41 :element-type 'f2cl-lib:integer4 42 :initial-contents '(3 4 1 2)))) 43 (declare (type (array f2cl-lib:logical (4)) bswpiv xswpiv) 44 (type (array f2cl-lib:integer4 (4)) locu22 locl21 locu12)) 45 (defun dlasy2 46 (ltranl ltranr isgn n1 n2 tl ldtl tr ldtr b ldb$ scale x ldx xnorm 47 info) 48 (declare (type (double-float) xnorm scale) 49 (type (array double-float (*)) x b tr tl) 50 (type (f2cl-lib:integer4) info ldx ldb$ ldtr ldtl n2 n1 isgn) 51 (type f2cl-lib:logical ltranr ltranl)) 52 (f2cl-lib:with-multi-array-data 53 ((tl double-float tl-%data% tl-%offset%) 54 (tr double-float tr-%data% tr-%offset%) 55 (b double-float b-%data% b-%offset%) 56 (x double-float x-%data% x-%offset%)) 57 (prog ((btmp (make-array 4 :element-type 'double-float)) 58 (t16 (make-array 16 :element-type 'double-float)) 59 (tmp (make-array 4 :element-type 'double-float)) 60 (x2 (make-array 2 :element-type 'double-float)) 61 (jpiv (make-array 4 :element-type 'f2cl-lib:integer4)) (bet 0.0) 62 (eps 0.0) (gam 0.0) (l21 0.0) (sgn 0.0) (smin 0.0) (smlnum 0.0) 63 (tau1 0.0) (temp 0.0) (u11 0.0) (u12 0.0) (u22 0.0) (xmax 0.0) 64 (i 0) (ip 0) (ipiv 0) (ipsv 0) (j 0) (jp 0) (jpsv 0) (k 0) 65 (bswap nil) (xswap nil)) 66 (declare (type (array double-float (16)) t16) 67 (type (array double-float (4)) btmp tmp) 68 (type (array double-float (2)) x2) 69 (type (array f2cl-lib:integer4 (4)) jpiv) 70 (type (double-float) bet eps gam l21 sgn smin smlnum tau1 71 temp u11 u12 u22 xmax) 72 (type (f2cl-lib:integer4) i ip ipiv ipsv j jp jpsv k) 73 (type f2cl-lib:logical bswap xswap)) 74 (setf info 0) 75 (if (or (= n1 0) (= n2 0)) (go end_label)) 76 (setf eps (dlamch "P")) 77 (setf smlnum (/ (dlamch "S") eps)) 78 (setf sgn (coerce (the f2cl-lib:integer4 isgn) 'double-float)) 79 (setf k (f2cl-lib:int-sub (f2cl-lib:int-add n1 n1 n2) 2)) 80 (f2cl-lib:computed-goto (label10 label20 label30 label50) k) 81 label10 82 (setf tau1 83 (+ 84 (f2cl-lib:fref tl-%data% (1 1) ((1 ldtl) (1 *)) tl-%offset%) 85 (* sgn 86 (f2cl-lib:fref tr-%data% 87 (1 1) 88 ((1 ldtr) (1 *)) 89 tr-%offset%)))) 90 (setf bet (abs tau1)) 91 (cond 92 ((<= bet smlnum) 93 (setf tau1 smlnum) 94 (setf bet smlnum) 95 (setf info 1))) 96 (setf scale one) 97 (setf gam 98 (abs 99 (f2cl-lib:fref b-%data% (1 1) ((1 ldb$) (1 *)) b-%offset%))) 100 (if (> (* smlnum gam) bet) (setf scale (/ one gam))) 101 (setf (f2cl-lib:fref x-%data% (1 1) ((1 ldx) (1 *)) x-%offset%) 102 (/ 103 (* 104 (f2cl-lib:fref b-%data% (1 1) ((1 ldb$) (1 *)) b-%offset%) 105 scale) 106 tau1)) 107 (setf xnorm 108 (abs 109 (f2cl-lib:fref x-%data% (1 1) ((1 ldx) (1 *)) x-%offset%))) 110 (go end_label) 111 label20 112 (setf smin 113 (max 114 (* eps 115 (max 116 (abs 117 (f2cl-lib:fref tl-%data% 118 (1 1) 119 ((1 ldtl) (1 *)) 120 tl-%offset%)) 121 (abs 122 (f2cl-lib:fref tr-%data% 123 (1 1) 124 ((1 ldtr) (1 *)) 125 tr-%offset%)) 126 (abs 127 (f2cl-lib:fref tr-%data% 128 (1 2) 129 ((1 ldtr) (1 *)) 130 tr-%offset%)) 131 (abs 132 (f2cl-lib:fref tr-%data% 133 (2 1) 134 ((1 ldtr) (1 *)) 135 tr-%offset%)) 136 (abs 137 (f2cl-lib:fref tr-%data% 138 (2 2) 139 ((1 ldtr) (1 *)) 140 tr-%offset%)))) 141 smlnum)) 142 (setf (f2cl-lib:fref tmp (1) ((1 4))) 143 (+ 144 (f2cl-lib:fref tl-%data% (1 1) ((1 ldtl) (1 *)) tl-%offset%) 145 (* sgn 146 (f2cl-lib:fref tr-%data% 147 (1 1) 148 ((1 ldtr) (1 *)) 149 tr-%offset%)))) 150 (setf (f2cl-lib:fref tmp (4) ((1 4))) 151 (+ 152 (f2cl-lib:fref tl-%data% (1 1) ((1 ldtl) (1 *)) tl-%offset%) 153 (* sgn 154 (f2cl-lib:fref tr-%data% 155 (2 2) 156 ((1 ldtr) (1 *)) 157 tr-%offset%)))) 158 (cond 159 (ltranr 160 (setf (f2cl-lib:fref tmp (2) ((1 4))) 161 (* sgn 162 (f2cl-lib:fref tr-%data% 163 (2 1) 164 ((1 ldtr) (1 *)) 165 tr-%offset%))) 166 (setf (f2cl-lib:fref tmp (3) ((1 4))) 167 (* sgn 168 (f2cl-lib:fref tr-%data% 169 (1 2) 170 ((1 ldtr) (1 *)) 171 tr-%offset%)))) 172 (t 173 (setf (f2cl-lib:fref tmp (2) ((1 4))) 174 (* sgn 175 (f2cl-lib:fref tr-%data% 176 (1 2) 177 ((1 ldtr) (1 *)) 178 tr-%offset%))) 179 (setf (f2cl-lib:fref tmp (3) ((1 4))) 180 (* sgn 181 (f2cl-lib:fref tr-%data% 182 (2 1) 183 ((1 ldtr) (1 *)) 184 tr-%offset%))))) 185 (setf (f2cl-lib:fref btmp (1) ((1 4))) 186 (f2cl-lib:fref b-%data% (1 1) ((1 ldb$) (1 *)) b-%offset%)) 187 (setf (f2cl-lib:fref btmp (2) ((1 4))) 188 (f2cl-lib:fref b-%data% (1 2) ((1 ldb$) (1 *)) b-%offset%)) 189 (go label40) 190 label30 191 (setf smin 192 (max 193 (* eps 194 (max 195 (abs 196 (f2cl-lib:fref tr-%data% 197 (1 1) 198 ((1 ldtr) (1 *)) 199 tr-%offset%)) 200 (abs 201 (f2cl-lib:fref tl-%data% 202 (1 1) 203 ((1 ldtl) (1 *)) 204 tl-%offset%)) 205 (abs 206 (f2cl-lib:fref tl-%data% 207 (1 2) 208 ((1 ldtl) (1 *)) 209 tl-%offset%)) 210 (abs 211 (f2cl-lib:fref tl-%data% 212 (2 1) 213 ((1 ldtl) (1 *)) 214 tl-%offset%)) 215 (abs 216 (f2cl-lib:fref tl-%data% 217 (2 2) 218 ((1 ldtl) (1 *)) 219 tl-%offset%)))) 220 smlnum)) 221 (setf (f2cl-lib:fref tmp (1) ((1 4))) 222 (+ 223 (f2cl-lib:fref tl-%data% (1 1) ((1 ldtl) (1 *)) tl-%offset%) 224 (* sgn 225 (f2cl-lib:fref tr-%data% 226 (1 1) 227 ((1 ldtr) (1 *)) 228 tr-%offset%)))) 229 (setf (f2cl-lib:fref tmp (4) ((1 4))) 230 (+ 231 (f2cl-lib:fref tl-%data% (2 2) ((1 ldtl) (1 *)) tl-%offset%) 232 (* sgn 233 (f2cl-lib:fref tr-%data% 234 (1 1) 235 ((1 ldtr) (1 *)) 236 tr-%offset%)))) 237 (cond 238 (ltranl 239 (setf (f2cl-lib:fref tmp (2) ((1 4))) 240 (f2cl-lib:fref tl-%data% 241 (1 2) 242 ((1 ldtl) (1 *)) 243 tl-%offset%)) 244 (setf (f2cl-lib:fref tmp (3) ((1 4))) 245 (f2cl-lib:fref tl-%data% 246 (2 1) 247 ((1 ldtl) (1 *)) 248 tl-%offset%))) 249 (t 250 (setf (f2cl-lib:fref tmp (2) ((1 4))) 251 (f2cl-lib:fref tl-%data% 252 (2 1) 253 ((1 ldtl) (1 *)) 254 tl-%offset%)) 255 (setf (f2cl-lib:fref tmp (3) ((1 4))) 256 (f2cl-lib:fref tl-%data% 257 (1 2) 258 ((1 ldtl) (1 *)) 259 tl-%offset%)))) 260 (setf (f2cl-lib:fref btmp (1) ((1 4))) 261 (f2cl-lib:fref b-%data% (1 1) ((1 ldb$) (1 *)) b-%offset%)) 262 (setf (f2cl-lib:fref btmp (2) ((1 4))) 263 (f2cl-lib:fref b-%data% (2 1) ((1 ldb$) (1 *)) b-%offset%)) 264 label40 265 (setf ipiv (idamax 4 tmp 1)) 266 (setf u11 (f2cl-lib:fref tmp (ipiv) ((1 4)))) 267 (cond 268 ((<= (abs u11) smin) 269 (setf info 1) 270 (setf u11 smin))) 271 (setf u12 272 (f2cl-lib:fref tmp 273 ((f2cl-lib:fref locu12 (ipiv) ((1 4)))) 274 ((1 4)))) 275 (setf l21 276 (/ 277 (f2cl-lib:fref tmp 278 ((f2cl-lib:fref locl21 (ipiv) ((1 4)))) 279 ((1 4))) 280 u11)) 281 (setf u22 282 (- 283 (f2cl-lib:fref tmp 284 ((f2cl-lib:fref locu22 (ipiv) ((1 4)))) 285 ((1 4))) 286 (* u12 l21))) 287 (setf xswap (f2cl-lib:fref xswpiv (ipiv) ((1 4)))) 288 (setf bswap (f2cl-lib:fref bswpiv (ipiv) ((1 4)))) 289 (cond 290 ((<= (abs u22) smin) 291 (setf info 1) 292 (setf u22 smin))) 293 (cond 294 (bswap 295 (setf temp (f2cl-lib:fref btmp (2) ((1 4)))) 296 (setf (f2cl-lib:fref btmp (2) ((1 4))) 297 (- (f2cl-lib:fref btmp (1) ((1 4))) (* l21 temp))) 298 (setf (f2cl-lib:fref btmp (1) ((1 4))) temp)) 299 (t 300 (setf (f2cl-lib:fref btmp (2) ((1 4))) 301 (- (f2cl-lib:fref btmp (2) ((1 4))) 302 (* l21 (f2cl-lib:fref btmp (1) ((1 4)))))))) 303 (setf scale one) 304 (cond 305 ((or 306 (> (* two smlnum (abs (f2cl-lib:fref btmp (2) ((1 4))))) 307 (abs u22)) 308 (> (* two smlnum (abs (f2cl-lib:fref btmp (1) ((1 4))))) 309 (abs u11))) 310 (setf scale 311 (/ half 312 (max (abs (f2cl-lib:fref btmp (1) ((1 4)))) 313 (abs (f2cl-lib:fref btmp (2) ((1 4))))))) 314 (setf (f2cl-lib:fref btmp (1) ((1 4))) 315 (* (f2cl-lib:fref btmp (1) ((1 4))) scale)) 316 (setf (f2cl-lib:fref btmp (2) ((1 4))) 317 (* (f2cl-lib:fref btmp (2) ((1 4))) scale)))) 318 (setf (f2cl-lib:fref x2 (2) ((1 2))) 319 (/ (f2cl-lib:fref btmp (2) ((1 4))) u22)) 320 (setf (f2cl-lib:fref x2 (1) ((1 2))) 321 (- (/ (f2cl-lib:fref btmp (1) ((1 4))) u11) 322 (* (/ u12 u11) (f2cl-lib:fref x2 (2) ((1 2)))))) 323 (cond 324 (xswap 325 (setf temp (f2cl-lib:fref x2 (2) ((1 2)))) 326 (setf (f2cl-lib:fref x2 (2) ((1 2))) 327 (f2cl-lib:fref x2 (1) ((1 2)))) 328 (setf (f2cl-lib:fref x2 (1) ((1 2))) temp))) 329 (setf (f2cl-lib:fref x-%data% (1 1) ((1 ldx) (1 *)) x-%offset%) 330 (f2cl-lib:fref x2 (1) ((1 2)))) 331 (cond 332 ((= n1 1) 333 (setf (f2cl-lib:fref x-%data% (1 2) ((1 ldx) (1 *)) x-%offset%) 334 (f2cl-lib:fref x2 (2) ((1 2)))) 335 (setf xnorm 336 (+ 337 (abs 338 (f2cl-lib:fref x-%data% 339 (1 1) 340 ((1 ldx) (1 *)) 341 x-%offset%)) 342 (abs 343 (f2cl-lib:fref x-%data% 344 (1 2) 345 ((1 ldx) (1 *)) 346 x-%offset%))))) 347 (t 348 (setf (f2cl-lib:fref x-%data% (2 1) ((1 ldx) (1 *)) x-%offset%) 349 (f2cl-lib:fref x2 (2) ((1 2)))) 350 (setf xnorm 351 (max 352 (abs 353 (f2cl-lib:fref x-%data% 354 (1 1) 355 ((1 ldx) (1 *)) 356 x-%offset%)) 357 (abs 358 (f2cl-lib:fref x-%data% 359 (2 1) 360 ((1 ldx) (1 *)) 361 x-%offset%)))))) 362 (go end_label) 363 label50 364 (setf smin 365 (max 366 (abs 367 (f2cl-lib:fref tr-%data% 368 (1 1) 369 ((1 ldtr) (1 *)) 370 tr-%offset%)) 371 (abs 372 (f2cl-lib:fref tr-%data% 373 (1 2) 374 ((1 ldtr) (1 *)) 375 tr-%offset%)) 376 (abs 377 (f2cl-lib:fref tr-%data% 378 (2 1) 379 ((1 ldtr) (1 *)) 380 tr-%offset%)) 381 (abs 382 (f2cl-lib:fref tr-%data% 383 (2 2) 384 ((1 ldtr) (1 *)) 385 tr-%offset%)))) 386 (setf smin 387 (max smin 388 (abs 389 (f2cl-lib:fref tl-%data% 390 (1 1) 391 ((1 ldtl) (1 *)) 392 tl-%offset%)) 393 (abs 394 (f2cl-lib:fref tl-%data% 395 (1 2) 396 ((1 ldtl) (1 *)) 397 tl-%offset%)) 398 (abs 399 (f2cl-lib:fref tl-%data% 400 (2 1) 401 ((1 ldtl) (1 *)) 402 tl-%offset%)) 403 (abs 404 (f2cl-lib:fref tl-%data% 405 (2 2) 406 ((1 ldtl) (1 *)) 407 tl-%offset%)))) 408 (setf smin (max (* eps smin) smlnum)) 409 (setf (f2cl-lib:fref btmp (1) ((1 4))) zero) 410 (dcopy 16 btmp 0 t16 1) 411 (setf (f2cl-lib:fref t16 (1 1) ((1 4) (1 4))) 412 (+ 413 (f2cl-lib:fref tl-%data% (1 1) ((1 ldtl) (1 *)) tl-%offset%) 414 (* sgn 415 (f2cl-lib:fref tr-%data% 416 (1 1) 417 ((1 ldtr) (1 *)) 418 tr-%offset%)))) 419 (setf (f2cl-lib:fref t16 (2 2) ((1 4) (1 4))) 420 (+ 421 (f2cl-lib:fref tl-%data% (2 2) ((1 ldtl) (1 *)) tl-%offset%) 422 (* sgn 423 (f2cl-lib:fref tr-%data% 424 (1 1) 425 ((1 ldtr) (1 *)) 426 tr-%offset%)))) 427 (setf (f2cl-lib:fref t16 (3 3) ((1 4) (1 4))) 428 (+ 429 (f2cl-lib:fref tl-%data% (1 1) ((1 ldtl) (1 *)) tl-%offset%) 430 (* sgn 431 (f2cl-lib:fref tr-%data% 432 (2 2) 433 ((1 ldtr) (1 *)) 434 tr-%offset%)))) 435 (setf (f2cl-lib:fref t16 (4 4) ((1 4) (1 4))) 436 (+ 437 (f2cl-lib:fref tl-%data% (2 2) ((1 ldtl) (1 *)) tl-%offset%) 438 (* sgn 439 (f2cl-lib:fref tr-%data% 440 (2 2) 441 ((1 ldtr) (1 *)) 442 tr-%offset%)))) 443 (cond 444 (ltranl 445 (setf (f2cl-lib:fref t16 (1 2) ((1 4) (1 4))) 446 (f2cl-lib:fref tl-%data% 447 (2 1) 448 ((1 ldtl) (1 *)) 449 tl-%offset%)) 450 (setf (f2cl-lib:fref t16 (2 1) ((1 4) (1 4))) 451 (f2cl-lib:fref tl-%data% 452 (1 2) 453 ((1 ldtl) (1 *)) 454 tl-%offset%)) 455 (setf (f2cl-lib:fref t16 (3 4) ((1 4) (1 4))) 456 (f2cl-lib:fref tl-%data% 457 (2 1) 458 ((1 ldtl) (1 *)) 459 tl-%offset%)) 460 (setf (f2cl-lib:fref t16 (4 3) ((1 4) (1 4))) 461 (f2cl-lib:fref tl-%data% 462 (1 2) 463 ((1 ldtl) (1 *)) 464 tl-%offset%))) 465 (t 466 (setf (f2cl-lib:fref t16 (1 2) ((1 4) (1 4))) 467 (f2cl-lib:fref tl-%data% 468 (1 2) 469 ((1 ldtl) (1 *)) 470 tl-%offset%)) 471 (setf (f2cl-lib:fref t16 (2 1) ((1 4) (1 4))) 472 (f2cl-lib:fref tl-%data% 473 (2 1) 474 ((1 ldtl) (1 *)) 475 tl-%offset%)) 476 (setf (f2cl-lib:fref t16 (3 4) ((1 4) (1 4))) 477 (f2cl-lib:fref tl-%data% 478 (1 2) 479 ((1 ldtl) (1 *)) 480 tl-%offset%)) 481 (setf (f2cl-lib:fref t16 (4 3) ((1 4) (1 4))) 482 (f2cl-lib:fref tl-%data% 483 (2 1) 484 ((1 ldtl) (1 *)) 485 tl-%offset%)))) 486 (cond 487 (ltranr 488 (setf (f2cl-lib:fref t16 (1 3) ((1 4) (1 4))) 489 (* sgn 490 (f2cl-lib:fref tr-%data% 491 (1 2) 492 ((1 ldtr) (1 *)) 493 tr-%offset%))) 494 (setf (f2cl-lib:fref t16 (2 4) ((1 4) (1 4))) 495 (* sgn 496 (f2cl-lib:fref tr-%data% 497 (1 2) 498 ((1 ldtr) (1 *)) 499 tr-%offset%))) 500 (setf (f2cl-lib:fref t16 (3 1) ((1 4) (1 4))) 501 (* sgn 502 (f2cl-lib:fref tr-%data% 503 (2 1) 504 ((1 ldtr) (1 *)) 505 tr-%offset%))) 506 (setf (f2cl-lib:fref t16 (4 2) ((1 4) (1 4))) 507 (* sgn 508 (f2cl-lib:fref tr-%data% 509 (2 1) 510 ((1 ldtr) (1 *)) 511 tr-%offset%)))) 512 (t 513 (setf (f2cl-lib:fref t16 (1 3) ((1 4) (1 4))) 514 (* sgn 515 (f2cl-lib:fref tr-%data% 516 (2 1) 517 ((1 ldtr) (1 *)) 518 tr-%offset%))) 519 (setf (f2cl-lib:fref t16 (2 4) ((1 4) (1 4))) 520 (* sgn 521 (f2cl-lib:fref tr-%data% 522 (2 1) 523 ((1 ldtr) (1 *)) 524 tr-%offset%))) 525 (setf (f2cl-lib:fref t16 (3 1) ((1 4) (1 4))) 526 (* sgn 527 (f2cl-lib:fref tr-%data% 528 (1 2) 529 ((1 ldtr) (1 *)) 530 tr-%offset%))) 531 (setf (f2cl-lib:fref t16 (4 2) ((1 4) (1 4))) 532 (* sgn 533 (f2cl-lib:fref tr-%data% 534 (1 2) 535 ((1 ldtr) (1 *)) 536 tr-%offset%))))) 537 (setf (f2cl-lib:fref btmp (1) ((1 4))) 538 (f2cl-lib:fref b-%data% (1 1) ((1 ldb$) (1 *)) b-%offset%)) 539 (setf (f2cl-lib:fref btmp (2) ((1 4))) 540 (f2cl-lib:fref b-%data% (2 1) ((1 ldb$) (1 *)) b-%offset%)) 541 (setf (f2cl-lib:fref btmp (3) ((1 4))) 542 (f2cl-lib:fref b-%data% (1 2) ((1 ldb$) (1 *)) b-%offset%)) 543 (setf (f2cl-lib:fref btmp (4) ((1 4))) 544 (f2cl-lib:fref b-%data% (2 2) ((1 ldb$) (1 *)) b-%offset%)) 545 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 546 ((> i 3) nil) 547 (tagbody 548 (setf xmax zero) 549 (f2cl-lib:fdo (ip i (f2cl-lib:int-add ip 1)) 550 ((> ip 4) nil) 551 (tagbody 552 (f2cl-lib:fdo (jp i (f2cl-lib:int-add jp 1)) 553 ((> jp 4) nil) 554 (tagbody 555 (cond 556 ((>= (abs (f2cl-lib:fref t16 (ip jp) ((1 4) (1 4)))) 557 xmax) 558 (setf xmax 559 (abs 560 (f2cl-lib:fref t16 (ip jp) ((1 4) (1 4))))) 561 (setf ipsv ip) 562 (setf jpsv jp))) 563 label60)) 564 label70)) 565 (cond 566 ((/= ipsv i) 567 (dswap 4 568 (f2cl-lib:array-slice t16 569 double-float 570 (ipsv 1) 571 ((1 4) (1 4))) 572 4 (f2cl-lib:array-slice t16 double-float (i 1) ((1 4) (1 4))) 573 4) 574 (setf temp (f2cl-lib:fref btmp (i) ((1 4)))) 575 (setf (f2cl-lib:fref btmp (i) ((1 4))) 576 (f2cl-lib:fref btmp (ipsv) ((1 4)))) 577 (setf (f2cl-lib:fref btmp (ipsv) ((1 4))) temp))) 578 (if (/= jpsv i) 579 (dswap 4 580 (f2cl-lib:array-slice t16 581 double-float 582 (1 jpsv) 583 ((1 4) (1 4))) 584 1 585 (f2cl-lib:array-slice t16 double-float (1 i) ((1 4) (1 4))) 586 1)) 587 (setf (f2cl-lib:fref jpiv (i) ((1 4))) jpsv) 588 (cond 589 ((< (abs (f2cl-lib:fref t16 (i i) ((1 4) (1 4)))) smin) 590 (setf info 1) 591 (setf (f2cl-lib:fref t16 (i i) ((1 4) (1 4))) smin))) 592 (f2cl-lib:fdo (j (f2cl-lib:int-add i 1) (f2cl-lib:int-add j 1)) 593 ((> j 4) nil) 594 (tagbody 595 (setf (f2cl-lib:fref t16 (j i) ((1 4) (1 4))) 596 (/ (f2cl-lib:fref t16 (j i) ((1 4) (1 4))) 597 (f2cl-lib:fref t16 (i i) ((1 4) (1 4))))) 598 (setf (f2cl-lib:fref btmp (j) ((1 4))) 599 (- (f2cl-lib:fref btmp (j) ((1 4))) 600 (* (f2cl-lib:fref t16 (j i) ((1 4) (1 4))) 601 (f2cl-lib:fref btmp (i) ((1 4)))))) 602 (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) 603 (f2cl-lib:int-add k 1)) 604 ((> k 4) nil) 605 (tagbody 606 (setf (f2cl-lib:fref t16 (j k) ((1 4) (1 4))) 607 (- (f2cl-lib:fref t16 (j k) ((1 4) (1 4))) 608 (* (f2cl-lib:fref t16 (j i) ((1 4) (1 4))) 609 (f2cl-lib:fref t16 (i k) ((1 4) (1 4)))))) 610 label80)) 611 label90)) 612 label100)) 613 (if (< (abs (f2cl-lib:fref t16 (4 4) ((1 4) (1 4)))) smin) 614 (setf (f2cl-lib:fref t16 (4 4) ((1 4) (1 4))) smin)) 615 (setf scale one) 616 (cond 617 ((or 618 (> (* eight smlnum (abs (f2cl-lib:fref btmp (1) ((1 4))))) 619 (abs (f2cl-lib:fref t16 (1 1) ((1 4) (1 4))))) 620 (> (* eight smlnum (abs (f2cl-lib:fref btmp (2) ((1 4))))) 621 (abs (f2cl-lib:fref t16 (2 2) ((1 4) (1 4))))) 622 (> (* eight smlnum (abs (f2cl-lib:fref btmp (3) ((1 4))))) 623 (abs (f2cl-lib:fref t16 (3 3) ((1 4) (1 4))))) 624 (> (* eight smlnum (abs (f2cl-lib:fref btmp (4) ((1 4))))) 625 (abs (f2cl-lib:fref t16 (4 4) ((1 4) (1 4)))))) 626 (setf scale 627 (/ (/ one eight) 628 (max (abs (f2cl-lib:fref btmp (1) ((1 4)))) 629 (abs (f2cl-lib:fref btmp (2) ((1 4)))) 630 (abs (f2cl-lib:fref btmp (3) ((1 4)))) 631 (abs (f2cl-lib:fref btmp (4) ((1 4))))))) 632 (setf (f2cl-lib:fref btmp (1) ((1 4))) 633 (* (f2cl-lib:fref btmp (1) ((1 4))) scale)) 634 (setf (f2cl-lib:fref btmp (2) ((1 4))) 635 (* (f2cl-lib:fref btmp (2) ((1 4))) scale)) 636 (setf (f2cl-lib:fref btmp (3) ((1 4))) 637 (* (f2cl-lib:fref btmp (3) ((1 4))) scale)) 638 (setf (f2cl-lib:fref btmp (4) ((1 4))) 639 (* (f2cl-lib:fref btmp (4) ((1 4))) scale)))) 640 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 641 ((> i 4) nil) 642 (tagbody 643 (setf k (f2cl-lib:int-sub 5 i)) 644 (setf temp (/ one (f2cl-lib:fref t16 (k k) ((1 4) (1 4))))) 645 (setf (f2cl-lib:fref tmp (k) ((1 4))) 646 (* (f2cl-lib:fref btmp (k) ((1 4))) temp)) 647 (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) (f2cl-lib:int-add j 1)) 648 ((> j 4) nil) 649 (tagbody 650 (setf (f2cl-lib:fref tmp (k) ((1 4))) 651 (- (f2cl-lib:fref tmp (k) ((1 4))) 652 (* temp 653 (f2cl-lib:fref t16 (k j) ((1 4) (1 4))) 654 (f2cl-lib:fref tmp (j) ((1 4)))))) 655 label110)) 656 label120)) 657 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 658 ((> i 3) nil) 659 (tagbody 660 (cond 661 ((/= 662 (f2cl-lib:fref jpiv 663 ((f2cl-lib:int-add 4 (f2cl-lib:int-sub i))) 664 ((1 4))) 665 (f2cl-lib:int-add 4 (f2cl-lib:int-sub i))) 666 (setf temp 667 (f2cl-lib:fref tmp ((f2cl-lib:int-sub 4 i)) ((1 4)))) 668 (setf (f2cl-lib:fref tmp ((f2cl-lib:int-sub 4 i)) ((1 4))) 669 (f2cl-lib:fref tmp 670 ((f2cl-lib:fref jpiv 671 ((f2cl-lib:int-sub 4 672 i)) 673 ((1 4)))) 674 ((1 4)))) 675 (setf (f2cl-lib:fref tmp 676 ((f2cl-lib:fref jpiv 677 ((f2cl-lib:int-sub 4 i)) 678 ((1 4)))) 679 ((1 4))) 680 temp))) 681 label130)) 682 (setf (f2cl-lib:fref x-%data% (1 1) ((1 ldx) (1 *)) x-%offset%) 683 (f2cl-lib:fref tmp (1) ((1 4)))) 684 (setf (f2cl-lib:fref x-%data% (2 1) ((1 ldx) (1 *)) x-%offset%) 685 (f2cl-lib:fref tmp (2) ((1 4)))) 686 (setf (f2cl-lib:fref x-%data% (1 2) ((1 ldx) (1 *)) x-%offset%) 687 (f2cl-lib:fref tmp (3) ((1 4)))) 688 (setf (f2cl-lib:fref x-%data% (2 2) ((1 ldx) (1 *)) x-%offset%) 689 (f2cl-lib:fref tmp (4) ((1 4)))) 690 (setf xnorm 691 (max 692 (+ (abs (f2cl-lib:fref tmp (1) ((1 4)))) 693 (abs (f2cl-lib:fref tmp (3) ((1 4))))) 694 (+ (abs (f2cl-lib:fref tmp (2) ((1 4)))) 695 (abs (f2cl-lib:fref tmp (4) ((1 4))))))) 696 (go end_label) 697 end_label 698 (return 699 (values nil 700 nil 701 nil 702 nil 703 nil 704 nil 705 nil 706 nil 707 nil 708 nil 709 nil 710 scale 711 nil 712 nil 713 xnorm 714 info))))))) 715 716(in-package #-gcl #:cl-user #+gcl "CL-USER") 717#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 718(eval-when (:load-toplevel :compile-toplevel :execute) 719 (setf (gethash 'fortran-to-lisp::dlasy2 720 fortran-to-lisp::*f2cl-function-info*) 721 (fortran-to-lisp::make-f2cl-finfo 722 :arg-types '(fortran-to-lisp::logical fortran-to-lisp::logical 723 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 724 (fortran-to-lisp::integer4) (array double-float (*)) 725 (fortran-to-lisp::integer4) (array double-float (*)) 726 (fortran-to-lisp::integer4) (array double-float (*)) 727 (fortran-to-lisp::integer4) (double-float) 728 (array double-float (*)) (fortran-to-lisp::integer4) 729 (double-float) (fortran-to-lisp::integer4)) 730 :return-values '(nil nil nil nil nil nil nil nil nil nil nil 731 fortran-to-lisp::scale nil nil 732 fortran-to-lisp::xnorm fortran-to-lisp::info) 733 :calls '(fortran-to-lisp::dswap fortran-to-lisp::dcopy 734 fortran-to-lisp::idamax fortran-to-lisp::dlamch)))) 735 736