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