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* ((cbias 1.5) 21 (zero 0.0) 22 (half 0.5) 23 (one 1.0) 24 (two 2.0) 25 (four 4.0) 26 (hundrd 100.0)) 27 (declare (type (double-float 1.5 1.5) cbias) 28 (type (double-float 0.0 0.0) zero) 29 (type (double-float 0.5 0.5) half) 30 (type (double-float 1.0 1.0) one) 31 (type (double-float 2.0 2.0) two) 32 (type (double-float 4.0 4.0) four) 33 (type (double-float 100.0 100.0) hundrd) 34 (ignorable cbias zero half one two four hundrd)) 35 (defun dlasq2 (n z info) 36 (declare (type (array double-float (*)) z) 37 (type (f2cl-lib:integer4) info n)) 38 (f2cl-lib:with-multi-array-data 39 ((z double-float z-%data% z-%offset%)) 40 (prog ((d 0.0) (desig 0.0) (dmin 0.0) (e 0.0) (emax 0.0) (emin 0.0) 41 (eps 0.0) (oldemn 0.0) (qmax 0.0) (qmin 0.0) (s 0.0) (safmin 0.0) 42 (sigma 0.0) (t$ 0.0) (temp 0.0) (tol 0.0) (tol2 0.0) (trace$ 0.0) 43 (zmax 0.0) (i0 0) (i4 0) (iinfo 0) (ipn4 0) (iter 0) (iwhila 0) 44 (iwhilb 0) (k 0) (n0 0) (nbig 0) (ndiv 0) (nfail 0) (pp 0) 45 (splt 0) (ieee nil)) 46 (declare (type (double-float) d desig dmin e emax emin eps oldemn qmax 47 qmin s safmin sigma t$ temp tol tol2 48 trace$ zmax) 49 (type (f2cl-lib:integer4) i0 i4 iinfo ipn4 iter iwhila iwhilb 50 k n0 nbig ndiv nfail pp splt) 51 (type f2cl-lib:logical ieee)) 52 (setf info 0) 53 (setf eps (dlamch "Precision")) 54 (setf safmin (dlamch "Safe minimum")) 55 (setf tol (* eps hundrd)) 56 (setf tol2 (expt tol 2)) 57 (cond 58 ((< n 0) 59 (setf info -1) 60 (xerbla "DLASQ2" 1) 61 (go end_label)) 62 ((= n 0) 63 (go end_label)) 64 ((= n 1) 65 (cond 66 ((< (f2cl-lib:fref z (1) ((1 *))) zero) 67 (setf info -201) 68 (xerbla "DLASQ2" 2))) 69 (go end_label)) 70 ((= n 2) 71 (cond 72 ((or (< (f2cl-lib:fref z (2) ((1 *))) zero) 73 (< (f2cl-lib:fref z (3) ((1 *))) zero)) 74 (setf info -2) 75 (xerbla "DLASQ2" 2) 76 (go end_label)) 77 ((> (f2cl-lib:fref z (3) ((1 *))) (f2cl-lib:fref z (1) ((1 *)))) 78 (setf d (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)) 79 (setf (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%) 80 (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%)) 81 (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) d))) 82 (setf (f2cl-lib:fref z-%data% (5) ((1 *)) z-%offset%) 83 (+ (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) 84 (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%) 85 (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%))) 86 (cond 87 ((> (f2cl-lib:fref z (2) ((1 *))) 88 (* (f2cl-lib:fref z (3) ((1 *))) tol2)) 89 (setf t$ 90 (* half 91 (+ 92 (- (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) 93 (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)) 94 (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%)))) 95 (setf s 96 (* (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%) 97 (/ (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%) 98 t$))) 99 (cond 100 ((<= s t$) 101 (setf s 102 (* (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%) 103 (/ (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%) 104 (* t$ 105 (+ one (f2cl-lib:fsqrt (+ one (/ s t$))))))))) 106 (t 107 (setf s 108 (* (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%) 109 (/ (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%) 110 (+ t$ 111 (* (f2cl-lib:fsqrt t$) 112 (f2cl-lib:fsqrt (+ t$ s))))))))) 113 (setf t$ 114 (+ (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) 115 (+ s (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%)))) 116 (setf (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%) 117 (* (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%) 118 (/ (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) 119 t$))) 120 (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) t$))) 121 (setf (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%) 122 (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)) 123 (setf (f2cl-lib:fref z-%data% (6) ((1 *)) z-%offset%) 124 (+ (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%) 125 (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%))) 126 (go end_label))) 127 (setf (f2cl-lib:fref z-%data% 128 ((f2cl-lib:int-mul 2 n)) 129 ((1 *)) 130 z-%offset%) 131 zero) 132 (setf emin (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%)) 133 (setf qmax zero) 134 (setf zmax zero) 135 (setf d zero) 136 (setf e zero) 137 (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 2)) 138 ((> k 139 (f2cl-lib:int-mul 2 140 (f2cl-lib:int-add n 141 (f2cl-lib:int-sub 142 1)))) 143 nil) 144 (tagbody 145 (cond 146 ((< (f2cl-lib:fref z (k) ((1 *))) zero) 147 (setf info (f2cl-lib:int-sub (f2cl-lib:int-add 200 k))) 148 (xerbla "DLASQ2" 2) 149 (go end_label)) 150 ((< (f2cl-lib:fref z ((f2cl-lib:int-add k 1)) ((1 *))) zero) 151 (setf info (f2cl-lib:int-sub (f2cl-lib:int-add 200 k 1))) 152 (xerbla "DLASQ2" 2) 153 (go end_label))) 154 (setf d (+ d (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%))) 155 (setf e 156 (+ e 157 (f2cl-lib:fref z-%data% 158 ((f2cl-lib:int-add k 1)) 159 ((1 *)) 160 z-%offset%))) 161 (setf qmax 162 (max qmax (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%))) 163 (setf emin 164 (min emin 165 (f2cl-lib:fref z-%data% 166 ((f2cl-lib:int-add k 1)) 167 ((1 *)) 168 z-%offset%))) 169 (setf zmax 170 (max qmax 171 zmax 172 (f2cl-lib:fref z-%data% 173 ((f2cl-lib:int-add k 1)) 174 ((1 *)) 175 z-%offset%))) 176 label10)) 177 (cond 178 ((< 179 (f2cl-lib:fref z 180 ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 181 (f2cl-lib:int-sub 1))) 182 ((1 *))) 183 zero) 184 (setf info 185 (f2cl-lib:int-sub 186 (f2cl-lib:int-sub 187 (f2cl-lib:int-add 200 (f2cl-lib:int-mul 2 n)) 188 1))) 189 (xerbla "DLASQ2" 2) 190 (go end_label))) 191 (setf d 192 (+ d 193 (f2cl-lib:fref z-%data% 194 ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1)) 195 ((1 *)) 196 z-%offset%))) 197 (setf qmax 198 (max qmax 199 (f2cl-lib:fref z-%data% 200 ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 201 1)) 202 ((1 *)) 203 z-%offset%))) 204 (setf zmax (max qmax zmax)) 205 (cond 206 ((= e zero) 207 (f2cl-lib:fdo (k 2 (f2cl-lib:int-add k 1)) 208 ((> k n) nil) 209 (tagbody 210 (setf (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%) 211 (f2cl-lib:fref z-%data% 212 ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 k) 213 1)) 214 ((1 *)) 215 z-%offset%)) 216 label20)) 217 (multiple-value-bind (var-0 var-1 var-2 var-3) 218 (dlasrt "D" n z iinfo) 219 (declare (ignore var-0 var-1 var-2)) 220 (setf iinfo var-3)) 221 (setf (f2cl-lib:fref z-%data% 222 ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1)) 223 ((1 *)) 224 z-%offset%) 225 d) 226 (go end_label))) 227 (setf trace$ (+ d e)) 228 (cond 229 ((= trace$ zero) 230 (setf (f2cl-lib:fref z-%data% 231 ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1)) 232 ((1 *)) 233 z-%offset%) 234 zero) 235 (go end_label))) 236 (setf ieee 237 (and (= (ilaenv 10 "DLASQ2" "N" 1 2 3 4) 1) 238 (= (ilaenv 11 "DLASQ2" "N" 1 2 3 4) 1))) 239 (f2cl-lib:fdo (k (f2cl-lib:int-mul 2 n) 240 (f2cl-lib:int-add k (f2cl-lib:int-sub 2))) 241 ((> k 2) nil) 242 (tagbody 243 (setf (f2cl-lib:fref z-%data% 244 ((f2cl-lib:int-mul 2 k)) 245 ((1 *)) 246 z-%offset%) 247 zero) 248 (setf (f2cl-lib:fref z-%data% 249 ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 k) 1)) 250 ((1 *)) 251 z-%offset%) 252 (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%)) 253 (setf (f2cl-lib:fref z-%data% 254 ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 k) 2)) 255 ((1 *)) 256 z-%offset%) 257 zero) 258 (setf (f2cl-lib:fref z-%data% 259 ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 k) 3)) 260 ((1 *)) 261 z-%offset%) 262 (f2cl-lib:fref z-%data% 263 ((f2cl-lib:int-sub k 1)) 264 ((1 *)) 265 z-%offset%)) 266 label30)) 267 (setf i0 1) 268 (setf n0 n) 269 (cond 270 ((< 271 (* cbias 272 (f2cl-lib:fref z 273 ((f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) 274 (f2cl-lib:int-sub 3))) 275 ((1 *)))) 276 (f2cl-lib:fref z 277 ((f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) 278 (f2cl-lib:int-sub 3))) 279 ((1 *)))) 280 (setf ipn4 (f2cl-lib:int-mul 4 (f2cl-lib:int-add i0 n0))) 281 (f2cl-lib:fdo (i4 (f2cl-lib:int-mul 4 i0) (f2cl-lib:int-add i4 4)) 282 ((> i4 283 (f2cl-lib:int-mul 2 284 (f2cl-lib:int-add i0 285 n0 286 (f2cl-lib:int-sub 287 1)))) 288 nil) 289 (tagbody 290 (setf temp 291 (f2cl-lib:fref z-%data% 292 ((f2cl-lib:int-sub i4 3)) 293 ((1 *)) 294 z-%offset%)) 295 (setf (f2cl-lib:fref z-%data% 296 ((f2cl-lib:int-sub i4 3)) 297 ((1 *)) 298 z-%offset%) 299 (f2cl-lib:fref z-%data% 300 ((f2cl-lib:int-sub ipn4 i4 3)) 301 ((1 *)) 302 z-%offset%)) 303 (setf (f2cl-lib:fref z-%data% 304 ((f2cl-lib:int-sub ipn4 i4 3)) 305 ((1 *)) 306 z-%offset%) 307 temp) 308 (setf temp 309 (f2cl-lib:fref z-%data% 310 ((f2cl-lib:int-sub i4 1)) 311 ((1 *)) 312 z-%offset%)) 313 (setf (f2cl-lib:fref z-%data% 314 ((f2cl-lib:int-sub i4 1)) 315 ((1 *)) 316 z-%offset%) 317 (f2cl-lib:fref z-%data% 318 ((f2cl-lib:int-sub ipn4 i4 5)) 319 ((1 *)) 320 z-%offset%)) 321 (setf (f2cl-lib:fref z-%data% 322 ((f2cl-lib:int-sub ipn4 i4 5)) 323 ((1 *)) 324 z-%offset%) 325 temp) 326 label40)))) 327 (setf pp 0) 328 (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) 329 ((> k 2) nil) 330 (tagbody 331 (setf d 332 (f2cl-lib:fref z-%data% 333 ((f2cl-lib:int-sub 334 (f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) 335 pp) 336 3)) 337 ((1 *)) 338 z-%offset%)) 339 (f2cl-lib:fdo (i4 340 (f2cl-lib:int-add 341 (f2cl-lib:int-mul 4 342 (f2cl-lib:int-add n0 343 (f2cl-lib:int-sub 344 1))) 345 pp) 346 (f2cl-lib:int-add i4 (f2cl-lib:int-sub 4))) 347 ((> i4 (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) pp)) 348 nil) 349 (tagbody 350 (cond 351 ((<= 352 (f2cl-lib:fref z 353 ((f2cl-lib:int-add i4 (f2cl-lib:int-sub 1))) 354 ((1 *))) 355 (* tol2 d)) 356 (setf (f2cl-lib:fref z-%data% 357 ((f2cl-lib:int-sub i4 1)) 358 ((1 *)) 359 z-%offset%) 360 (- zero)) 361 (setf d 362 (f2cl-lib:fref z-%data% 363 ((f2cl-lib:int-sub i4 3)) 364 ((1 *)) 365 z-%offset%))) 366 (t 367 (setf d 368 (* 369 (f2cl-lib:fref z-%data% 370 ((f2cl-lib:int-sub i4 3)) 371 ((1 *)) 372 z-%offset%) 373 (/ d 374 (+ d 375 (f2cl-lib:fref z-%data% 376 ((f2cl-lib:int-sub i4 1)) 377 ((1 *)) 378 z-%offset%))))))) 379 label50)) 380 (setf emin 381 (f2cl-lib:fref z-%data% 382 ((f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) 383 pp 384 1)) 385 ((1 *)) 386 z-%offset%)) 387 (setf d 388 (f2cl-lib:fref z-%data% 389 ((f2cl-lib:int-sub 390 (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) 391 pp) 392 3)) 393 ((1 *)) 394 z-%offset%)) 395 (f2cl-lib:fdo (i4 (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) pp) 396 (f2cl-lib:int-add i4 4)) 397 ((> i4 398 (f2cl-lib:int-add 399 (f2cl-lib:int-mul 4 400 (f2cl-lib:int-add n0 401 (f2cl-lib:int-sub 402 1))) 403 pp)) 404 nil) 405 (tagbody 406 (setf (f2cl-lib:fref z-%data% 407 ((f2cl-lib:int-sub 408 (f2cl-lib:int-add i4 409 (f2cl-lib:int-mul -1 410 2 411 pp)) 412 2)) 413 ((1 *)) 414 z-%offset%) 415 (+ d 416 (f2cl-lib:fref z-%data% 417 ((f2cl-lib:int-sub i4 1)) 418 ((1 *)) 419 z-%offset%))) 420 (cond 421 ((<= 422 (f2cl-lib:fref z 423 ((f2cl-lib:int-add i4 (f2cl-lib:int-sub 1))) 424 ((1 *))) 425 (* tol2 d)) 426 (setf (f2cl-lib:fref z-%data% 427 ((f2cl-lib:int-sub i4 1)) 428 ((1 *)) 429 z-%offset%) 430 (- zero)) 431 (setf (f2cl-lib:fref z-%data% 432 ((f2cl-lib:int-sub 433 (f2cl-lib:int-add i4 434 (f2cl-lib:int-mul 435 -1 436 2 437 pp)) 438 2)) 439 ((1 *)) 440 z-%offset%) 441 d) 442 (setf (f2cl-lib:fref z-%data% 443 ((f2cl-lib:int-add i4 444 (f2cl-lib:int-mul -1 445 2 446 pp))) 447 ((1 *)) 448 z-%offset%) 449 zero) 450 (setf d 451 (f2cl-lib:fref z-%data% 452 ((f2cl-lib:int-add i4 1)) 453 ((1 *)) 454 z-%offset%))) 455 ((and 456 (< 457 (* safmin 458 (f2cl-lib:fref z ((f2cl-lib:int-add i4 1)) ((1 *)))) 459 (f2cl-lib:fref z 460 ((f2cl-lib:int-add i4 461 (f2cl-lib:int-mul -1 462 2 463 pp) 464 (f2cl-lib:int-sub 2))) 465 ((1 *)))) 466 (< 467 (* safmin 468 (f2cl-lib:fref z 469 ((f2cl-lib:int-add i4 470 (f2cl-lib:int-mul -1 471 2 472 pp) 473 (f2cl-lib:int-sub 474 2))) 475 ((1 *)))) 476 (f2cl-lib:fref z ((f2cl-lib:int-add i4 1)) ((1 *))))) 477 (setf temp 478 (/ 479 (f2cl-lib:fref z-%data% 480 ((f2cl-lib:int-add i4 1)) 481 ((1 *)) 482 z-%offset%) 483 (f2cl-lib:fref z-%data% 484 ((f2cl-lib:int-sub 485 (f2cl-lib:int-add i4 486 (f2cl-lib:int-mul 487 -1 488 2 489 pp)) 490 2)) 491 ((1 *)) 492 z-%offset%))) 493 (setf (f2cl-lib:fref z-%data% 494 ((f2cl-lib:int-add i4 495 (f2cl-lib:int-mul -1 496 2 497 pp))) 498 ((1 *)) 499 z-%offset%) 500 (* 501 (f2cl-lib:fref z-%data% 502 ((f2cl-lib:int-sub i4 1)) 503 ((1 *)) 504 z-%offset%) 505 temp)) 506 (setf d (* d temp))) 507 (t 508 (setf (f2cl-lib:fref z-%data% 509 ((f2cl-lib:int-add i4 510 (f2cl-lib:int-mul -1 511 2 512 pp))) 513 ((1 *)) 514 z-%offset%) 515 (* 516 (f2cl-lib:fref z-%data% 517 ((f2cl-lib:int-add i4 1)) 518 ((1 *)) 519 z-%offset%) 520 (/ 521 (f2cl-lib:fref z-%data% 522 ((f2cl-lib:int-sub i4 1)) 523 ((1 *)) 524 z-%offset%) 525 (f2cl-lib:fref z-%data% 526 ((f2cl-lib:int-sub 527 (f2cl-lib:int-add i4 528 (f2cl-lib:int-mul 529 -1 530 2 531 pp)) 532 2)) 533 ((1 *)) 534 z-%offset%)))) 535 (setf d 536 (* 537 (f2cl-lib:fref z-%data% 538 ((f2cl-lib:int-add i4 1)) 539 ((1 *)) 540 z-%offset%) 541 (/ d 542 (f2cl-lib:fref z-%data% 543 ((f2cl-lib:int-sub 544 (f2cl-lib:int-add i4 545 (f2cl-lib:int-mul 546 -1 547 2 548 pp)) 549 2)) 550 ((1 *)) 551 z-%offset%)))))) 552 (setf emin 553 (min emin 554 (f2cl-lib:fref z-%data% 555 ((f2cl-lib:int-add i4 556 (f2cl-lib:int-mul 557 -1 558 2 559 pp))) 560 ((1 *)) 561 z-%offset%))) 562 label60)) 563 (setf (f2cl-lib:fref z-%data% 564 ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) 565 pp 566 2)) 567 ((1 *)) 568 z-%offset%) 569 d) 570 (setf qmax 571 (f2cl-lib:fref z-%data% 572 ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 i0) 573 pp 574 2)) 575 ((1 *)) 576 z-%offset%)) 577 (f2cl-lib:fdo (i4 578 (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) 579 (f2cl-lib:int-sub pp) 580 2) 581 (f2cl-lib:int-add i4 4)) 582 ((> i4 583 (f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) 584 (f2cl-lib:int-sub pp) 585 (f2cl-lib:int-sub 2))) 586 nil) 587 (tagbody 588 (setf qmax 589 (max qmax 590 (f2cl-lib:fref z-%data% (i4) ((1 *)) z-%offset%))) 591 label70)) 592 (setf pp (f2cl-lib:int-sub 1 pp)) 593 label80)) 594 (setf iter 2) 595 (setf nfail 0) 596 (setf ndiv (f2cl-lib:int-mul 2 (f2cl-lib:int-sub n0 i0))) 597 (f2cl-lib:fdo (iwhila 1 (f2cl-lib:int-add iwhila 1)) 598 ((> iwhila (f2cl-lib:int-add n 1)) nil) 599 (tagbody 600 (if (< n0 1) (go label150)) 601 (setf desig zero) 602 (cond 603 ((= n0 n) 604 (setf sigma zero)) 605 (t 606 (setf sigma 607 (- 608 (f2cl-lib:fref z-%data% 609 ((f2cl-lib:int-sub 610 (f2cl-lib:int-mul 4 n0) 611 1)) 612 ((1 *)) 613 z-%offset%))))) 614 (cond 615 ((< sigma zero) 616 (setf info 1) 617 (go end_label))) 618 (setf emax zero) 619 (cond 620 ((> n0 i0) 621 (setf emin 622 (abs 623 (f2cl-lib:fref z-%data% 624 ((f2cl-lib:int-sub 625 (f2cl-lib:int-mul 4 n0) 626 5)) 627 ((1 *)) 628 z-%offset%)))) 629 (t 630 (setf emin zero))) 631 (setf qmin 632 (f2cl-lib:fref z-%data% 633 ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) 634 3)) 635 ((1 *)) 636 z-%offset%)) 637 (setf qmax qmin) 638 (f2cl-lib:fdo (i4 (f2cl-lib:int-mul 4 n0) 639 (f2cl-lib:int-add i4 (f2cl-lib:int-sub 4))) 640 ((> i4 8) nil) 641 (tagbody 642 (if 643 (<= 644 (f2cl-lib:fref z-%data% 645 ((f2cl-lib:int-sub i4 5)) 646 ((1 *)) 647 z-%offset%) 648 zero) 649 (go label100)) 650 (cond 651 ((>= qmin (* four emax)) 652 (setf qmin 653 (min qmin 654 (f2cl-lib:fref z-%data% 655 ((f2cl-lib:int-sub i4 3)) 656 ((1 *)) 657 z-%offset%))) 658 (setf emax 659 (max emax 660 (f2cl-lib:fref z-%data% 661 ((f2cl-lib:int-sub i4 5)) 662 ((1 *)) 663 z-%offset%))))) 664 (setf qmax 665 (max qmax 666 (+ 667 (f2cl-lib:fref z-%data% 668 ((f2cl-lib:int-sub i4 7)) 669 ((1 *)) 670 z-%offset%) 671 (f2cl-lib:fref z-%data% 672 ((f2cl-lib:int-sub i4 5)) 673 ((1 *)) 674 z-%offset%)))) 675 (setf emin 676 (min emin 677 (f2cl-lib:fref z-%data% 678 ((f2cl-lib:int-sub i4 5)) 679 ((1 *)) 680 z-%offset%))) 681 label90)) 682 (setf i4 4) 683 label100 684 (setf i0 (the f2cl-lib:integer4 (truncate i4 4))) 685 (setf (f2cl-lib:fref z-%data% 686 ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) 1)) 687 ((1 *)) 688 z-%offset%) 689 emin) 690 (setf dmin 691 (- 692 (max zero 693 (+ qmin 694 (* (- two) 695 (f2cl-lib:fsqrt qmin) 696 (f2cl-lib:fsqrt emax)))))) 697 (setf pp 0) 698 (setf nbig 699 (f2cl-lib:int-mul 30 700 (f2cl-lib:int-add 701 (f2cl-lib:int-sub n0 i0) 702 1))) 703 (f2cl-lib:fdo (iwhilb 1 (f2cl-lib:int-add iwhilb 1)) 704 ((> iwhilb nbig) nil) 705 (tagbody 706 (if (> i0 n0) (go label130)) 707 (multiple-value-bind 708 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 709 var-9 var-10 var-11) 710 (dlasq3 i0 n0 z pp dmin sigma desig qmax nfail iter ndiv 711 ieee) 712 (declare (ignore var-0 var-2 var-3 var-11)) 713 (setf n0 var-1) 714 (setf dmin var-4) 715 (setf sigma var-5) 716 (setf desig var-6) 717 (setf qmax var-7) 718 (setf nfail var-8) 719 (setf iter var-9) 720 (setf ndiv var-10)) 721 (setf pp (f2cl-lib:int-sub 1 pp)) 722 (cond 723 ((and (= pp 0) 724 (>= (f2cl-lib:int-add n0 (f2cl-lib:int-sub i0)) 3)) 725 (cond 726 ((or 727 (<= (f2cl-lib:fref z ((f2cl-lib:int-mul 4 n0)) ((1 *))) 728 (* tol2 qmax)) 729 (<= 730 (f2cl-lib:fref z 731 ((f2cl-lib:int-add 732 (f2cl-lib:int-mul 4 n0) 733 (f2cl-lib:int-sub 1))) 734 ((1 *))) 735 (* tol2 sigma))) 736 (setf splt (f2cl-lib:int-sub i0 1)) 737 (setf qmax 738 (f2cl-lib:fref z-%data% 739 ((f2cl-lib:int-sub 740 (f2cl-lib:int-mul 4 i0) 741 3)) 742 ((1 *)) 743 z-%offset%)) 744 (setf emin 745 (f2cl-lib:fref z-%data% 746 ((f2cl-lib:int-sub 747 (f2cl-lib:int-mul 4 i0) 748 1)) 749 ((1 *)) 750 z-%offset%)) 751 (setf oldemn 752 (f2cl-lib:fref z-%data% 753 ((f2cl-lib:int-mul 4 i0)) 754 ((1 *)) 755 z-%offset%)) 756 (f2cl-lib:fdo (i4 (f2cl-lib:int-mul 4 i0) 757 (f2cl-lib:int-add i4 4)) 758 ((> i4 759 (f2cl-lib:int-mul 4 760 (f2cl-lib:int-add n0 761 (f2cl-lib:int-sub 762 3)))) 763 nil) 764 (tagbody 765 (cond 766 ((or 767 (<= (f2cl-lib:fref z (i4) ((1 *))) 768 (* tol2 769 (f2cl-lib:fref z 770 ((f2cl-lib:int-add i4 771 (f2cl-lib:int-sub 772 3))) 773 ((1 *))))) 774 (<= 775 (f2cl-lib:fref z 776 ((f2cl-lib:int-add i4 777 (f2cl-lib:int-sub 778 1))) 779 ((1 *))) 780 (* tol2 sigma))) 781 (setf (f2cl-lib:fref z-%data% 782 ((f2cl-lib:int-sub i4 1)) 783 ((1 *)) 784 z-%offset%) 785 (- sigma)) 786 (setf splt (the f2cl-lib:integer4 (truncate i4 4))) 787 (setf qmax zero) 788 (setf emin 789 (f2cl-lib:fref z-%data% 790 ((f2cl-lib:int-add i4 3)) 791 ((1 *)) 792 z-%offset%)) 793 (setf oldemn 794 (f2cl-lib:fref z-%data% 795 ((f2cl-lib:int-add i4 4)) 796 ((1 *)) 797 z-%offset%))) 798 (t 799 (setf qmax 800 (max qmax 801 (f2cl-lib:fref z-%data% 802 ((f2cl-lib:int-add i4 803 1)) 804 ((1 *)) 805 z-%offset%))) 806 (setf emin 807 (min emin 808 (f2cl-lib:fref z-%data% 809 ((f2cl-lib:int-sub i4 810 1)) 811 ((1 *)) 812 z-%offset%))) 813 (setf oldemn 814 (min oldemn 815 (f2cl-lib:fref z-%data% 816 (i4) 817 ((1 *)) 818 z-%offset%))))) 819 label110)) 820 (setf (f2cl-lib:fref z-%data% 821 ((f2cl-lib:int-sub 822 (f2cl-lib:int-mul 4 n0) 823 1)) 824 ((1 *)) 825 z-%offset%) 826 emin) 827 (setf (f2cl-lib:fref z-%data% 828 ((f2cl-lib:int-mul 4 n0)) 829 ((1 *)) 830 z-%offset%) 831 oldemn) 832 (setf i0 (f2cl-lib:int-add splt 1)))))) 833 label120)) 834 (setf info 2) 835 (go end_label) 836 label130 837 label140)) 838 (setf info 3) 839 (go end_label) 840 label150 841 (f2cl-lib:fdo (k 2 (f2cl-lib:int-add k 1)) 842 ((> k n) nil) 843 (tagbody 844 (setf (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%) 845 (f2cl-lib:fref z-%data% 846 ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 k) 847 3)) 848 ((1 *)) 849 z-%offset%)) 850 label160)) 851 (multiple-value-bind (var-0 var-1 var-2 var-3) 852 (dlasrt "D" n z iinfo) 853 (declare (ignore var-0 var-1 var-2)) 854 (setf iinfo var-3)) 855 (setf e zero) 856 (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) 857 ((> k 1) nil) 858 (tagbody 859 (setf e (+ e (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%))) 860 label170)) 861 (setf (f2cl-lib:fref z-%data% 862 ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 1)) 863 ((1 *)) 864 z-%offset%) 865 trace$) 866 (setf (f2cl-lib:fref z-%data% 867 ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 2)) 868 ((1 *)) 869 z-%offset%) 870 e) 871 (setf (f2cl-lib:fref z-%data% 872 ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 3)) 873 ((1 *)) 874 z-%offset%) 875 (f2cl-lib:dble iter)) 876 (setf (f2cl-lib:fref z-%data% 877 ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 4)) 878 ((1 *)) 879 z-%offset%) 880 (/ (f2cl-lib:dble ndiv) (f2cl-lib:dble (expt n 2)))) 881 (setf (f2cl-lib:fref z-%data% 882 ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 5)) 883 ((1 *)) 884 z-%offset%) 885 (/ (* hundrd nfail) (f2cl-lib:dble iter))) 886 (go end_label) 887 end_label 888 (return (values nil nil info)))))) 889 890(in-package #-gcl #:cl-user #+gcl "CL-USER") 891#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 892(eval-when (:load-toplevel :compile-toplevel :execute) 893 (setf (gethash 'fortran-to-lisp::dlasq2 894 fortran-to-lisp::*f2cl-function-info*) 895 (fortran-to-lisp::make-f2cl-finfo 896 :arg-types '((fortran-to-lisp::integer4) (array double-float (*)) 897 (fortran-to-lisp::integer4)) 898 :return-values '(nil nil fortran-to-lisp::info) 899 :calls '(fortran-to-lisp::dlasq3 fortran-to-lisp::ilaenv 900 fortran-to-lisp::dlasrt fortran-to-lisp::xerbla 901 fortran-to-lisp::dlamch)))) 902 903