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) 21 (one 1.0) 22 (negone (- 1.0)) 23 (hndrth 0.01) 24 (ten 10.0) 25 (hndrd 100.0) 26 (meigth (- 0.125)) 27 (maxitr 6)) 28 (declare (type (double-float 0.0 0.0) zero) 29 (type (double-float 1.0 1.0) one) 30 (type (double-float) negone) 31 (type (double-float 0.01 0.01) hndrth) 32 (type (double-float 10.0 10.0) ten) 33 (type (double-float 100.0 100.0) hndrd) 34 (type (double-float) meigth) 35 (type (f2cl-lib:integer4 6 6) maxitr) 36 (ignorable zero one negone hndrth ten hndrd meigth maxitr)) 37 (defun dbdsqr (uplo n ncvt nru ncc d e vt ldvt u ldu c ldc work info) 38 (declare (type (array double-float (*)) work c u vt e d) 39 (type (f2cl-lib:integer4) info ldc ldu ldvt ncc nru ncvt n) 40 (type (simple-string *) uplo)) 41 (f2cl-lib:with-multi-array-data 42 ((uplo character uplo-%data% uplo-%offset%) 43 (d double-float d-%data% d-%offset%) 44 (e double-float e-%data% e-%offset%) 45 (vt double-float vt-%data% vt-%offset%) 46 (u double-float u-%data% u-%offset%) 47 (c double-float c-%data% c-%offset%) 48 (work double-float work-%data% work-%offset%)) 49 (prog ((abse 0.0) (abss 0.0) (cosl 0.0) (cosr 0.0) (cs 0.0) (eps 0.0) 50 (f 0.0) (g 0.0) (h 0.0) (mu 0.0) (oldcs 0.0) (oldsn 0.0) (r 0.0) 51 (shift 0.0) (sigmn 0.0) (sigmx 0.0) (sinl 0.0) (sinr 0.0) 52 (sll 0.0) (smax 0.0) (smin 0.0) (sminl 0.0) (sminlo 0.0) 53 (sminoa 0.0) (sn 0.0) (thresh 0.0) (tol 0.0) (tolmul 0.0) 54 (unfl 0.0) (i 0) (idir 0) (isub 0) (iter 0) (j 0) (ll 0) (lll 0) 55 (m 0) (maxit 0) (nm1 0) (nm12 0) (nm13 0) (oldll 0) (oldm 0) 56 (lower nil) (rotate nil)) 57 (declare (type (double-float) abse abss cosl cosr cs eps f g h mu oldcs 58 oldsn r shift sigmn sigmx sinl sinr sll 59 smax smin sminl sminlo sminoa sn thresh 60 tol tolmul unfl) 61 (type (f2cl-lib:integer4) i idir isub iter j ll lll m maxit 62 nm1 nm12 nm13 oldll oldm) 63 (type f2cl-lib:logical lower rotate)) 64 (setf info 0) 65 (setf lower (lsame uplo "L")) 66 (cond 67 ((and (not (lsame uplo "U")) (not lower)) 68 (setf info -1)) 69 ((< n 0) 70 (setf info -2)) 71 ((< ncvt 0) 72 (setf info -3)) 73 ((< nru 0) 74 (setf info -4)) 75 ((< ncc 0) 76 (setf info -5)) 77 ((or (and (= ncvt 0) (< ldvt 1)) 78 (and (> ncvt 0) 79 (< ldvt 80 (max (the f2cl-lib:integer4 1) 81 (the f2cl-lib:integer4 n))))) 82 (setf info -9)) 83 ((< ldu (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nru))) 84 (setf info -11)) 85 ((or (and (= ncc 0) (< ldc 1)) 86 (and (> ncc 0) 87 (< ldc 88 (max (the f2cl-lib:integer4 1) 89 (the f2cl-lib:integer4 n))))) 90 (setf info -13))) 91 (cond 92 ((/= info 0) 93 (xerbla "DBDSQR" (f2cl-lib:int-sub info)) 94 (go end_label))) 95 (if (= n 0) (go end_label)) 96 (if (= n 1) (go label160)) 97 (setf rotate (or (> ncvt 0) (> nru 0) (> ncc 0))) 98 (cond 99 ((not rotate) 100 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 101 (dlasq1 n d e work info) 102 (declare (ignore var-0 var-1 var-2 var-3)) 103 (setf info var-4)) 104 (go end_label))) 105 (setf nm1 (f2cl-lib:int-sub n 1)) 106 (setf nm12 (f2cl-lib:int-add nm1 nm1)) 107 (setf nm13 (f2cl-lib:int-add nm12 nm1)) 108 (setf idir 0) 109 (setf eps (dlamch "Epsilon")) 110 (setf unfl (dlamch "Safe minimum")) 111 (cond 112 (lower 113 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 114 ((> i (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) nil) 115 (tagbody 116 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 117 (dlartg (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) 118 (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) cs sn r) 119 (declare (ignore var-0 var-1)) 120 (setf cs var-2) 121 (setf sn var-3) 122 (setf r var-4)) 123 (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) r) 124 (setf (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) 125 (* sn 126 (f2cl-lib:fref d-%data% 127 ((f2cl-lib:int-add i 1)) 128 ((1 *)) 129 d-%offset%))) 130 (setf (f2cl-lib:fref d-%data% 131 ((f2cl-lib:int-add i 1)) 132 ((1 *)) 133 d-%offset%) 134 (* cs 135 (f2cl-lib:fref d-%data% 136 ((f2cl-lib:int-add i 1)) 137 ((1 *)) 138 d-%offset%))) 139 (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) cs) 140 (setf (f2cl-lib:fref work-%data% 141 ((f2cl-lib:int-add nm1 i)) 142 ((1 *)) 143 work-%offset%) 144 sn) 145 label10)) 146 (if (> nru 0) 147 (dlasr "R" "V" "F" nru n 148 (f2cl-lib:array-slice work-%data% 149 double-float 150 (1) 151 ((1 *)) 152 work-%offset%) 153 (f2cl-lib:array-slice work-%data% 154 double-float 155 (n) 156 ((1 *)) 157 work-%offset%) 158 u ldu)) 159 (if (> ncc 0) 160 (dlasr "L" "V" "F" n ncc 161 (f2cl-lib:array-slice work-%data% 162 double-float 163 (1) 164 ((1 *)) 165 work-%offset%) 166 (f2cl-lib:array-slice work-%data% 167 double-float 168 (n) 169 ((1 *)) 170 work-%offset%) 171 c ldc)))) 172 (setf tolmul (max ten (min hndrd (expt eps meigth)))) 173 (setf tol (* tolmul eps)) 174 (setf smax zero) 175 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 176 ((> i n) nil) 177 (tagbody 178 (setf smax 179 (max smax 180 (abs 181 (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)))) 182 label20)) 183 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 184 ((> i (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) nil) 185 (tagbody 186 (setf smax 187 (max smax 188 (abs 189 (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%)))) 190 label30)) 191 (setf sminl zero) 192 (cond 193 ((>= tol zero) 194 (tagbody 195 (setf sminoa 196 (abs (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%))) 197 (if (= sminoa zero) (go label50)) 198 (setf mu sminoa) 199 (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) 200 ((> i n) nil) 201 (tagbody 202 (setf mu 203 (* 204 (abs (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) 205 (/ mu 206 (+ mu 207 (abs 208 (f2cl-lib:fref e-%data% 209 ((f2cl-lib:int-sub i 1)) 210 ((1 *)) 211 e-%offset%)))))) 212 (setf sminoa (min sminoa mu)) 213 (if (= sminoa zero) (go label50)) 214 label40)) 215 label50 216 (setf sminoa (/ sminoa (f2cl-lib:fsqrt (f2cl-lib:dble n)))) 217 (setf thresh (max (* tol sminoa) (* maxitr n n unfl))))) 218 (t 219 (setf thresh (max (* (abs tol) smax) (* maxitr n n unfl))))) 220 (setf maxit (f2cl-lib:int-mul maxitr n n)) 221 (setf iter 0) 222 (setf oldll -1) 223 (setf oldm -1) 224 (setf m n) 225 label60 226 (if (<= m 1) (go label160)) 227 (if (> iter maxit) (go label200)) 228 (if 229 (and (< tol zero) 230 (<= (abs (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%)) 231 thresh)) 232 (setf (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%) zero)) 233 (setf smax (abs (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%))) 234 (setf smin smax) 235 (f2cl-lib:fdo (lll 1 (f2cl-lib:int-add lll 1)) 236 ((> lll (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) nil) 237 (tagbody 238 (setf ll (f2cl-lib:int-sub m lll)) 239 (setf abss (abs (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%))) 240 (setf abse (abs (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%))) 241 (if (and (< tol zero) (<= abss thresh)) 242 (setf (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%) zero)) 243 (if (<= abse thresh) (go label80)) 244 (setf smin (min smin abss)) 245 (setf smax (max smax abss abse)) 246 label70)) 247 (setf ll 0) 248 (go label90) 249 label80 250 (setf (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) zero) 251 (cond 252 ((= ll (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) 253 (setf m (f2cl-lib:int-sub m 1)) 254 (go label60))) 255 label90 256 (setf ll (f2cl-lib:int-add ll 1)) 257 (cond 258 ((= ll (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) 259 (multiple-value-bind 260 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) 261 (dlasv2 262 (f2cl-lib:fref d-%data% 263 ((f2cl-lib:int-sub m 1)) 264 ((1 *)) 265 d-%offset%) 266 (f2cl-lib:fref e-%data% 267 ((f2cl-lib:int-sub m 1)) 268 ((1 *)) 269 e-%offset%) 270 (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%) sigmn sigmx 271 sinr cosr sinl cosl) 272 (declare (ignore var-0 var-1 var-2)) 273 (setf sigmn var-3) 274 (setf sigmx var-4) 275 (setf sinr var-5) 276 (setf cosr var-6) 277 (setf sinl var-7) 278 (setf cosl var-8)) 279 (setf (f2cl-lib:fref d-%data% 280 ((f2cl-lib:int-sub m 1)) 281 ((1 *)) 282 d-%offset%) 283 sigmx) 284 (setf (f2cl-lib:fref e-%data% 285 ((f2cl-lib:int-sub m 1)) 286 ((1 *)) 287 e-%offset%) 288 zero) 289 (setf (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%) sigmn) 290 (if (> ncvt 0) 291 (drot ncvt 292 (f2cl-lib:array-slice vt-%data% 293 double-float 294 ((+ m (f2cl-lib:int-sub 1)) 1) 295 ((1 ldvt) (1 *)) 296 vt-%offset%) 297 ldvt 298 (f2cl-lib:array-slice vt-%data% 299 double-float 300 (m 1) 301 ((1 ldvt) (1 *)) 302 vt-%offset%) 303 ldvt cosr sinr)) 304 (if (> nru 0) 305 (drot nru 306 (f2cl-lib:array-slice u-%data% 307 double-float 308 (1 (f2cl-lib:int-sub m 1)) 309 ((1 ldu) (1 *)) 310 u-%offset%) 311 1 312 (f2cl-lib:array-slice u-%data% 313 double-float 314 (1 m) 315 ((1 ldu) (1 *)) 316 u-%offset%) 317 1 cosl sinl)) 318 (if (> ncc 0) 319 (drot ncc 320 (f2cl-lib:array-slice c-%data% 321 double-float 322 ((+ m (f2cl-lib:int-sub 1)) 1) 323 ((1 ldc) (1 *)) 324 c-%offset%) 325 ldc 326 (f2cl-lib:array-slice c-%data% 327 double-float 328 (m 1) 329 ((1 ldc) (1 *)) 330 c-%offset%) 331 ldc cosl sinl)) 332 (setf m (f2cl-lib:int-sub m 2)) 333 (go label60))) 334 (cond 335 ((or (> ll oldm) (< m oldll)) 336 (cond 337 ((>= (abs (f2cl-lib:fref d (ll) ((1 *)))) 338 (abs (f2cl-lib:fref d (m) ((1 *))))) 339 (setf idir 1)) 340 (t 341 (setf idir 2))))) 342 (cond 343 ((= idir 1) 344 (cond 345 ((or 346 (<= 347 (abs 348 (f2cl-lib:fref e 349 ((f2cl-lib:int-add m (f2cl-lib:int-sub 1))) 350 ((1 *)))) 351 (* (abs tol) (abs (f2cl-lib:fref d (m) ((1 *)))))) 352 (and (< tol zero) 353 (<= 354 (abs 355 (f2cl-lib:fref e 356 ((f2cl-lib:int-add m 357 (f2cl-lib:int-sub 1))) 358 ((1 *)))) 359 thresh))) 360 (setf (f2cl-lib:fref e-%data% 361 ((f2cl-lib:int-sub m 1)) 362 ((1 *)) 363 e-%offset%) 364 zero) 365 (go label60))) 366 (cond 367 ((>= tol zero) 368 (setf mu (abs (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%))) 369 (setf sminl mu) 370 (f2cl-lib:fdo (lll ll (f2cl-lib:int-add lll 1)) 371 ((> lll (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) 372 nil) 373 (tagbody 374 (cond 375 ((<= (abs (f2cl-lib:fref e (lll) ((1 *)))) (* tol mu)) 376 (setf (f2cl-lib:fref e-%data% (lll) ((1 *)) e-%offset%) 377 zero) 378 (go label60))) 379 (setf sminlo sminl) 380 (setf mu 381 (* 382 (abs 383 (f2cl-lib:fref d-%data% 384 ((f2cl-lib:int-add lll 1)) 385 ((1 *)) 386 d-%offset%)) 387 (/ mu 388 (+ mu 389 (abs 390 (f2cl-lib:fref e-%data% 391 (lll) 392 ((1 *)) 393 e-%offset%)))))) 394 (setf sminl (min sminl mu)) 395 label100))))) 396 (t 397 (cond 398 ((or 399 (<= (abs (f2cl-lib:fref e (ll) ((1 *)))) 400 (* (abs tol) (abs (f2cl-lib:fref d (ll) ((1 *)))))) 401 (and (< tol zero) 402 (<= (abs (f2cl-lib:fref e (ll) ((1 *)))) thresh))) 403 (setf (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) zero) 404 (go label60))) 405 (cond 406 ((>= tol zero) 407 (setf mu (abs (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%))) 408 (setf sminl mu) 409 (f2cl-lib:fdo (lll (f2cl-lib:int-add m (f2cl-lib:int-sub 1)) 410 (f2cl-lib:int-add lll (f2cl-lib:int-sub 1))) 411 ((> lll ll) nil) 412 (tagbody 413 (cond 414 ((<= (abs (f2cl-lib:fref e (lll) ((1 *)))) (* tol mu)) 415 (setf (f2cl-lib:fref e-%data% (lll) ((1 *)) e-%offset%) 416 zero) 417 (go label60))) 418 (setf sminlo sminl) 419 (setf mu 420 (* 421 (abs 422 (f2cl-lib:fref d-%data% (lll) ((1 *)) d-%offset%)) 423 (/ mu 424 (+ mu 425 (abs 426 (f2cl-lib:fref e-%data% 427 (lll) 428 ((1 *)) 429 e-%offset%)))))) 430 (setf sminl (min sminl mu)) 431 label110)))))) 432 (setf oldll ll) 433 (setf oldm m) 434 (cond 435 ((and (>= tol zero) 436 (<= (* n tol (f2cl-lib:f2cl/ sminl smax)) 437 (max eps (* hndrth tol)))) 438 (setf shift zero)) 439 (t 440 (cond 441 ((= idir 1) 442 (setf sll (abs (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%))) 443 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 444 (dlas2 445 (f2cl-lib:fref d-%data% 446 ((f2cl-lib:int-sub m 1)) 447 ((1 *)) 448 d-%offset%) 449 (f2cl-lib:fref e-%data% 450 ((f2cl-lib:int-sub m 1)) 451 ((1 *)) 452 e-%offset%) 453 (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%) shift r) 454 (declare (ignore var-0 var-1 var-2)) 455 (setf shift var-3) 456 (setf r var-4))) 457 (t 458 (setf sll (abs (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%))) 459 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 460 (dlas2 (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%) 461 (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) 462 (f2cl-lib:fref d-%data% 463 ((f2cl-lib:int-add ll 1)) 464 ((1 *)) 465 d-%offset%) 466 shift r) 467 (declare (ignore var-0 var-1 var-2)) 468 (setf shift var-3) 469 (setf r var-4)))) 470 (cond 471 ((> sll zero) 472 (if (< (expt (/ shift sll) 2) eps) (setf shift zero)))))) 473 (setf iter (f2cl-lib:int-sub (f2cl-lib:int-add iter m) ll)) 474 (cond 475 ((= shift zero) 476 (cond 477 ((= idir 1) 478 (setf cs one) 479 (setf oldcs one) 480 (f2cl-lib:fdo (i ll (f2cl-lib:int-add i 1)) 481 ((> i (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) 482 nil) 483 (tagbody 484 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 485 (dlartg 486 (* (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) cs) 487 (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) cs sn r) 488 (declare (ignore var-0 var-1)) 489 (setf cs var-2) 490 (setf sn var-3) 491 (setf r var-4)) 492 (if (> i ll) 493 (setf (f2cl-lib:fref e-%data% 494 ((f2cl-lib:int-sub i 1)) 495 ((1 *)) 496 e-%offset%) 497 (* oldsn r))) 498 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 499 (dlartg (* oldcs r) 500 (* 501 (f2cl-lib:fref d-%data% 502 ((f2cl-lib:int-add i 1)) 503 ((1 *)) 504 d-%offset%) 505 sn) 506 oldcs oldsn 507 (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) 508 (declare (ignore var-0 var-1)) 509 (setf oldcs var-2) 510 (setf oldsn var-3) 511 (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) 512 var-4)) 513 (setf (f2cl-lib:fref work-%data% 514 ((f2cl-lib:int-add 515 (f2cl-lib:int-sub i ll) 516 1)) 517 ((1 *)) 518 work-%offset%) 519 cs) 520 (setf (f2cl-lib:fref work-%data% 521 ((f2cl-lib:int-add 522 (f2cl-lib:int-sub i ll) 523 1 524 nm1)) 525 ((1 *)) 526 work-%offset%) 527 sn) 528 (setf (f2cl-lib:fref work-%data% 529 ((f2cl-lib:int-add 530 (f2cl-lib:int-sub i ll) 531 1 532 nm12)) 533 ((1 *)) 534 work-%offset%) 535 oldcs) 536 (setf (f2cl-lib:fref work-%data% 537 ((f2cl-lib:int-add 538 (f2cl-lib:int-sub i ll) 539 1 540 nm13)) 541 ((1 *)) 542 work-%offset%) 543 oldsn) 544 label120)) 545 (setf h (* (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%) cs)) 546 (setf (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%) (* h oldcs)) 547 (setf (f2cl-lib:fref e-%data% 548 ((f2cl-lib:int-sub m 1)) 549 ((1 *)) 550 e-%offset%) 551 (* h oldsn)) 552 (if (> ncvt 0) 553 (dlasr "L" "V" "F" 554 (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncvt 555 (f2cl-lib:array-slice work-%data% 556 double-float 557 (1) 558 ((1 *)) 559 work-%offset%) 560 (f2cl-lib:array-slice work-%data% 561 double-float 562 (n) 563 ((1 *)) 564 work-%offset%) 565 (f2cl-lib:array-slice vt-%data% 566 double-float 567 (ll 1) 568 ((1 ldvt) (1 *)) 569 vt-%offset%) 570 ldvt)) 571 (if (> nru 0) 572 (dlasr "R" "V" "F" nru 573 (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) 574 (f2cl-lib:array-slice work-%data% 575 double-float 576 ((+ nm12 1)) 577 ((1 *)) 578 work-%offset%) 579 (f2cl-lib:array-slice work-%data% 580 double-float 581 ((+ nm13 1)) 582 ((1 *)) 583 work-%offset%) 584 (f2cl-lib:array-slice u-%data% 585 double-float 586 (1 ll) 587 ((1 ldu) (1 *)) 588 u-%offset%) 589 ldu)) 590 (if (> ncc 0) 591 (dlasr "L" "V" "F" 592 (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncc 593 (f2cl-lib:array-slice work-%data% 594 double-float 595 ((+ nm12 1)) 596 ((1 *)) 597 work-%offset%) 598 (f2cl-lib:array-slice work-%data% 599 double-float 600 ((+ nm13 1)) 601 ((1 *)) 602 work-%offset%) 603 (f2cl-lib:array-slice c-%data% 604 double-float 605 (ll 1) 606 ((1 ldc) (1 *)) 607 c-%offset%) 608 ldc)) 609 (if 610 (<= 611 (abs 612 (f2cl-lib:fref e-%data% 613 ((f2cl-lib:int-sub m 1)) 614 ((1 *)) 615 e-%offset%)) 616 thresh) 617 (setf (f2cl-lib:fref e-%data% 618 ((f2cl-lib:int-sub m 1)) 619 ((1 *)) 620 e-%offset%) 621 zero))) 622 (t 623 (setf cs one) 624 (setf oldcs one) 625 (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) 626 ((> i (f2cl-lib:int-add ll 1)) nil) 627 (tagbody 628 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 629 (dlartg 630 (* (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) cs) 631 (f2cl-lib:fref e-%data% 632 ((f2cl-lib:int-sub i 1)) 633 ((1 *)) 634 e-%offset%) 635 cs sn r) 636 (declare (ignore var-0 var-1)) 637 (setf cs var-2) 638 (setf sn var-3) 639 (setf r var-4)) 640 (if (< i m) 641 (setf (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) 642 (* oldsn r))) 643 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 644 (dlartg (* oldcs r) 645 (* 646 (f2cl-lib:fref d-%data% 647 ((f2cl-lib:int-sub i 1)) 648 ((1 *)) 649 d-%offset%) 650 sn) 651 oldcs oldsn 652 (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) 653 (declare (ignore var-0 var-1)) 654 (setf oldcs var-2) 655 (setf oldsn var-3) 656 (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) 657 var-4)) 658 (setf (f2cl-lib:fref work-%data% 659 ((f2cl-lib:int-sub i ll)) 660 ((1 *)) 661 work-%offset%) 662 cs) 663 (setf (f2cl-lib:fref work-%data% 664 ((f2cl-lib:int-add 665 (f2cl-lib:int-sub i ll) 666 nm1)) 667 ((1 *)) 668 work-%offset%) 669 (- sn)) 670 (setf (f2cl-lib:fref work-%data% 671 ((f2cl-lib:int-add 672 (f2cl-lib:int-sub i ll) 673 nm12)) 674 ((1 *)) 675 work-%offset%) 676 oldcs) 677 (setf (f2cl-lib:fref work-%data% 678 ((f2cl-lib:int-add 679 (f2cl-lib:int-sub i ll) 680 nm13)) 681 ((1 *)) 682 work-%offset%) 683 (- oldsn)) 684 label130)) 685 (setf h (* (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%) cs)) 686 (setf (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%) 687 (* h oldcs)) 688 (setf (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) 689 (* h oldsn)) 690 (if (> ncvt 0) 691 (dlasr "L" "V" "B" 692 (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncvt 693 (f2cl-lib:array-slice work-%data% 694 double-float 695 ((+ nm12 1)) 696 ((1 *)) 697 work-%offset%) 698 (f2cl-lib:array-slice work-%data% 699 double-float 700 ((+ nm13 1)) 701 ((1 *)) 702 work-%offset%) 703 (f2cl-lib:array-slice vt-%data% 704 double-float 705 (ll 1) 706 ((1 ldvt) (1 *)) 707 vt-%offset%) 708 ldvt)) 709 (if (> nru 0) 710 (dlasr "R" "V" "B" nru 711 (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) 712 (f2cl-lib:array-slice work-%data% 713 double-float 714 (1) 715 ((1 *)) 716 work-%offset%) 717 (f2cl-lib:array-slice work-%data% 718 double-float 719 (n) 720 ((1 *)) 721 work-%offset%) 722 (f2cl-lib:array-slice u-%data% 723 double-float 724 (1 ll) 725 ((1 ldu) (1 *)) 726 u-%offset%) 727 ldu)) 728 (if (> ncc 0) 729 (dlasr "L" "V" "B" 730 (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncc 731 (f2cl-lib:array-slice work-%data% 732 double-float 733 (1) 734 ((1 *)) 735 work-%offset%) 736 (f2cl-lib:array-slice work-%data% 737 double-float 738 (n) 739 ((1 *)) 740 work-%offset%) 741 (f2cl-lib:array-slice c-%data% 742 double-float 743 (ll 1) 744 ((1 ldc) (1 *)) 745 c-%offset%) 746 ldc)) 747 (if 748 (<= (abs (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%)) 749 thresh) 750 (setf (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) zero))))) 751 (t 752 (cond 753 ((= idir 1) 754 (setf f 755 (* 756 (- 757 (abs (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%)) 758 shift) 759 (+ 760 (f2cl-lib:sign one 761 (f2cl-lib:fref d-%data% 762 (ll) 763 ((1 *)) 764 d-%offset%)) 765 (/ shift 766 (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%))))) 767 (setf g (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%)) 768 (f2cl-lib:fdo (i ll (f2cl-lib:int-add i 1)) 769 ((> i (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) 770 nil) 771 (tagbody 772 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 773 (dlartg f g cosr sinr r) 774 (declare (ignore var-0 var-1)) 775 (setf cosr var-2) 776 (setf sinr var-3) 777 (setf r var-4)) 778 (if (> i ll) 779 (setf (f2cl-lib:fref e-%data% 780 ((f2cl-lib:int-sub i 1)) 781 ((1 *)) 782 e-%offset%) 783 r)) 784 (setf f 785 (+ 786 (* cosr 787 (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) 788 (* sinr 789 (f2cl-lib:fref e-%data% 790 (i) 791 ((1 *)) 792 e-%offset%)))) 793 (setf (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) 794 (- 795 (* cosr 796 (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%)) 797 (* sinr 798 (f2cl-lib:fref d-%data% 799 (i) 800 ((1 *)) 801 d-%offset%)))) 802 (setf g 803 (* sinr 804 (f2cl-lib:fref d-%data% 805 ((f2cl-lib:int-add i 1)) 806 ((1 *)) 807 d-%offset%))) 808 (setf (f2cl-lib:fref d-%data% 809 ((f2cl-lib:int-add i 1)) 810 ((1 *)) 811 d-%offset%) 812 (* cosr 813 (f2cl-lib:fref d-%data% 814 ((f2cl-lib:int-add i 1)) 815 ((1 *)) 816 d-%offset%))) 817 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 818 (dlartg f g cosl sinl r) 819 (declare (ignore var-0 var-1)) 820 (setf cosl var-2) 821 (setf sinl var-3) 822 (setf r var-4)) 823 (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) r) 824 (setf f 825 (+ 826 (* cosl 827 (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%)) 828 (* sinl 829 (f2cl-lib:fref d-%data% 830 ((f2cl-lib:int-add i 1)) 831 ((1 *)) 832 d-%offset%)))) 833 (setf (f2cl-lib:fref d-%data% 834 ((f2cl-lib:int-add i 1)) 835 ((1 *)) 836 d-%offset%) 837 (- 838 (* cosl 839 (f2cl-lib:fref d-%data% 840 ((f2cl-lib:int-add i 1)) 841 ((1 *)) 842 d-%offset%)) 843 (* sinl 844 (f2cl-lib:fref e-%data% 845 (i) 846 ((1 *)) 847 e-%offset%)))) 848 (cond 849 ((< i (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) 850 (setf g 851 (* sinl 852 (f2cl-lib:fref e-%data% 853 ((f2cl-lib:int-add i 1)) 854 ((1 *)) 855 e-%offset%))) 856 (setf (f2cl-lib:fref e-%data% 857 ((f2cl-lib:int-add i 1)) 858 ((1 *)) 859 e-%offset%) 860 (* cosl 861 (f2cl-lib:fref e-%data% 862 ((f2cl-lib:int-add i 1)) 863 ((1 *)) 864 e-%offset%))))) 865 (setf (f2cl-lib:fref work-%data% 866 ((f2cl-lib:int-add 867 (f2cl-lib:int-sub i ll) 868 1)) 869 ((1 *)) 870 work-%offset%) 871 cosr) 872 (setf (f2cl-lib:fref work-%data% 873 ((f2cl-lib:int-add 874 (f2cl-lib:int-sub i ll) 875 1 876 nm1)) 877 ((1 *)) 878 work-%offset%) 879 sinr) 880 (setf (f2cl-lib:fref work-%data% 881 ((f2cl-lib:int-add 882 (f2cl-lib:int-sub i ll) 883 1 884 nm12)) 885 ((1 *)) 886 work-%offset%) 887 cosl) 888 (setf (f2cl-lib:fref work-%data% 889 ((f2cl-lib:int-add 890 (f2cl-lib:int-sub i ll) 891 1 892 nm13)) 893 ((1 *)) 894 work-%offset%) 895 sinl) 896 label140)) 897 (setf (f2cl-lib:fref e-%data% 898 ((f2cl-lib:int-sub m 1)) 899 ((1 *)) 900 e-%offset%) 901 f) 902 (if (> ncvt 0) 903 (dlasr "L" "V" "F" 904 (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncvt 905 (f2cl-lib:array-slice work-%data% 906 double-float 907 (1) 908 ((1 *)) 909 work-%offset%) 910 (f2cl-lib:array-slice work-%data% 911 double-float 912 (n) 913 ((1 *)) 914 work-%offset%) 915 (f2cl-lib:array-slice vt-%data% 916 double-float 917 (ll 1) 918 ((1 ldvt) (1 *)) 919 vt-%offset%) 920 ldvt)) 921 (if (> nru 0) 922 (dlasr "R" "V" "F" nru 923 (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) 924 (f2cl-lib:array-slice work-%data% 925 double-float 926 ((+ nm12 1)) 927 ((1 *)) 928 work-%offset%) 929 (f2cl-lib:array-slice work-%data% 930 double-float 931 ((+ nm13 1)) 932 ((1 *)) 933 work-%offset%) 934 (f2cl-lib:array-slice u-%data% 935 double-float 936 (1 ll) 937 ((1 ldu) (1 *)) 938 u-%offset%) 939 ldu)) 940 (if (> ncc 0) 941 (dlasr "L" "V" "F" 942 (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncc 943 (f2cl-lib:array-slice work-%data% 944 double-float 945 ((+ nm12 1)) 946 ((1 *)) 947 work-%offset%) 948 (f2cl-lib:array-slice work-%data% 949 double-float 950 ((+ nm13 1)) 951 ((1 *)) 952 work-%offset%) 953 (f2cl-lib:array-slice c-%data% 954 double-float 955 (ll 1) 956 ((1 ldc) (1 *)) 957 c-%offset%) 958 ldc)) 959 (if 960 (<= 961 (abs 962 (f2cl-lib:fref e-%data% 963 ((f2cl-lib:int-sub m 1)) 964 ((1 *)) 965 e-%offset%)) 966 thresh) 967 (setf (f2cl-lib:fref e-%data% 968 ((f2cl-lib:int-sub m 1)) 969 ((1 *)) 970 e-%offset%) 971 zero))) 972 (t 973 (setf f 974 (* 975 (- (abs (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%)) 976 shift) 977 (+ 978 (f2cl-lib:sign one 979 (f2cl-lib:fref d-%data% 980 (m) 981 ((1 *)) 982 d-%offset%)) 983 (/ shift 984 (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%))))) 985 (setf g 986 (f2cl-lib:fref e-%data% 987 ((f2cl-lib:int-sub m 1)) 988 ((1 *)) 989 e-%offset%)) 990 (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) 991 ((> i (f2cl-lib:int-add ll 1)) nil) 992 (tagbody 993 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 994 (dlartg f g cosr sinr r) 995 (declare (ignore var-0 var-1)) 996 (setf cosr var-2) 997 (setf sinr var-3) 998 (setf r var-4)) 999 (if (< i m) 1000 (setf (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) r)) 1001 (setf f 1002 (+ 1003 (* cosr 1004 (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) 1005 (* sinr 1006 (f2cl-lib:fref e-%data% 1007 ((f2cl-lib:int-sub i 1)) 1008 ((1 *)) 1009 e-%offset%)))) 1010 (setf (f2cl-lib:fref e-%data% 1011 ((f2cl-lib:int-sub i 1)) 1012 ((1 *)) 1013 e-%offset%) 1014 (- 1015 (* cosr 1016 (f2cl-lib:fref e-%data% 1017 ((f2cl-lib:int-sub i 1)) 1018 ((1 *)) 1019 e-%offset%)) 1020 (* sinr 1021 (f2cl-lib:fref d-%data% 1022 (i) 1023 ((1 *)) 1024 d-%offset%)))) 1025 (setf g 1026 (* sinr 1027 (f2cl-lib:fref d-%data% 1028 ((f2cl-lib:int-sub i 1)) 1029 ((1 *)) 1030 d-%offset%))) 1031 (setf (f2cl-lib:fref d-%data% 1032 ((f2cl-lib:int-sub i 1)) 1033 ((1 *)) 1034 d-%offset%) 1035 (* cosr 1036 (f2cl-lib:fref d-%data% 1037 ((f2cl-lib:int-sub i 1)) 1038 ((1 *)) 1039 d-%offset%))) 1040 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 1041 (dlartg f g cosl sinl r) 1042 (declare (ignore var-0 var-1)) 1043 (setf cosl var-2) 1044 (setf sinl var-3) 1045 (setf r var-4)) 1046 (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) r) 1047 (setf f 1048 (+ 1049 (* cosl 1050 (f2cl-lib:fref e-%data% 1051 ((f2cl-lib:int-sub i 1)) 1052 ((1 *)) 1053 e-%offset%)) 1054 (* sinl 1055 (f2cl-lib:fref d-%data% 1056 ((f2cl-lib:int-sub i 1)) 1057 ((1 *)) 1058 d-%offset%)))) 1059 (setf (f2cl-lib:fref d-%data% 1060 ((f2cl-lib:int-sub i 1)) 1061 ((1 *)) 1062 d-%offset%) 1063 (- 1064 (* cosl 1065 (f2cl-lib:fref d-%data% 1066 ((f2cl-lib:int-sub i 1)) 1067 ((1 *)) 1068 d-%offset%)) 1069 (* sinl 1070 (f2cl-lib:fref e-%data% 1071 ((f2cl-lib:int-sub i 1)) 1072 ((1 *)) 1073 e-%offset%)))) 1074 (cond 1075 ((> i (f2cl-lib:int-add ll 1)) 1076 (setf g 1077 (* sinl 1078 (f2cl-lib:fref e-%data% 1079 ((f2cl-lib:int-sub i 2)) 1080 ((1 *)) 1081 e-%offset%))) 1082 (setf (f2cl-lib:fref e-%data% 1083 ((f2cl-lib:int-sub i 2)) 1084 ((1 *)) 1085 e-%offset%) 1086 (* cosl 1087 (f2cl-lib:fref e-%data% 1088 ((f2cl-lib:int-sub i 2)) 1089 ((1 *)) 1090 e-%offset%))))) 1091 (setf (f2cl-lib:fref work-%data% 1092 ((f2cl-lib:int-sub i ll)) 1093 ((1 *)) 1094 work-%offset%) 1095 cosr) 1096 (setf (f2cl-lib:fref work-%data% 1097 ((f2cl-lib:int-add 1098 (f2cl-lib:int-sub i ll) 1099 nm1)) 1100 ((1 *)) 1101 work-%offset%) 1102 (- sinr)) 1103 (setf (f2cl-lib:fref work-%data% 1104 ((f2cl-lib:int-add 1105 (f2cl-lib:int-sub i ll) 1106 nm12)) 1107 ((1 *)) 1108 work-%offset%) 1109 cosl) 1110 (setf (f2cl-lib:fref work-%data% 1111 ((f2cl-lib:int-add 1112 (f2cl-lib:int-sub i ll) 1113 nm13)) 1114 ((1 *)) 1115 work-%offset%) 1116 (- sinl)) 1117 label150)) 1118 (setf (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) f) 1119 (if 1120 (<= (abs (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%)) 1121 thresh) 1122 (setf (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) zero)) 1123 (if (> ncvt 0) 1124 (dlasr "L" "V" "B" 1125 (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncvt 1126 (f2cl-lib:array-slice work-%data% 1127 double-float 1128 ((+ nm12 1)) 1129 ((1 *)) 1130 work-%offset%) 1131 (f2cl-lib:array-slice work-%data% 1132 double-float 1133 ((+ nm13 1)) 1134 ((1 *)) 1135 work-%offset%) 1136 (f2cl-lib:array-slice vt-%data% 1137 double-float 1138 (ll 1) 1139 ((1 ldvt) (1 *)) 1140 vt-%offset%) 1141 ldvt)) 1142 (if (> nru 0) 1143 (dlasr "R" "V" "B" nru 1144 (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) 1145 (f2cl-lib:array-slice work-%data% 1146 double-float 1147 (1) 1148 ((1 *)) 1149 work-%offset%) 1150 (f2cl-lib:array-slice work-%data% 1151 double-float 1152 (n) 1153 ((1 *)) 1154 work-%offset%) 1155 (f2cl-lib:array-slice u-%data% 1156 double-float 1157 (1 ll) 1158 ((1 ldu) (1 *)) 1159 u-%offset%) 1160 ldu)) 1161 (if (> ncc 0) 1162 (dlasr "L" "V" "B" 1163 (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncc 1164 (f2cl-lib:array-slice work-%data% 1165 double-float 1166 (1) 1167 ((1 *)) 1168 work-%offset%) 1169 (f2cl-lib:array-slice work-%data% 1170 double-float 1171 (n) 1172 ((1 *)) 1173 work-%offset%) 1174 (f2cl-lib:array-slice c-%data% 1175 double-float 1176 (ll 1) 1177 ((1 ldc) (1 *)) 1178 c-%offset%) 1179 ldc)))))) 1180 (go label60) 1181 label160 1182 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 1183 ((> i n) nil) 1184 (tagbody 1185 (cond 1186 ((< (f2cl-lib:fref d (i) ((1 *))) zero) 1187 (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) 1188 (- (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%))) 1189 (if (> ncvt 0) 1190 (dscal ncvt negone 1191 (f2cl-lib:array-slice vt-%data% 1192 double-float 1193 (i 1) 1194 ((1 ldvt) (1 *)) 1195 vt-%offset%) 1196 ldvt)))) 1197 label170)) 1198 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 1199 ((> i (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) nil) 1200 (tagbody 1201 (setf isub 1) 1202 (setf smin (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%)) 1203 (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) 1204 ((> j (f2cl-lib:int-add n 1 (f2cl-lib:int-sub i))) 1205 nil) 1206 (tagbody 1207 (cond 1208 ((<= (f2cl-lib:fref d (j) ((1 *))) smin) 1209 (setf isub j) 1210 (setf smin 1211 (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%)))) 1212 label180)) 1213 (cond 1214 ((/= isub (f2cl-lib:int-add n 1 (f2cl-lib:int-sub i))) 1215 (setf (f2cl-lib:fref d-%data% (isub) ((1 *)) d-%offset%) 1216 (f2cl-lib:fref d-%data% 1217 ((f2cl-lib:int-sub (f2cl-lib:int-add n 1) 1218 i)) 1219 ((1 *)) 1220 d-%offset%)) 1221 (setf (f2cl-lib:fref d-%data% 1222 ((f2cl-lib:int-sub (f2cl-lib:int-add n 1) 1223 i)) 1224 ((1 *)) 1225 d-%offset%) 1226 smin) 1227 (if (> ncvt 0) 1228 (dswap ncvt 1229 (f2cl-lib:array-slice vt-%data% 1230 double-float 1231 (isub 1) 1232 ((1 ldvt) (1 *)) 1233 vt-%offset%) 1234 ldvt 1235 (f2cl-lib:array-slice vt-%data% 1236 double-float 1237 ((+ n 1 (f2cl-lib:int-sub i)) 1) 1238 ((1 ldvt) (1 *)) 1239 vt-%offset%) 1240 ldvt)) 1241 (if (> nru 0) 1242 (dswap nru 1243 (f2cl-lib:array-slice u-%data% 1244 double-float 1245 (1 isub) 1246 ((1 ldu) (1 *)) 1247 u-%offset%) 1248 1 1249 (f2cl-lib:array-slice u-%data% 1250 double-float 1251 (1 1252 (f2cl-lib:int-sub 1253 (f2cl-lib:int-add n 1) 1254 i)) 1255 ((1 ldu) (1 *)) 1256 u-%offset%) 1257 1)) 1258 (if (> ncc 0) 1259 (dswap ncc 1260 (f2cl-lib:array-slice c-%data% 1261 double-float 1262 (isub 1) 1263 ((1 ldc) (1 *)) 1264 c-%offset%) 1265 ldc 1266 (f2cl-lib:array-slice c-%data% 1267 double-float 1268 ((+ n 1 (f2cl-lib:int-sub i)) 1) 1269 ((1 ldc) (1 *)) 1270 c-%offset%) 1271 ldc)))) 1272 label190)) 1273 (go label220) 1274 label200 1275 (setf info 0) 1276 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 1277 ((> i (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) nil) 1278 (tagbody 1279 (if (/= (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) zero) 1280 (setf info (f2cl-lib:int-add info 1))) 1281 label210)) 1282 label220 1283 (go end_label) 1284 end_label 1285 (return 1286 (values nil 1287 nil 1288 nil 1289 nil 1290 nil 1291 nil 1292 nil 1293 nil 1294 nil 1295 nil 1296 nil 1297 nil 1298 nil 1299 nil 1300 info)))))) 1301 1302(in-package #-gcl #:cl-user #+gcl "CL-USER") 1303#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 1304(eval-when (:load-toplevel :compile-toplevel :execute) 1305 (setf (gethash 'fortran-to-lisp::dbdsqr 1306 fortran-to-lisp::*f2cl-function-info*) 1307 (fortran-to-lisp::make-f2cl-finfo 1308 :arg-types '((simple-string) (fortran-to-lisp::integer4) 1309 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 1310 (fortran-to-lisp::integer4) (array double-float (*)) 1311 (array double-float (*)) (array double-float (*)) 1312 (fortran-to-lisp::integer4) (array double-float (*)) 1313 (fortran-to-lisp::integer4) (array double-float (*)) 1314 (fortran-to-lisp::integer4) (array double-float (*)) 1315 (fortran-to-lisp::integer4)) 1316 :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil 1317 nil fortran-to-lisp::info) 1318 :calls '(fortran-to-lisp::dswap fortran-to-lisp::dscal 1319 fortran-to-lisp::dlas2 fortran-to-lisp::drot 1320 fortran-to-lisp::dlasv2 fortran-to-lisp::dlasr 1321 fortran-to-lisp::dlartg fortran-to-lisp::dlamch 1322 fortran-to-lisp::dlasq1 fortran-to-lisp::xerbla 1323 fortran-to-lisp::lsame)))) 1324 1325