00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
00032 #include <cstdio>
00033 #include <cstdlib>
00034
00035 #include "lapackblas.h"
00036
00037 int s_cat(char *lp, const char **rpp, integer *rnp, integer *np, ftnlen ll)
00038
00039 {
00040 ftnlen i, n, nc;
00041 const char *f__rp;
00042
00043 n = (int)*np;
00044 for(i = 0 ; i < n ; ++i) {
00045 nc = ll;
00046 if(rnp[i] < nc) nc = rnp[i];
00047 ll -= nc;
00048 f__rp = rpp[i];
00049 while(--nc >= 0) *lp++ = *f__rp++;
00050 }
00051 while(--ll >= 0)
00052 *lp++ = ' ';
00053 return 0;
00054 }
00055
00056 integer ieeeck_(integer *ispec, real *zero, real *one)
00057 {
00058
00059
00060
00061
00062
00063
00064
00065
00066
00067
00068
00069
00070
00071
00072
00073
00074
00075
00076
00077
00078
00079
00080
00081
00082
00083
00084
00085
00086
00087
00088
00089
00090
00091
00092
00093 integer ret_val;
00094
00095 static real neginf, posinf, negzro, newzro, nan1, nan2, nan3, nan4, nan5,
00096 nan6;
00097
00098
00099 ret_val = 1;
00100
00101 posinf = *one / *zero;
00102 if (posinf <= *one) {
00103 ret_val = 0;
00104 return ret_val;
00105 }
00106
00107 neginf = -(*one) / *zero;
00108 if (neginf >= *zero) {
00109 ret_val = 0;
00110 return ret_val;
00111 }
00112
00113 negzro = *one / (neginf + *one);
00114 if (negzro != *zero) {
00115 ret_val = 0;
00116 return ret_val;
00117 }
00118
00119 neginf = *one / negzro;
00120 if (neginf >= *zero) {
00121 ret_val = 0;
00122 return ret_val;
00123 }
00124
00125 newzro = negzro + *zero;
00126 if (newzro != *zero) {
00127 ret_val = 0;
00128 return ret_val;
00129 }
00130
00131 posinf = *one / newzro;
00132 if (posinf <= *one) {
00133 ret_val = 0;
00134 return ret_val;
00135 }
00136
00137 neginf *= posinf;
00138 if (neginf >= *zero) {
00139 ret_val = 0;
00140 return ret_val;
00141 }
00142
00143 posinf *= posinf;
00144 if (posinf <= *one) {
00145 ret_val = 0;
00146 return ret_val;
00147 }
00148
00149
00150
00151
00152
00153
00154 if (*ispec == 0) {
00155 return ret_val;
00156 }
00157
00158 nan1 = posinf + neginf;
00159
00160 nan2 = posinf / neginf;
00161
00162 nan3 = posinf / posinf;
00163
00164 nan4 = posinf * *zero;
00165
00166 nan5 = neginf * negzro;
00167
00168 nan6 = nan5 * 0.f;
00169
00170 if (nan1 == nan1) {
00171 ret_val = 0;
00172 return ret_val;
00173 }
00174
00175 if (nan2 == nan2) {
00176 ret_val = 0;
00177 return ret_val;
00178 }
00179
00180 if (nan3 == nan3) {
00181 ret_val = 0;
00182 return ret_val;
00183 }
00184
00185 if (nan4 == nan4) {
00186 ret_val = 0;
00187 return ret_val;
00188 }
00189
00190 if (nan5 == nan5) {
00191 ret_val = 0;
00192 return ret_val;
00193 }
00194
00195 if (nan6 == nan6) {
00196 ret_val = 0;
00197 return ret_val;
00198 }
00199
00200 return ret_val;
00201 }
00202
00203
00204
00205
00206 integer ilaenv_(integer *ispec, const char *name__, const char *, integer *n1,
00207 integer *n2, integer *, integer *n4, ftnlen name_len, ftnlen )
00208 {
00209
00210
00211
00212
00213
00214
00215
00216
00217
00218
00219
00220
00221
00222
00223
00224
00225
00226
00227
00228
00229
00230
00231
00232
00233
00234
00235
00236
00237
00238
00239
00240
00241
00242
00243
00244
00245
00246
00247
00248
00249
00250
00251
00252
00253
00254
00255
00256
00257
00258
00259
00260
00261
00262
00263
00264
00265
00266
00267
00268
00269
00270
00271
00272
00273
00274
00275
00276
00277
00278
00279
00280
00281
00282
00283
00284
00285
00286
00287
00288
00289
00290
00291
00292
00293
00294
00295
00296
00297
00298
00299
00300
00301
00302
00303
00304
00305 static integer c__0 = 0;
00306 static real c_b162 = 0.f;
00307 static real c_b163 = 1.f;
00308 static integer c__1 = 1;
00309
00310
00311 integer ret_val;
00312
00313 void s_copy(char *, const char *, ftnlen, ftnlen);
00314 integer s_cmp(char *, const char *, ftnlen, ftnlen);
00315
00316 static integer i__;
00317 static logical cname, sname;
00318 static integer nbmin;
00319 static char c1[1], c2[2], c3[3], c4[2];
00320 static integer ic, nb;
00321 extern integer ieeeck_(integer *, real *, real *);
00322 static integer iz, nx;
00323 static char subnam[6];
00324
00325
00326
00327
00328 switch (*ispec) {
00329 case 1: goto L100;
00330 case 2: goto L100;
00331 case 3: goto L100;
00332 case 4: goto L400;
00333 case 5: goto L500;
00334 case 6: goto L600;
00335 case 7: goto L700;
00336 case 8: goto L800;
00337 case 9: goto L900;
00338 case 10: goto L1000;
00339 case 11: goto L1100;
00340 }
00341
00342
00343
00344 ret_val = -1;
00345 return ret_val;
00346
00347 L100:
00348
00349
00350
00351 ret_val = 1;
00352 s_copy(subnam, name__, (ftnlen)6, name_len);
00353 ic = *(unsigned char *)subnam;
00354 iz = 'Z';
00355 if (iz == 90 || iz == 122) {
00356
00357
00358
00359 if (ic >= 97 && ic <= 122) {
00360 *(unsigned char *)subnam = (char) (ic - 32);
00361 for (i__ = 2; i__ <= 6; ++i__) {
00362 ic = *(unsigned char *)&subnam[i__ - 1];
00363 if (ic >= 97 && ic <= 122) {
00364 *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
00365 }
00366
00367 }
00368 }
00369
00370 } else if (iz == 233 || iz == 169) {
00371
00372
00373
00374 if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 &&
00375 ic <= 169) {
00376 *(unsigned char *)subnam = (char) (ic + 64);
00377 for (i__ = 2; i__ <= 6; ++i__) {
00378 ic = *(unsigned char *)&subnam[i__ - 1];
00379 if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >=
00380 162 && ic <= 169) {
00381 *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64);
00382 }
00383
00384 }
00385 }
00386
00387 } else if (iz == 218 || iz == 250) {
00388
00389
00390
00391 if (ic >= 225 && ic <= 250) {
00392 *(unsigned char *)subnam = (char) (ic - 32);
00393 for (i__ = 2; i__ <= 6; ++i__) {
00394 ic = *(unsigned char *)&subnam[i__ - 1];
00395 if (ic >= 225 && ic <= 250) {
00396 *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
00397 }
00398
00399 }
00400 }
00401 }
00402
00403 *(unsigned char *)c1 = *(unsigned char *)subnam;
00404 sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D';
00405 cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z';
00406 if (! (cname || sname)) {
00407 return ret_val;
00408 }
00409 s_copy(c2, subnam + 1, (ftnlen)2, (ftnlen)2);
00410 s_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3);
00411 s_copy(c4, c3 + 1, (ftnlen)2, (ftnlen)2);
00412
00413 switch (*ispec) {
00414 case 1: goto L110;
00415 case 2: goto L200;
00416 case 3: goto L300;
00417 }
00418
00419 L110:
00420
00421
00422
00423
00424
00425
00426
00427 nb = 1;
00428
00429 if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
00430 if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00431 if (sname) {
00432 nb = 64;
00433 } else {
00434 nb = 64;
00435 }
00436 } else if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3,
00437 "RQF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)
00438 3, (ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3)
00439 == 0) {
00440 if (sname) {
00441 nb = 32;
00442 } else {
00443 nb = 32;
00444 }
00445 } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
00446 if (sname) {
00447 nb = 32;
00448 } else {
00449 nb = 32;
00450 }
00451 } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
00452 if (sname) {
00453 nb = 32;
00454 } else {
00455 nb = 32;
00456 }
00457 } else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
00458 if (sname) {
00459 nb = 64;
00460 } else {
00461 nb = 64;
00462 }
00463 }
00464 } else if (s_cmp(c2, "PO", (ftnlen)2, (ftnlen)2) == 0) {
00465 if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00466 if (sname) {
00467 nb = 64;
00468 } else {
00469 nb = 64;
00470 }
00471 }
00472 } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
00473 if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00474 if (sname) {
00475 nb = 64;
00476 } else {
00477 nb = 64;
00478 }
00479 } else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
00480 nb = 32;
00481 } else if (sname && s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
00482 nb = 64;
00483 }
00484 } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
00485 if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00486 nb = 64;
00487 } else if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
00488 nb = 32;
00489 } else if (s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
00490 nb = 64;
00491 }
00492 } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
00493 if (*(unsigned char *)c3 == 'G') {
00494 if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
00495 (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00496 ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00497 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00498 c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00499 ftnlen)2, (ftnlen)2) == 0) {
00500 nb = 32;
00501 }
00502 } else if (*(unsigned char *)c3 == 'M') {
00503 if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
00504 (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00505 ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00506 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00507 c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00508 ftnlen)2, (ftnlen)2) == 0) {
00509 nb = 32;
00510 }
00511 }
00512 } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
00513 if (*(unsigned char *)c3 == 'G') {
00514 if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
00515 (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00516 ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00517 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00518 c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00519 ftnlen)2, (ftnlen)2) == 0) {
00520 nb = 32;
00521 }
00522 } else if (*(unsigned char *)c3 == 'M') {
00523 if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
00524 (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00525 ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00526 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00527 c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00528 ftnlen)2, (ftnlen)2) == 0) {
00529 nb = 32;
00530 }
00531 }
00532 } else if (s_cmp(c2, "GB", (ftnlen)2, (ftnlen)2) == 0) {
00533 if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00534 if (sname) {
00535 if (*n4 <= 64) {
00536 nb = 1;
00537 } else {
00538 nb = 32;
00539 }
00540 } else {
00541 if (*n4 <= 64) {
00542 nb = 1;
00543 } else {
00544 nb = 32;
00545 }
00546 }
00547 }
00548 } else if (s_cmp(c2, "PB", (ftnlen)2, (ftnlen)2) == 0) {
00549 if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00550 if (sname) {
00551 if (*n2 <= 64) {
00552 nb = 1;
00553 } else {
00554 nb = 32;
00555 }
00556 } else {
00557 if (*n2 <= 64) {
00558 nb = 1;
00559 } else {
00560 nb = 32;
00561 }
00562 }
00563 }
00564 } else if (s_cmp(c2, "TR", (ftnlen)2, (ftnlen)2) == 0) {
00565 if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
00566 if (sname) {
00567 nb = 64;
00568 } else {
00569 nb = 64;
00570 }
00571 }
00572 } else if (s_cmp(c2, "LA", (ftnlen)2, (ftnlen)2) == 0) {
00573 if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) {
00574 if (sname) {
00575 nb = 64;
00576 } else {
00577 nb = 64;
00578 }
00579 }
00580 } else if (sname && s_cmp(c2, "ST", (ftnlen)2, (ftnlen)2) == 0) {
00581 if (s_cmp(c3, "EBZ", (ftnlen)3, (ftnlen)3) == 0) {
00582 nb = 1;
00583 }
00584 }
00585 ret_val = nb;
00586 return ret_val;
00587
00588 L200:
00589
00590
00591
00592 nbmin = 2;
00593 if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
00594 if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
00595 ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
00596 ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0)
00597 {
00598 if (sname) {
00599 nbmin = 2;
00600 } else {
00601 nbmin = 2;
00602 }
00603 } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
00604 if (sname) {
00605 nbmin = 2;
00606 } else {
00607 nbmin = 2;
00608 }
00609 } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
00610 if (sname) {
00611 nbmin = 2;
00612 } else {
00613 nbmin = 2;
00614 }
00615 } else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
00616 if (sname) {
00617 nbmin = 2;
00618 } else {
00619 nbmin = 2;
00620 }
00621 }
00622 } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
00623 if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00624 if (sname) {
00625 nbmin = 8;
00626 } else {
00627 nbmin = 8;
00628 }
00629 } else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
00630 nbmin = 2;
00631 }
00632 } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
00633 if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
00634 nbmin = 2;
00635 }
00636 } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
00637 if (*(unsigned char *)c3 == 'G') {
00638 if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
00639 (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00640 ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00641 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00642 c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00643 ftnlen)2, (ftnlen)2) == 0) {
00644 nbmin = 2;
00645 }
00646 } else if (*(unsigned char *)c3 == 'M') {
00647 if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
00648 (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00649 ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00650 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00651 c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00652 ftnlen)2, (ftnlen)2) == 0) {
00653 nbmin = 2;
00654 }
00655 }
00656 } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
00657 if (*(unsigned char *)c3 == 'G') {
00658 if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
00659 (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00660 ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00661 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00662 c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00663 ftnlen)2, (ftnlen)2) == 0) {
00664 nbmin = 2;
00665 }
00666 } else if (*(unsigned char *)c3 == 'M') {
00667 if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
00668 (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00669 ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00670 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00671 c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00672 ftnlen)2, (ftnlen)2) == 0) {
00673 nbmin = 2;
00674 }
00675 }
00676 }
00677 ret_val = nbmin;
00678 return ret_val;
00679
00680 L300:
00681
00682
00683
00684 nx = 0;
00685 if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
00686 if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
00687 ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
00688 ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0)
00689 {
00690 if (sname) {
00691 nx = 128;
00692 } else {
00693 nx = 128;
00694 }
00695 } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
00696 if (sname) {
00697 nx = 128;
00698 } else {
00699 nx = 128;
00700 }
00701 } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
00702 if (sname) {
00703 nx = 128;
00704 } else {
00705 nx = 128;
00706 }
00707 }
00708 } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
00709 if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
00710 nx = 32;
00711 }
00712 } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
00713 if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
00714 nx = 32;
00715 }
00716 } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
00717 if (*(unsigned char *)c3 == 'G') {
00718 if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
00719 (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00720 ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00721 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00722 c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00723 ftnlen)2, (ftnlen)2) == 0) {
00724 nx = 128;
00725 }
00726 }
00727 } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
00728 if (*(unsigned char *)c3 == 'G') {
00729 if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
00730 (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00731 ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00732 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00733 c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00734 ftnlen)2, (ftnlen)2) == 0) {
00735 nx = 128;
00736 }
00737 }
00738 }
00739 ret_val = nx;
00740 return ret_val;
00741
00742 L400:
00743
00744
00745
00746 ret_val = 6;
00747 return ret_val;
00748
00749 L500:
00750
00751
00752
00753 ret_val = 2;
00754 return ret_val;
00755
00756 L600:
00757
00758
00759
00760 ret_val = (integer) ((real) f2cmin(*n1,*n2) * 1.6f);
00761 return ret_val;
00762
00763 L700:
00764
00765
00766
00767 ret_val = 1;
00768 return ret_val;
00769
00770 L800:
00771
00772
00773
00774 ret_val = 50;
00775 return ret_val;
00776
00777 L900:
00778
00779
00780
00781
00782
00783 ret_val = 25;
00784 return ret_val;
00785
00786 L1000:
00787
00788
00789
00790
00791 ret_val = 1;
00792 if (ret_val == 1) {
00793 ret_val = ieeeck_(&c__0, &c_b162, &c_b163);
00794 }
00795 return ret_val;
00796
00797 L1100:
00798
00799
00800
00801
00802 ret_val = 1;
00803 if (ret_val == 1) {
00804 ret_val = ieeeck_(&c__1, &c_b162, &c_b163);
00805 }
00806 return ret_val;
00807
00808
00809
00810 }
00811
00812
00813
00814 logical lsame_(const char *ca, const char *cb)
00815 {
00816
00817
00818
00819
00820
00821
00822
00823
00824
00825
00826
00827
00828
00829
00830
00831
00832
00833
00834
00835
00836
00837
00838
00839
00840
00841 logical ret_val;
00842
00843 static integer inta, intb, zcode;
00844
00845
00846 ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
00847 if (ret_val) {
00848 return ret_val;
00849 }
00850
00851
00852
00853 zcode = 'Z';
00854
00855
00856
00857
00858
00859
00860 inta = *(unsigned char *)ca;
00861 intb = *(unsigned char *)cb;
00862
00863 if (zcode == 90 || zcode == 122) {
00864
00865
00866
00867
00868
00869 if (inta >= 97 && inta <= 122) {
00870 inta += -32;
00871 }
00872 if (intb >= 97 && intb <= 122) {
00873 intb += -32;
00874 }
00875
00876 } else if (zcode == 233 || zcode == 169) {
00877
00878
00879
00880
00881
00882 if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta
00883 >= 162 && inta <= 169) {
00884 inta += 64;
00885 }
00886 if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb
00887 >= 162 && intb <= 169) {
00888 intb += 64;
00889 }
00890
00891 } else if (zcode == 218 || zcode == 250) {
00892
00893
00894
00895
00896
00897 if (inta >= 225 && inta <= 250) {
00898 inta += -32;
00899 }
00900 if (intb >= 225 && intb <= 250) {
00901 intb += -32;
00902 }
00903 }
00904 ret_val = inta == intb;
00905
00906
00907
00908
00909
00910 return ret_val;
00911 }
00912
00913
00914
00915 #ifdef KR_headers
00916 double pow_ri(ap, bp) real *ap; integer *bp;
00917 #else
00918 double pow_ri(real *ap, integer *bp)
00919 #endif
00920 {
00921 double pow, x;
00922 integer n;
00923 unsigned long u;
00924
00925 pow = 1;
00926 x = *ap;
00927 n = *bp;
00928
00929 if(n != 0)
00930 {
00931 if(n < 0)
00932 {
00933 n = -n;
00934 x = 1/x;
00935 }
00936 for(u = n; ; )
00937 {
00938 if(u & 01)
00939 pow *= x;
00940 if(u >>= 1)
00941 x *= x;
00942 else
00943 break;
00944 }
00945 }
00946 return(pow);
00947 }
00948
00949 #ifdef KR_headers
00950 integer pow_ii(ap, bp) integer *ap, *bp;
00951 #else
00952 integer pow_ii(integer *ap, integer *bp)
00953 #endif
00954 {
00955 integer pow, x, n;
00956 unsigned long u;
00957
00958 x = *ap;
00959 n = *bp;
00960
00961 if (n <= 0) {
00962 if (n == 0 || x == 1)
00963 return 1;
00964 if (x != -1)
00965 return x != 0 ? 1/x : 0;
00966 n = -n;
00967 }
00968 u = n;
00969 for(pow = 1; ; )
00970 {
00971 if(u & 01)
00972 pow *= x;
00973 if(u >>= 1)
00974 x *= x;
00975 else
00976 break;
00977 }
00978 return(pow);
00979 }
00980
00981 #ifdef KR_headers
00982 double r_sign(a,b) real *a, *b;
00983 #else
00984 double r_sign(real *a, real *b)
00985 #endif
00986 {
00987 double x;
00988 x = (*a >= 0 ? *a : - *a);
00989 return( *b >= 0 ? x : -x);
00990 }
00991
00992
00993
00994 int saxpy_(integer *n, real *sa, real *sx, integer *incx,
00995 real *sy, integer *incy)
00996 {
00997
00998 integer i__1;
00999
01000 static integer i__, m, ix, iy, mp1;
01001
01002
01003
01004
01005
01006 --sy;
01007 --sx;
01008
01009 if (*n <= 0) {
01010 return 0;
01011 }
01012 if (*sa == 0.f) {
01013 return 0;
01014 }
01015 if (*incx == 1 && *incy == 1) {
01016 goto L20;
01017 }
01018
01019
01020 ix = 1;
01021 iy = 1;
01022 if (*incx < 0) {
01023 ix = (-(*n) + 1) * *incx + 1;
01024 }
01025 if (*incy < 0) {
01026 iy = (-(*n) + 1) * *incy + 1;
01027 }
01028 i__1 = *n;
01029 for (i__ = 1; i__ <= i__1; ++i__) {
01030 sy[iy] += *sa * sx[ix];
01031 ix += *incx;
01032 iy += *incy;
01033
01034 }
01035 return 0;
01036
01037
01038 L20:
01039 m = *n % 4;
01040 if (m == 0) {
01041 goto L40;
01042 }
01043 i__1 = m;
01044 for (i__ = 1; i__ <= i__1; ++i__) {
01045 sy[i__] += *sa * sx[i__];
01046
01047 }
01048 if (*n < 4) {
01049 return 0;
01050 }
01051 L40:
01052 mp1 = m + 1;
01053 i__1 = *n;
01054 for (i__ = mp1; i__ <= i__1; i__ += 4) {
01055 sy[i__] += *sa * sx[i__];
01056 sy[i__ + 1] += *sa * sx[i__ + 1];
01057 sy[i__ + 2] += *sa * sx[i__ + 2];
01058 sy[i__ + 3] += *sa * sx[i__ + 3];
01059
01060 }
01061 return 0;
01062 }
01063
01064
01065
01066
01067
01068 #ifdef KR_headers
01069 integer s_cmp(a0, b0, la, lb) char *a0, *b0; ftnlen la, lb;
01070 #else
01071 integer s_cmp(char *a0, const char *b0, ftnlen la, ftnlen lb)
01072 #endif
01073 {
01074 register unsigned char *a, *aend, *b, *bend;
01075 a = (unsigned char *)a0;
01076 b = (unsigned char *)b0;
01077 aend = a + la;
01078 bend = b + lb;
01079
01080 if(la <= lb)
01081 {
01082 while(a < aend)
01083 if(*a != *b)
01084 return( *a - *b );
01085 else
01086 { ++a; ++b; }
01087
01088 while(b < bend)
01089 if(*b != ' ')
01090 return( ' ' - *b );
01091 else ++b;
01092 }
01093
01094 else
01095 {
01096 while(b < bend)
01097 if(*a == *b)
01098 { ++a; ++b; }
01099 else
01100 return( *a - *b );
01101 while(a < aend)
01102 if(*a != ' ')
01103 return(*a - ' ');
01104 else ++a;
01105 }
01106 return(0);
01107 }
01108
01109
01110
01111
01112
01113
01114
01115
01116
01117
01118 #ifdef KR_headers
01119 VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb;
01120 #else
01121 void s_copy(char *a, const char *b, ftnlen la, ftnlen lb)
01122 #endif
01123 {
01124 register char *aend;
01125 const register char *bend;
01126
01127 aend = a + la;
01128
01129 if(la <= lb)
01130 #ifndef NO_OVERWRITE
01131 if (a <= b || a >= b + la)
01132 #endif
01133 while(a < aend)
01134 *a++ = *b++;
01135 #ifndef NO_OVERWRITE
01136 else
01137 for(b += la; a < aend; )
01138 *--aend = *--b;
01139 #endif
01140
01141 else {
01142 bend = b + lb;
01143 #ifndef NO_OVERWRITE
01144 if (a <= b || a >= bend)
01145 #endif
01146 while(b < bend)
01147 *a++ = *b++;
01148 #ifndef NO_OVERWRITE
01149 else {
01150 a += lb;
01151 while(b < bend)
01152 *--a = *--bend;
01153 a += lb;
01154 }
01155 #endif
01156 while(a < aend)
01157 *a++ = ' ';
01158 }
01159 }
01160
01161
01162
01163 int scopy_(integer *n, real *sx, integer *incx, real *sy,
01164 integer *incy)
01165 {
01166
01167 integer i__1;
01168
01169 static integer i__, m, ix, iy, mp1;
01170
01171
01172
01173
01174
01175 --sy;
01176 --sx;
01177
01178 if (*n <= 0) {
01179 return 0;
01180 }
01181 if (*incx == 1 && *incy == 1) {
01182 goto L20;
01183 }
01184
01185
01186 ix = 1;
01187 iy = 1;
01188 if (*incx < 0) {
01189 ix = (-(*n) + 1) * *incx + 1;
01190 }
01191 if (*incy < 0) {
01192 iy = (-(*n) + 1) * *incy + 1;
01193 }
01194 i__1 = *n;
01195 for (i__ = 1; i__ <= i__1; ++i__) {
01196 sy[iy] = sx[ix];
01197 ix += *incx;
01198 iy += *incy;
01199
01200 }
01201 return 0;
01202
01203
01204 L20:
01205 m = *n % 7;
01206 if (m == 0) {
01207 goto L40;
01208 }
01209 i__1 = m;
01210 for (i__ = 1; i__ <= i__1; ++i__) {
01211 sy[i__] = sx[i__];
01212
01213 }
01214 if (*n < 7) {
01215 return 0;
01216 }
01217 L40:
01218 mp1 = m + 1;
01219 i__1 = *n;
01220 for (i__ = mp1; i__ <= i__1; i__ += 7) {
01221 sy[i__] = sx[i__];
01222 sy[i__ + 1] = sx[i__ + 1];
01223 sy[i__ + 2] = sx[i__ + 2];
01224 sy[i__ + 3] = sx[i__ + 3];
01225 sy[i__ + 4] = sx[i__ + 4];
01226 sy[i__ + 5] = sx[i__ + 5];
01227 sy[i__ + 6] = sx[i__ + 6];
01228
01229 }
01230 return 0;
01231 }
01232
01233
01234
01235
01236 doublereal sdot_(integer *n, real *sx, integer *incx, real *sy, integer *incy)
01237 {
01238
01239 integer i__1;
01240 real ret_val;
01241
01242 static integer i__, m;
01243 static real stemp;
01244 static integer ix, iy, mp1;
01245
01246
01247
01248
01249
01250 --sy;
01251 --sx;
01252
01253 stemp = 0.f;
01254 ret_val = 0.f;
01255 if (*n <= 0) {
01256 return ret_val;
01257 }
01258 if (*incx == 1 && *incy == 1) {
01259 goto L20;
01260 }
01261
01262
01263 ix = 1;
01264 iy = 1;
01265 if (*incx < 0) {
01266 ix = (-(*n) + 1) * *incx + 1;
01267 }
01268 if (*incy < 0) {
01269 iy = (-(*n) + 1) * *incy + 1;
01270 }
01271 i__1 = *n;
01272 for (i__ = 1; i__ <= i__1; ++i__) {
01273 stemp += sx[ix] * sy[iy];
01274 ix += *incx;
01275 iy += *incy;
01276
01277 }
01278 ret_val = stemp;
01279 return ret_val;
01280
01281
01282 L20:
01283 m = *n % 5;
01284 if (m == 0) {
01285 goto L40;
01286 }
01287 i__1 = m;
01288 for (i__ = 1; i__ <= i__1; ++i__) {
01289 stemp += sx[i__] * sy[i__];
01290
01291 }
01292 if (*n < 5) {
01293 goto L60;
01294 }
01295 L40:
01296 mp1 = m + 1;
01297 i__1 = *n;
01298 for (i__ = mp1; i__ <= i__1; i__ += 5) {
01299 stemp = stemp + sx[i__] * sy[i__] + sx[i__ + 1] * sy[i__ + 1] + sx[
01300 i__ + 2] * sy[i__ + 2] + sx[i__ + 3] * sy[i__ + 3] + sx[i__ +
01301 4] * sy[i__ + 4];
01302
01303 }
01304 L60:
01305 ret_val = stemp;
01306 return ret_val;
01307 }
01308
01309
01310
01311
01312 int sgemm_(const char *transa, const char *transb, integer *m, integer *
01313 n, integer *k, real *alpha, real *a, integer *lda, real *b, integer *
01314 ldb, real *beta, real *c__, integer *ldc)
01315 {
01316
01317 integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
01318 i__3;
01319
01320 static integer info;
01321 static logical nota, notb;
01322 static real temp;
01323 static integer i__, j, l, ncola;
01324 extern logical lsame_(const char *, const char *);
01325 static integer nrowa, nrowb;
01326 extern int xerbla_(const char *, integer *);
01327 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
01328 #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
01329 #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
01330
01331
01332
01333
01334
01335
01336
01337
01338
01339
01340
01341
01342
01343
01344
01345
01346
01347
01348
01349
01350
01351
01352
01353
01354
01355
01356
01357
01358
01359
01360
01361
01362
01363
01364
01365
01366
01367
01368
01369
01370
01371
01372
01373
01374
01375
01376
01377
01378
01379
01380
01381
01382
01383
01384
01385
01386
01387
01388
01389
01390
01391
01392
01393
01394
01395
01396
01397
01398
01399
01400
01401
01402
01403
01404
01405
01406
01407
01408
01409
01410
01411
01412
01413
01414
01415
01416
01417
01418
01419
01420
01421
01422 a_dim1 = *lda;
01423 a_offset = 1 + a_dim1 * 1;
01424 a -= a_offset;
01425 b_dim1 = *ldb;
01426 b_offset = 1 + b_dim1 * 1;
01427 b -= b_offset;
01428 c_dim1 = *ldc;
01429 c_offset = 1 + c_dim1 * 1;
01430 c__ -= c_offset;
01431
01432 nota = lsame_(transa, "N");
01433 notb = lsame_(transb, "N");
01434 if (nota) {
01435 nrowa = *m;
01436 ncola = *k;
01437 } else {
01438 nrowa = *k;
01439 ncola = *m;
01440 }
01441 if (notb) {
01442 nrowb = *k;
01443 } else {
01444 nrowb = *n;
01445 }
01446
01447 info = 0;
01448 if (! nota && ! lsame_(transa, "C") && ! lsame_(
01449 transa, "T")) {
01450 info = 1;
01451 } else if (! notb && ! lsame_(transb, "C") && !
01452 lsame_(transb, "T")) {
01453 info = 2;
01454 } else if (*m < 0) {
01455 info = 3;
01456 } else if (*n < 0) {
01457 info = 4;
01458 } else if (*k < 0) {
01459 info = 5;
01460 } else if (*lda < f2cmax(1,nrowa)) {
01461 info = 8;
01462 } else if (*ldb < f2cmax(1,nrowb)) {
01463 info = 10;
01464 } else if (*ldc < f2cmax(1,*m)) {
01465 info = 13;
01466 }
01467 if (info != 0) {
01468 xerbla_("SGEMM ", &info);
01469 return 0;
01470 }
01471
01472 if (*m == 0 || *n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
01473 return 0;
01474 }
01475
01476 if (*alpha == 0.f) {
01477 if (*beta == 0.f) {
01478 i__1 = *n;
01479 for (j = 1; j <= i__1; ++j) {
01480 i__2 = *m;
01481 for (i__ = 1; i__ <= i__2; ++i__) {
01482 c___ref(i__, j) = 0.f;
01483
01484 }
01485
01486 }
01487 } else {
01488 i__1 = *n;
01489 for (j = 1; j <= i__1; ++j) {
01490 i__2 = *m;
01491 for (i__ = 1; i__ <= i__2; ++i__) {
01492 c___ref(i__, j) = *beta * c___ref(i__, j);
01493
01494 }
01495
01496 }
01497 }
01498 return 0;
01499 }
01500
01501 if (notb) {
01502 if (nota) {
01503
01504 i__1 = *n;
01505 for (j = 1; j <= i__1; ++j) {
01506 if (*beta == 0.f) {
01507 i__2 = *m;
01508 for (i__ = 1; i__ <= i__2; ++i__) {
01509 c___ref(i__, j) = 0.f;
01510
01511 }
01512 } else if (*beta != 1.f) {
01513 i__2 = *m;
01514 for (i__ = 1; i__ <= i__2; ++i__) {
01515 c___ref(i__, j) = *beta * c___ref(i__, j);
01516
01517 }
01518 }
01519 i__2 = *k;
01520 for (l = 1; l <= i__2; ++l) {
01521 if (b_ref(l, j) != 0.f) {
01522 temp = *alpha * b_ref(l, j);
01523 i__3 = *m;
01524 for (i__ = 1; i__ <= i__3; ++i__) {
01525 c___ref(i__, j) = c___ref(i__, j) + temp * a_ref(
01526 i__, l);
01527
01528 }
01529 }
01530
01531 }
01532
01533 }
01534 } else {
01535
01536 i__1 = *n;
01537 for (j = 1; j <= i__1; ++j) {
01538 i__2 = *m;
01539 for (i__ = 1; i__ <= i__2; ++i__) {
01540 temp = 0.f;
01541 i__3 = *k;
01542 for (l = 1; l <= i__3; ++l) {
01543 temp += a_ref(l, i__) * b_ref(l, j);
01544
01545 }
01546 if (*beta == 0.f) {
01547 c___ref(i__, j) = *alpha * temp;
01548 } else {
01549 c___ref(i__, j) = *alpha * temp + *beta * c___ref(i__,
01550 j);
01551 }
01552
01553 }
01554
01555 }
01556 }
01557 } else {
01558 if (nota) {
01559
01560 i__1 = *n;
01561 for (j = 1; j <= i__1; ++j) {
01562 if (*beta == 0.f) {
01563 i__2 = *m;
01564 for (i__ = 1; i__ <= i__2; ++i__) {
01565 c___ref(i__, j) = 0.f;
01566
01567 }
01568 } else if (*beta != 1.f) {
01569 i__2 = *m;
01570 for (i__ = 1; i__ <= i__2; ++i__) {
01571 c___ref(i__, j) = *beta * c___ref(i__, j);
01572
01573 }
01574 }
01575 i__2 = *k;
01576 for (l = 1; l <= i__2; ++l) {
01577 if (b_ref(j, l) != 0.f) {
01578 temp = *alpha * b_ref(j, l);
01579 i__3 = *m;
01580 for (i__ = 1; i__ <= i__3; ++i__) {
01581 c___ref(i__, j) = c___ref(i__, j) + temp * a_ref(
01582 i__, l);
01583
01584 }
01585 }
01586
01587 }
01588
01589 }
01590 } else {
01591
01592 i__1 = *n;
01593 for (j = 1; j <= i__1; ++j) {
01594 i__2 = *m;
01595 for (i__ = 1; i__ <= i__2; ++i__) {
01596 temp = 0.f;
01597 i__3 = *k;
01598 for (l = 1; l <= i__3; ++l) {
01599 temp += a_ref(l, i__) * b_ref(j, l);
01600
01601 }
01602 if (*beta == 0.f) {
01603 c___ref(i__, j) = *alpha * temp;
01604 } else {
01605 c___ref(i__, j) = *alpha * temp + *beta * c___ref(i__,
01606 j);
01607 }
01608
01609 }
01610
01611 }
01612 }
01613 }
01614 return 0;
01615
01616 }
01617 #undef c___ref
01618 #undef b_ref
01619 #undef a_ref
01620
01621
01622
01623
01624 int sgemv_(const char *trans, integer *m, integer *n, real *alpha,
01625 real *a, integer *lda, real *x, integer *incx, real *beta, real *y,
01626 integer *incy)
01627 {
01628
01629 integer a_dim1, a_offset, i__1, i__2;
01630
01631 static integer info;
01632 static real temp;
01633 static integer lenx, leny, i__, j;
01634 extern logical lsame_(const char *, const char *);
01635 static integer ix, iy, jx, jy, kx, ky;
01636 extern int xerbla_(const char *, integer *);
01637 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
01638
01639
01640
01641
01642
01643
01644
01645
01646
01647
01648
01649
01650
01651
01652
01653
01654
01655
01656
01657
01658
01659
01660
01661
01662
01663
01664
01665
01666
01667
01668
01669
01670
01671
01672
01673
01674
01675
01676
01677
01678
01679
01680
01681
01682
01683
01684
01685
01686
01687
01688
01689
01690
01691
01692
01693
01694
01695
01696
01697
01698
01699
01700
01701
01702
01703
01704
01705
01706
01707 a_dim1 = *lda;
01708 a_offset = 1 + a_dim1 * 1;
01709 a -= a_offset;
01710 --x;
01711 --y;
01712
01713 info = 0;
01714 if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
01715 ) {
01716 info = 1;
01717 } else if (*m < 0) {
01718 info = 2;
01719 } else if (*n < 0) {
01720 info = 3;
01721 } else if (*lda < f2cmax(1,*m)) {
01722 info = 6;
01723 } else if (*incx == 0) {
01724 info = 8;
01725 } else if (*incy == 0) {
01726 info = 11;
01727 }
01728 if (info != 0) {
01729 xerbla_("SGEMV ", &info);
01730 return 0;
01731 }
01732
01733 if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
01734 return 0;
01735 }
01736
01737
01738 if (lsame_(trans, "N")) {
01739 lenx = *n;
01740 leny = *m;
01741 } else {
01742 lenx = *m;
01743 leny = *n;
01744 }
01745 if (*incx > 0) {
01746 kx = 1;
01747 } else {
01748 kx = 1 - (lenx - 1) * *incx;
01749 }
01750 if (*incy > 0) {
01751 ky = 1;
01752 } else {
01753 ky = 1 - (leny - 1) * *incy;
01754 }
01755
01756
01757
01758 if (*beta != 1.f) {
01759 if (*incy == 1) {
01760 if (*beta == 0.f) {
01761 i__1 = leny;
01762 for (i__ = 1; i__ <= i__1; ++i__) {
01763 y[i__] = 0.f;
01764
01765 }
01766 } else {
01767 i__1 = leny;
01768 for (i__ = 1; i__ <= i__1; ++i__) {
01769 y[i__] = *beta * y[i__];
01770
01771 }
01772 }
01773 } else {
01774 iy = ky;
01775 if (*beta == 0.f) {
01776 i__1 = leny;
01777 for (i__ = 1; i__ <= i__1; ++i__) {
01778 y[iy] = 0.f;
01779 iy += *incy;
01780
01781 }
01782 } else {
01783 i__1 = leny;
01784 for (i__ = 1; i__ <= i__1; ++i__) {
01785 y[iy] = *beta * y[iy];
01786 iy += *incy;
01787
01788 }
01789 }
01790 }
01791 }
01792 if (*alpha == 0.f) {
01793 return 0;
01794 }
01795 if (lsame_(trans, "N")) {
01796
01797 jx = kx;
01798 if (*incy == 1) {
01799 i__1 = *n;
01800 for (j = 1; j <= i__1; ++j) {
01801 if (x[jx] != 0.f) {
01802 temp = *alpha * x[jx];
01803 i__2 = *m;
01804 for (i__ = 1; i__ <= i__2; ++i__) {
01805 y[i__] += temp * a_ref(i__, j);
01806
01807 }
01808 }
01809 jx += *incx;
01810
01811 }
01812 } else {
01813 i__1 = *n;
01814 for (j = 1; j <= i__1; ++j) {
01815 if (x[jx] != 0.f) {
01816 temp = *alpha * x[jx];
01817 iy = ky;
01818 i__2 = *m;
01819 for (i__ = 1; i__ <= i__2; ++i__) {
01820 y[iy] += temp * a_ref(i__, j);
01821 iy += *incy;
01822
01823 }
01824 }
01825 jx += *incx;
01826
01827 }
01828 }
01829 } else {
01830
01831 jy = ky;
01832 if (*incx == 1) {
01833 i__1 = *n;
01834 for (j = 1; j <= i__1; ++j) {
01835 temp = 0.f;
01836 i__2 = *m;
01837 for (i__ = 1; i__ <= i__2; ++i__) {
01838 temp += a_ref(i__, j) * x[i__];
01839
01840 }
01841 y[jy] += *alpha * temp;
01842 jy += *incy;
01843
01844 }
01845 } else {
01846 i__1 = *n;
01847 for (j = 1; j <= i__1; ++j) {
01848 temp = 0.f;
01849 ix = kx;
01850 i__2 = *m;
01851 for (i__ = 1; i__ <= i__2; ++i__) {
01852 temp += a_ref(i__, j) * x[ix];
01853 ix += *incx;
01854
01855 }
01856 y[jy] += *alpha * temp;
01857 jy += *incy;
01858
01859 }
01860 }
01861 }
01862 return 0;
01863
01864 }
01865 #undef a_ref
01866
01867
01868
01869
01870 int sger_(integer *m, integer *n, real *alpha, real *x,
01871 integer *incx, real *y, integer *incy, real *a, integer *lda)
01872 {
01873
01874 integer a_dim1, a_offset, i__1, i__2;
01875
01876 static integer info;
01877 static real temp;
01878 static integer i__, j, ix, jy, kx;
01879 extern int xerbla_(const char *, integer *);
01880 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
01881
01882
01883
01884
01885
01886
01887
01888
01889
01890
01891
01892
01893
01894
01895
01896
01897
01898
01899
01900
01901
01902
01903
01904
01905
01906
01907
01908
01909
01910
01911
01912
01913
01914
01915
01916
01917
01918
01919
01920
01921
01922
01923
01924
01925
01926
01927
01928
01929
01930
01931
01932
01933
01934
01935 --x;
01936 --y;
01937 a_dim1 = *lda;
01938 a_offset = 1 + a_dim1 * 1;
01939 a -= a_offset;
01940
01941 info = 0;
01942 if (*m < 0) {
01943 info = 1;
01944 } else if (*n < 0) {
01945 info = 2;
01946 } else if (*incx == 0) {
01947 info = 5;
01948 } else if (*incy == 0) {
01949 info = 7;
01950 } else if (*lda < f2cmax(1,*m)) {
01951 info = 9;
01952 }
01953 if (info != 0) {
01954 xerbla_("SGER ", &info);
01955 return 0;
01956 }
01957
01958 if (*m == 0 || *n == 0 || *alpha == 0.f) {
01959 return 0;
01960 }
01961
01962
01963 if (*incy > 0) {
01964 jy = 1;
01965 } else {
01966 jy = 1 - (*n - 1) * *incy;
01967 }
01968 if (*incx == 1) {
01969 i__1 = *n;
01970 for (j = 1; j <= i__1; ++j) {
01971 if (y[jy] != 0.f) {
01972 temp = *alpha * y[jy];
01973 i__2 = *m;
01974 for (i__ = 1; i__ <= i__2; ++i__) {
01975 a_ref(i__, j) = a_ref(i__, j) + x[i__] * temp;
01976
01977 }
01978 }
01979 jy += *incy;
01980
01981 }
01982 } else {
01983 if (*incx > 0) {
01984 kx = 1;
01985 } else {
01986 kx = 1 - (*m - 1) * *incx;
01987 }
01988 i__1 = *n;
01989 for (j = 1; j <= i__1; ++j) {
01990 if (y[jy] != 0.f) {
01991 temp = *alpha * y[jy];
01992 ix = kx;
01993 i__2 = *m;
01994 for (i__ = 1; i__ <= i__2; ++i__) {
01995 a_ref(i__, j) = a_ref(i__, j) + x[ix] * temp;
01996 ix += *incx;
01997
01998 }
01999 }
02000 jy += *incy;
02001
02002 }
02003 }
02004 return 0;
02005
02006 }
02007 #undef a_ref
02008
02009
02010
02011
02012 int slae2_(real *a, real *b, real *c__, real *rt1, real *rt2)
02013 {
02014
02015
02016
02017
02018
02019
02020
02021
02022
02023
02024
02025
02026
02027
02028
02029
02030
02031
02032
02033
02034
02035
02036
02037
02038
02039
02040
02041
02042
02043
02044
02045
02046
02047
02048
02049
02050
02051
02052
02053
02054
02055
02056
02057
02058
02059
02060
02061
02062
02063
02064
02065
02066 real r__1;
02067
02068
02069
02070 static real acmn, acmx, ab, df, tb, sm, rt, adf;
02071
02072
02073 sm = *a + *c__;
02074 df = *a - *c__;
02075 adf = dabs(df);
02076 tb = *b + *b;
02077 ab = dabs(tb);
02078 if (dabs(*a) > dabs(*c__)) {
02079 acmx = *a;
02080 acmn = *c__;
02081 } else {
02082 acmx = *c__;
02083 acmn = *a;
02084 }
02085 if (adf > ab) {
02086
02087 r__1 = ab / adf;
02088 rt = adf * sqrt(r__1 * r__1 + 1.f);
02089 } else if (adf < ab) {
02090
02091 r__1 = adf / ab;
02092 rt = ab * sqrt(r__1 * r__1 + 1.f);
02093 } else {
02094
02095
02096
02097 rt = ab * sqrt(2.f);
02098 }
02099 if (sm < 0.f) {
02100 *rt1 = (sm - rt) * .5f;
02101
02102
02103
02104
02105
02106 *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
02107 } else if (sm > 0.f) {
02108 *rt1 = (sm + rt) * .5f;
02109
02110
02111
02112
02113
02114 *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
02115 } else {
02116
02117
02118
02119 *rt1 = rt * .5f;
02120 *rt2 = rt * -.5f;
02121 }
02122 return 0;
02123
02124
02125
02126 }
02127
02128
02129
02130
02131 int slaev2_(real *a, real *b, real *c__, real *rt1, real *
02132 rt2, real *cs1, real *sn1)
02133 {
02134
02135
02136
02137
02138
02139
02140
02141
02142
02143
02144
02145
02146
02147
02148
02149
02150
02151
02152
02153
02154
02155
02156
02157
02158
02159
02160
02161
02162
02163
02164
02165
02166
02167
02168
02169
02170
02171
02172
02173
02174
02175
02176
02177
02178
02179
02180
02181
02182
02183
02184
02185
02186
02187
02188
02189
02190
02191
02192
02193
02194
02195
02196
02197 real r__1;
02198
02199
02200
02201 static real acmn, acmx, ab, df, cs, ct, tb, sm, tn, rt, adf, acs;
02202 static integer sgn1, sgn2;
02203
02204
02205 sm = *a + *c__;
02206 df = *a - *c__;
02207 adf = dabs(df);
02208 tb = *b + *b;
02209 ab = dabs(tb);
02210 if (dabs(*a) > dabs(*c__)) {
02211 acmx = *a;
02212 acmn = *c__;
02213 } else {
02214 acmx = *c__;
02215 acmn = *a;
02216 }
02217 if (adf > ab) {
02218
02219 r__1 = ab / adf;
02220 rt = adf * sqrt(r__1 * r__1 + 1.f);
02221 } else if (adf < ab) {
02222
02223 r__1 = adf / ab;
02224 rt = ab * sqrt(r__1 * r__1 + 1.f);
02225 } else {
02226
02227
02228
02229 rt = ab * sqrt(2.f);
02230 }
02231 if (sm < 0.f) {
02232 *rt1 = (sm - rt) * .5f;
02233 sgn1 = -1;
02234
02235
02236
02237
02238
02239 *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
02240 } else if (sm > 0.f) {
02241 *rt1 = (sm + rt) * .5f;
02242 sgn1 = 1;
02243
02244
02245
02246
02247
02248 *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
02249 } else {
02250
02251
02252
02253 *rt1 = rt * .5f;
02254 *rt2 = rt * -.5f;
02255 sgn1 = 1;
02256 }
02257
02258
02259
02260 if (df >= 0.f) {
02261 cs = df + rt;
02262 sgn2 = 1;
02263 } else {
02264 cs = df - rt;
02265 sgn2 = -1;
02266 }
02267 acs = dabs(cs);
02268 if (acs > ab) {
02269 ct = -tb / cs;
02270 *sn1 = 1.f / sqrt(ct * ct + 1.f);
02271 *cs1 = ct * *sn1;
02272 } else {
02273 if (ab == 0.f) {
02274 *cs1 = 1.f;
02275 *sn1 = 0.f;
02276 } else {
02277 tn = -cs / tb;
02278 *cs1 = 1.f / sqrt(tn * tn + 1.f);
02279 *sn1 = tn * *cs1;
02280 }
02281 }
02282 if (sgn1 == sgn2) {
02283 tn = *cs1;
02284 *cs1 = -(*sn1);
02285 *sn1 = tn;
02286 }
02287 return 0;
02288
02289
02290
02291 }
02292
02293
02294
02295 doublereal slamch_(const char *cmach)
02296 {
02297
02298
02299
02300
02301
02302
02303
02304
02305
02306
02307
02308
02309
02310
02311
02312
02313
02314
02315
02316
02317
02318
02319
02320
02321
02322
02323
02324
02325
02326
02327
02328
02329
02330
02331
02332
02333
02334
02335
02336
02337
02338
02339
02340
02341 static logical first = TRUE_;
02342
02343 integer i__1;
02344 real ret_val;
02345
02346 double pow_ri(real *, integer *);
02347
02348 static real base;
02349 static integer beta;
02350 static real emin, prec, emax;
02351 static integer imin, imax;
02352 static logical lrnd;
02353 static real rmin, rmax, t, rmach;
02354 extern logical lsame_(const char *, const char *);
02355 static real small, sfmin;
02356 extern int slamc2_(integer *, integer *, logical *, real
02357 *, integer *, real *, integer *, real *);
02358 static integer it;
02359 static real rnd, eps;
02360
02361
02362
02363 if (first) {
02364 first = FALSE_;
02365 slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
02366 base = (real) beta;
02367 t = (real) it;
02368 if (lrnd) {
02369 rnd = 1.f;
02370 i__1 = 1 - it;
02371 eps = pow_ri(&base, &i__1) / 2;
02372 } else {
02373 rnd = 0.f;
02374 i__1 = 1 - it;
02375 eps = pow_ri(&base, &i__1);
02376 }
02377 prec = eps * base;
02378 emin = (real) imin;
02379 emax = (real) imax;
02380 sfmin = rmin;
02381 small = 1.f / rmax;
02382 if (small >= sfmin) {
02383
02384
02385
02386
02387
02388 sfmin = small * (eps + 1.f);
02389 }
02390 }
02391
02392 if (lsame_(cmach, "E")) {
02393 rmach = eps;
02394 } else if (lsame_(cmach, "S")) {
02395 rmach = sfmin;
02396 } else if (lsame_(cmach, "B")) {
02397 rmach = base;
02398 } else if (lsame_(cmach, "P")) {
02399 rmach = prec;
02400 } else if (lsame_(cmach, "N")) {
02401 rmach = t;
02402 } else if (lsame_(cmach, "R")) {
02403 rmach = rnd;
02404 } else if (lsame_(cmach, "M")) {
02405 rmach = emin;
02406 } else if (lsame_(cmach, "U")) {
02407 rmach = rmin;
02408 } else if (lsame_(cmach, "L")) {
02409 rmach = emax;
02410 } else if (lsame_(cmach, "O")) {
02411 rmach = rmax;
02412 }
02413
02414 ret_val = rmach;
02415 return ret_val;
02416
02417
02418
02419 }
02420
02421
02422
02423 int slamc1_(integer *beta, integer *t, logical *rnd, logical
02424 *ieee1)
02425 {
02426
02427
02428
02429
02430
02431
02432
02433
02434
02435
02436
02437
02438
02439
02440
02441
02442
02443
02444
02445
02446
02447
02448
02449
02450
02451
02452
02453
02454
02455
02456
02457
02458
02459
02460
02461
02462
02463
02464
02465
02466
02467
02468
02469
02470
02471
02472
02473
02474
02475 static logical first = TRUE_;
02476
02477 real r__1, r__2;
02478
02479 static logical lrnd;
02480 static real a, b, c, f;
02481 static integer lbeta;
02482 static real savec;
02483 static logical lieee1;
02484 static real t1, t2;
02485 extern doublereal slamc3_(real *, real *);
02486 static integer lt;
02487 static real one, qtr;
02488
02489
02490
02491 if (first) {
02492 first = FALSE_;
02493 one = 1.f;
02494
02495
02496
02497
02498
02499
02500
02501
02502
02503
02504
02505
02506
02507
02508
02509
02510
02511 a = 1.f;
02512 c = 1.f;
02513
02514
02515 L10:
02516 if (c == one) {
02517 a *= 2;
02518 c = slamc3_(&a, &one);
02519 r__1 = -(doublereal)a;
02520 c = slamc3_(&c, &r__1);
02521 goto L10;
02522 }
02523
02524
02525
02526
02527
02528
02529
02530
02531 b = 1.f;
02532 c = slamc3_(&a, &b);
02533
02537 printf("\n");
02538
02539
02540 L20:
02541 if (c == a) {
02542 b *= 2;
02543 c = slamc3_(&a, &b);
02544 goto L20;
02545 }
02546
02547
02548
02549
02550
02551
02552
02553
02554
02555
02556 qtr = one / 4;
02557 savec = c;
02558 r__1 = -(doublereal)a;
02559 c = slamc3_(&c, &r__1);
02560 lbeta = static_cast<integer>(c + qtr);
02561
02562
02563
02564
02565
02566
02567 b = (real) lbeta;
02568 r__1 = b / 2;
02569 r__2 = -(doublereal)b / 100;
02570 f = slamc3_(&r__1, &r__2);
02571 c = slamc3_(&f, &a);
02572 if (c == a) {
02573 lrnd = TRUE_;
02574 } else {
02575 lrnd = FALSE_;
02576 }
02577 r__1 = b / 2;
02578 r__2 = b / 100;
02579 f = slamc3_(&r__1, &r__2);
02580 c = slamc3_(&f, &a);
02581 if (lrnd && c == a) {
02582 lrnd = FALSE_;
02583 }
02584
02585
02586
02587
02588
02589
02590
02591
02592
02593
02594
02595 r__1 = b / 2;
02596 t1 = slamc3_(&r__1, &a);
02597 r__1 = b / 2;
02598 t2 = slamc3_(&r__1, &savec);
02599 lieee1 = t1 == a && t2 > savec && lrnd;
02600
02601
02602
02603
02604
02605
02606
02607
02608
02609
02610
02611 lt = 0;
02612 a = 1.f;
02613 c = 1.f;
02614
02615
02616 L30:
02617 if (c == one) {
02618 ++lt;
02619 a *= lbeta;
02620 c = slamc3_(&a, &one);
02621 r__1 = -(doublereal)a;
02622 c = slamc3_(&c, &r__1);
02623 goto L30;
02624 }
02625
02626
02627 }
02628
02629 *beta = lbeta;
02630 *t = lt;
02631 *rnd = lrnd;
02632 *ieee1 = lieee1;
02633 return 0;
02634
02635
02636
02637 }
02638
02639
02640
02641 int slamc2_(integer *beta, integer *t, logical *rnd, real *
02642 eps, integer *emin, real *rmin, integer *emax, real *rmax)
02643 {
02644
02645
02646
02647
02648
02649
02650
02651
02652
02653
02654
02655
02656
02657
02658
02659
02660
02661
02662
02663
02664
02665
02666
02667
02668
02669
02670
02671
02672
02673
02674
02675
02676
02677
02678
02679
02680
02681
02682
02683
02684
02685
02686
02687
02688
02689
02690
02691
02692
02693
02694
02695
02696
02697
02698
02699
02700
02701
02702
02703
02704
02705
02706
02707
02708
02709
02710 static logical first = TRUE_;
02711 static logical iwarn = FALSE_;
02712
02713 integer i__1;
02714 real r__1, r__2, r__3, r__4, r__5;
02715
02716 double pow_ri(real *, integer *);
02717
02718 static logical ieee;
02719 static real half;
02720 static logical lrnd;
02721 static real leps, zero, a, b, c;
02722 static integer i, lbeta;
02723 static real rbase;
02724 static integer lemin, lemax, gnmin;
02725 static real small;
02726 static integer gpmin;
02727 static real third, lrmin, lrmax, sixth;
02728 static logical lieee1;
02729 extern int slamc1_(integer *, integer *, logical *,
02730 logical *);
02731 extern doublereal slamc3_(real *, real *);
02732 extern int slamc4_(integer *, real *, integer *),
02733 slamc5_(integer *, integer *, integer *, logical *, integer *,
02734 real *);
02735 static integer lt, ngnmin, ngpmin;
02736 static real one, two;
02737
02738
02739
02740 if (first) {
02741 first = FALSE_;
02742 zero = 0.f;
02743 one = 1.f;
02744 two = 2.f;
02745
02746
02747
02748
02749
02750
02751
02752
02753
02754
02755
02756
02757
02758
02759 slamc1_(&lbeta, <, &lrnd, &lieee1);
02760
02761
02762
02763 b = (real) lbeta;
02764 i__1 = -lt;
02765 a = pow_ri(&b, &i__1);
02766 leps = a;
02767
02768
02769
02770
02771 b = two / 3;
02772 half = one / 2;
02773 r__1 = -(doublereal)half;
02774 sixth = slamc3_(&b, &r__1);
02775 third = slamc3_(&sixth, &sixth);
02776 r__1 = -(doublereal)half;
02777 b = slamc3_(&third, &r__1);
02778 b = slamc3_(&b, &sixth);
02779 b = dabs(b);
02780 if (b < leps) {
02781 b = leps;
02782 }
02783
02784 leps = 1.f;
02785
02786
02787 L10:
02788 if (leps > b && b > zero) {
02789 leps = b;
02790 r__1 = half * leps;
02791
02792 r__3 = two, r__4 = r__3, r__3 *= r__3;
02793
02794 r__5 = leps;
02795 r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
02796 c = slamc3_(&r__1, &r__2);
02797 r__1 = -(doublereal)c;
02798 c = slamc3_(&half, &r__1);
02799 b = slamc3_(&half, &c);
02800 r__1 = -(doublereal)b;
02801 c = slamc3_(&half, &r__1);
02802 b = slamc3_(&half, &c);
02803 goto L10;
02804 }
02805
02806
02807 if (a < leps) {
02808 leps = a;
02809 }
02810
02811
02812
02813
02814
02815
02816
02817
02818
02819 rbase = one / lbeta;
02820 small = one;
02821 for (i = 1; i <= 3; ++i) {
02822 r__1 = small * rbase;
02823 small = slamc3_(&r__1, &zero);
02824
02825 }
02826 a = slamc3_(&one, &small);
02827 slamc4_(&ngpmin, &one, &lbeta);
02828 r__1 = -(doublereal)one;
02829 slamc4_(&ngnmin, &r__1, &lbeta);
02830 slamc4_(&gpmin, &a, &lbeta);
02831 r__1 = -(doublereal)a;
02832 slamc4_(&gnmin, &r__1, &lbeta);
02833 ieee = FALSE_;
02834
02835 if (ngpmin == ngnmin && gpmin == gnmin) {
02836 if (ngpmin == gpmin) {
02837 lemin = ngpmin;
02838
02839
02840
02841 } else if (gpmin - ngpmin == 3) {
02842 lemin = ngpmin - 1 + lt;
02843 ieee = TRUE_;
02844
02845
02846
02847 } else {
02848 lemin = f2cmin(ngpmin,gpmin);
02849
02850 iwarn = TRUE_;
02851 }
02852
02853 } else if (ngpmin == gpmin && ngnmin == gnmin) {
02854 if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
02855 lemin = f2cmax(ngpmin,ngnmin);
02856
02857
02858
02859 } else {
02860 lemin = f2cmin(ngpmin,ngnmin);
02861
02862 iwarn = TRUE_;
02863 }
02864
02865 } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
02866 {
02867 if (gpmin - f2cmin(ngpmin,ngnmin) == 3) {
02868 lemin = f2cmax(ngpmin,ngnmin) - 1 + lt;
02869
02870
02871
02872 } else {
02873 lemin = f2cmin(ngpmin,ngnmin);
02874
02875 iwarn = TRUE_;
02876 }
02877
02878 } else {
02879
02880 i__1 = f2cmin(ngpmin,ngnmin), i__1 = f2cmin(i__1,gpmin);
02881 lemin = f2cmin(i__1,gnmin);
02882
02883 iwarn = TRUE_;
02884 }
02885
02886
02887 if (iwarn) {
02888 first = TRUE_;
02889 printf("\n\n WARNING. The value EMIN may be incorrect:- ");
02890 printf("EMIN = %8i\n",lemin);
02891 printf("If, after inspection, the value EMIN looks acceptable");
02892 printf("please comment out \n the IF block as marked within the");
02893 printf("code of routine SLAMC2, \n otherwise supply EMIN");
02894 printf("explicitly.\n");
02895 }
02896
02897
02898
02899
02900
02901
02902
02903
02904
02905
02906 ieee = ieee || lieee1;
02907
02908
02909
02910
02911
02912
02913
02914 lrmin = 1.f;
02915 i__1 = 1 - lemin;
02916 for (i = 1; i <= 1-lemin; ++i) {
02917 r__1 = lrmin * rbase;
02918 lrmin = slamc3_(&r__1, &zero);
02919
02920 }
02921
02922
02923
02924 slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
02925 }
02926
02927 *beta = lbeta;
02928 *t = lt;
02929 *rnd = lrnd;
02930 *eps = leps;
02931 *emin = lemin;
02932 *rmin = lrmin;
02933 *emax = lemax;
02934 *rmax = lrmax;
02935
02936 return 0;
02937
02938
02939
02940
02941 }
02942
02943
02944
02945 doublereal slamc3_(real *a, real *b)
02946 {
02947
02948
02949
02950
02951
02952
02953
02954
02955
02956
02957
02958
02959
02960
02961
02962
02963
02964
02965
02966
02967
02968
02969
02970
02971
02972 real ret_val;
02973
02974
02975
02976 ret_val = *a + *b;
02977
02978 return ret_val;
02979
02980
02981
02982 }
02983
02984
02985
02986 int slamc4_(integer *emin, real *start, integer *base)
02987 {
02988
02989
02990
02991
02992
02993
02994
02995
02996
02997
02998
02999
03000
03001
03002
03003
03004
03005
03006
03007
03008
03009
03010
03011
03012
03013
03014
03015
03016
03017 integer i__1;
03018 real r__1;
03019
03020 static real zero, a;
03021 static integer i;
03022 static real rbase, b1, b2, c1, c2, d1, d2;
03023 extern doublereal slamc3_(real *, real *);
03024 static real one;
03025
03026
03027
03028 a = *start;
03029 one = 1.f;
03030 rbase = one / *base;
03031 zero = 0.f;
03032 *emin = 1;
03033 r__1 = a * rbase;
03034 b1 = slamc3_(&r__1, &zero);
03035 c1 = a;
03036 c2 = a;
03037 d1 = a;
03038 d2 = a;
03039
03040
03041 L10:
03042 if (c1 == a && c2 == a && d1 == a && d2 == a) {
03043 --(*emin);
03044 a = b1;
03045 r__1 = a / *base;
03046 b1 = slamc3_(&r__1, &zero);
03047 r__1 = b1 * *base;
03048 c1 = slamc3_(&r__1, &zero);
03049 d1 = zero;
03050 i__1 = *base;
03051 for (i = 1; i <= *base; ++i) {
03052 d1 += b1;
03053
03054 }
03055 r__1 = a * rbase;
03056 b2 = slamc3_(&r__1, &zero);
03057 r__1 = b2 / rbase;
03058 c2 = slamc3_(&r__1, &zero);
03059 d2 = zero;
03060 i__1 = *base;
03061 for (i = 1; i <= *base; ++i) {
03062 d2 += b2;
03063
03064 }
03065 goto L10;
03066 }
03067
03068
03069 return 0;
03070
03071
03072
03073 }
03074
03075
03076
03077 int slamc5_(integer *beta, integer *p, integer *emin,
03078 logical *ieee, integer *emax, real *rmax)
03079 {
03080
03081
03082
03083
03084
03085
03086
03087
03088
03089
03090
03091
03092
03093
03094
03095
03096
03097
03098
03099
03100
03101
03102
03103
03104
03105
03106
03107
03108
03109
03110
03111
03112
03113
03114
03115
03116
03117
03118
03119
03120
03121
03122
03123
03124
03125
03126
03127
03128
03129 static real c_b5 = 0.f;
03130
03131
03132 integer i__1;
03133 real r__1;
03134
03135 static integer lexp;
03136 static real oldy;
03137 static integer uexp, i;
03138 static real y, z;
03139 static integer nbits;
03140 extern doublereal slamc3_(real *, real *);
03141 static real recbas;
03142 static integer exbits, expsum, try__;
03143
03144
03145
03146 lexp = 1;
03147 exbits = 1;
03148 L10:
03149 try__ = lexp << 1;
03150 if (try__ <= -(*emin)) {
03151 lexp = try__;
03152 ++exbits;
03153 goto L10;
03154 }
03155 if (lexp == -(*emin)) {
03156 uexp = lexp;
03157 } else {
03158 uexp = try__;
03159 ++exbits;
03160 }
03161
03162
03163
03164
03165
03166 if (uexp + *emin > -lexp - *emin) {
03167 expsum = lexp << 1;
03168 } else {
03169 expsum = uexp << 1;
03170 }
03171
03172
03173
03174
03175 *emax = expsum + *emin - 1;
03176 nbits = exbits + 1 + *p;
03177
03178
03179
03180
03181 if (nbits % 2 == 1 && *beta == 2) {
03182
03183
03184
03185
03186
03187
03188
03189
03190
03191
03192
03193
03194
03195
03196
03197
03198
03199
03200 --(*emax);
03201 }
03202
03203 if (*ieee) {
03204
03205
03206
03207
03208
03209 --(*emax);
03210 }
03211
03212
03213
03214
03215
03216
03217
03218 recbas = 1.f / *beta;
03219 z = *beta - 1.f;
03220 y = 0.f;
03221 i__1 = *p;
03222 for (i = 1; i <= *p; ++i) {
03223 z *= recbas;
03224 if (y < 1.f) {
03225 oldy = y;
03226 }
03227 y = slamc3_(&y, &z);
03228
03229 }
03230 if (y >= 1.f) {
03231 y = oldy;
03232 }
03233
03234
03235
03236 i__1 = *emax;
03237 for (i = 1; i <= *emax; ++i) {
03238 r__1 = y * *beta;
03239 y = slamc3_(&r__1, &c_b5);
03240
03241 }
03242
03243 *rmax = y;
03244 return 0;
03245
03246
03247
03248 }
03249
03250
03251
03252
03253 doublereal slanst_(const char *norm, integer *n, real *d__, real *e)
03254 {
03255
03256
03257
03258
03259
03260
03261
03262
03263
03264
03265
03266
03267
03268
03269
03270
03271
03272
03273
03274
03275
03276
03277
03278
03279
03280
03281
03282
03283
03284
03285
03286
03287
03288
03289
03290
03291
03292
03293
03294
03295
03296
03297
03298
03299
03300
03301
03302
03303
03304
03305
03306
03307
03308 static integer c__1 = 1;
03309
03310
03311 integer i__1;
03312 real ret_val, r__1, r__2, r__3, r__4, r__5;
03313
03314
03315
03316 static integer i__;
03317 static real scale;
03318 extern logical lsame_(const char *, const char *);
03319 static real anorm;
03320 extern int slassq_(integer *, real *, integer *, real *,
03321 real *);
03322 static real sum;
03323
03324
03325 --e;
03326 --d__;
03327
03328
03329 if (*n <= 0) {
03330 anorm = 0.f;
03331 } else if (lsame_(norm, "M")) {
03332
03333
03334
03335 anorm = (r__1 = d__[*n], dabs(r__1));
03336 i__1 = *n - 1;
03337 for (i__ = 1; i__ <= i__1; ++i__) {
03338
03339 r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1));
03340 anorm = df2cmax(r__2,r__3);
03341
03342 r__2 = anorm, r__3 = (r__1 = e[i__], dabs(r__1));
03343 anorm = df2cmax(r__2,r__3);
03344
03345 }
03346 } else if (lsame_(norm, "O") || *(unsigned char *)
03347 norm == '1' || lsame_(norm, "I")) {
03348
03349
03350
03351 if (*n == 1) {
03352 anorm = dabs(d__[1]);
03353 } else {
03354
03355 r__3 = dabs(d__[1]) + dabs(e[1]), r__4 = (r__1 = e[*n - 1], dabs(
03356 r__1)) + (r__2 = d__[*n], dabs(r__2));
03357 anorm = df2cmax(r__3,r__4);
03358 i__1 = *n - 1;
03359 for (i__ = 2; i__ <= i__1; ++i__) {
03360
03361 r__4 = anorm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 =
03362 e[i__], dabs(r__2)) + (r__3 = e[i__ - 1], dabs(r__3));
03363 anorm = df2cmax(r__4,r__5);
03364
03365 }
03366 }
03367 } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
03368
03369
03370
03371 scale = 0.f;
03372 sum = 1.f;
03373 if (*n > 1) {
03374 i__1 = *n - 1;
03375 slassq_(&i__1, &e[1], &c__1, &scale, &sum);
03376 sum *= 2;
03377 }
03378 slassq_(n, &d__[1], &c__1, &scale, &sum);
03379 anorm = scale * sqrt(sum);
03380 }
03381
03382 ret_val = anorm;
03383 return ret_val;
03384
03385
03386
03387 }
03388
03389
03390
03391
03392 doublereal slansy_(const char *norm, char *uplo, integer *n, real *a, integer *lda,
03393 real *work)
03394 {
03395
03396
03397
03398
03399
03400
03401
03402
03403
03404
03405
03406
03407
03408
03409
03410
03411
03412
03413
03414
03415
03416
03417
03418
03419
03420
03421
03422
03423
03424
03425
03426
03427
03428
03429
03430
03431
03432
03433
03434
03435
03436
03437
03438
03439
03440
03441
03442
03443
03444
03445
03446
03447
03448
03449
03450
03451
03452
03453
03454
03455
03456
03457
03458
03459
03460
03461
03462
03463
03464 static integer c__1 = 1;
03465
03466
03467 integer a_dim1, a_offset, i__1, i__2;
03468 real ret_val, r__1, r__2, r__3;
03469
03470
03471
03472 static real absa;
03473 static integer i__, j;
03474 static real scale;
03475 extern logical lsame_(const char *, const char *);
03476 static real value;
03477 extern int slassq_(integer *, real *, integer *, real *,
03478 real *);
03479 static real sum;
03480 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
03481
03482
03483 a_dim1 = *lda;
03484 a_offset = 1 + a_dim1 * 1;
03485 a -= a_offset;
03486 --work;
03487
03488
03489 if (*n == 0) {
03490 value = 0.f;
03491 } else if (lsame_(norm, "M")) {
03492
03493
03494
03495 value = 0.f;
03496 if (lsame_(uplo, "U")) {
03497 i__1 = *n;
03498 for (j = 1; j <= i__1; ++j) {
03499 i__2 = j;
03500 for (i__ = 1; i__ <= i__2; ++i__) {
03501
03502 r__2 = value, r__3 = (r__1 = a_ref(i__, j), dabs(r__1));
03503 value = df2cmax(r__2,r__3);
03504
03505 }
03506
03507 }
03508 } else {
03509 i__1 = *n;
03510 for (j = 1; j <= i__1; ++j) {
03511 i__2 = *n;
03512 for (i__ = j; i__ <= i__2; ++i__) {
03513
03514 r__2 = value, r__3 = (r__1 = a_ref(i__, j), dabs(r__1));
03515 value = df2cmax(r__2,r__3);
03516
03517 }
03518
03519 }
03520 }
03521 } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
03522
03523
03524
03525 value = 0.f;
03526 if (lsame_(uplo, "U")) {
03527 i__1 = *n;
03528 for (j = 1; j <= i__1; ++j) {
03529 sum = 0.f;
03530 i__2 = j - 1;
03531 for (i__ = 1; i__ <= i__2; ++i__) {
03532 absa = (r__1 = a_ref(i__, j), dabs(r__1));
03533 sum += absa;
03534 work[i__] += absa;
03535
03536 }
03537 work[j] = sum + (r__1 = a_ref(j, j), dabs(r__1));
03538
03539 }
03540 i__1 = *n;
03541 for (i__ = 1; i__ <= i__1; ++i__) {
03542
03543 r__1 = value, r__2 = work[i__];
03544 value = df2cmax(r__1,r__2);
03545
03546 }
03547 } else {
03548 i__1 = *n;
03549 for (i__ = 1; i__ <= i__1; ++i__) {
03550 work[i__] = 0.f;
03551
03552 }
03553 i__1 = *n;
03554 for (j = 1; j <= i__1; ++j) {
03555 sum = work[j] + (r__1 = a_ref(j, j), dabs(r__1));
03556 i__2 = *n;
03557 for (i__ = j + 1; i__ <= i__2; ++i__) {
03558 absa = (r__1 = a_ref(i__, j), dabs(r__1));
03559 sum += absa;
03560 work[i__] += absa;
03561
03562 }
03563 value = df2cmax(value,sum);
03564
03565 }
03566 }
03567 } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
03568
03569
03570
03571 scale = 0.f;
03572 sum = 1.f;
03573 if (lsame_(uplo, "U")) {
03574 i__1 = *n;
03575 for (j = 2; j <= i__1; ++j) {
03576 i__2 = j - 1;
03577 slassq_(&i__2, &a_ref(1, j), &c__1, &scale, &sum);
03578
03579 }
03580 } else {
03581 i__1 = *n - 1;
03582 for (j = 1; j <= i__1; ++j) {
03583 i__2 = *n - j;
03584 slassq_(&i__2, &a_ref(j + 1, j), &c__1, &scale, &sum);
03585
03586 }
03587 }
03588 sum *= 2;
03589 i__1 = *lda + 1;
03590 slassq_(n, &a[a_offset], &i__1, &scale, &sum);
03591 value = scale * sqrt(sum);
03592 }
03593
03594 ret_val = value;
03595 return ret_val;
03596
03597
03598
03599 }
03600
03601 #undef a_ref
03602
03603
03604
03605
03606
03607 doublereal slapy2_(real *x, real *y)
03608 {
03609
03610
03611
03612
03613
03614
03615
03616
03617
03618
03619
03620
03621
03622
03623
03624
03625
03626
03627
03628
03629
03630 real ret_val, r__1;
03631
03632
03633
03634 static real xabs, yabs, w, z__;
03635
03636
03637
03638 xabs = dabs(*x);
03639 yabs = dabs(*y);
03640 w = df2cmax(xabs,yabs);
03641 z__ = df2cmin(xabs,yabs);
03642 if (z__ == 0.f) {
03643 ret_val = w;
03644 } else {
03645
03646 r__1 = z__ / w;
03647 ret_val = w * sqrt(r__1 * r__1 + 1.f);
03648 }
03649 return ret_val;
03650
03651
03652
03653 }
03654
03655
03656
03657
03658 int slarfb_(const char *side, const char *trans, const char *direct, const char *
03659 storev, integer *m, integer *n, integer *k, real *v, integer *ldv,
03660 real *t, integer *ldt, real *c__, integer *ldc, real *work, integer *
03661 ldwork)
03662 {
03663
03664
03665
03666
03667
03668
03669
03670
03671
03672
03673
03674
03675
03676
03677
03678
03679
03680
03681
03682
03683
03684
03685
03686
03687
03688
03689
03690
03691
03692
03693
03694
03695
03696
03697
03698
03699
03700
03701
03702
03703
03704
03705
03706
03707
03708
03709
03710
03711
03712
03713
03714
03715
03716
03717
03718
03719
03720
03721
03722
03723
03724
03725
03726
03727
03728
03729
03730
03731
03732
03733
03734
03735
03736
03737
03738
03739
03740
03741
03742
03743
03744
03745
03746
03747
03748 static integer c__1 = 1;
03749 static real c_b14 = 1.f;
03750 static real c_b25 = -1.f;
03751
03752
03753 integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
03754 work_offset, i__1, i__2;
03755
03756 static integer i__, j;
03757 extern logical lsame_(const char *, const char *);
03758 extern int sgemm_(const char *, const char *, integer *, integer *,
03759 integer *, real *, real *, integer *, real *, integer *, real *,
03760 real *, integer *), scopy_(integer *, real *,
03761 integer *, real *, integer *), strmm_(const char *, const char *, const char *,
03762 const char *, integer *, integer *, real *, real *, integer *, real *,
03763 integer *);
03764 static char transt[1];
03765 #define work_ref(a_1,a_2) work[(a_2)*work_dim1 + a_1]
03766 #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
03767 #define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1]
03768
03769
03770 v_dim1 = *ldv;
03771 v_offset = 1 + v_dim1 * 1;
03772 v -= v_offset;
03773 t_dim1 = *ldt;
03774 t_offset = 1 + t_dim1 * 1;
03775 t -= t_offset;
03776 c_dim1 = *ldc;
03777 c_offset = 1 + c_dim1 * 1;
03778 c__ -= c_offset;
03779 work_dim1 = *ldwork;
03780 work_offset = 1 + work_dim1 * 1;
03781 work -= work_offset;
03782
03783
03784 if (*m <= 0 || *n <= 0) {
03785 return 0;
03786 }
03787
03788 if (lsame_(trans, "N")) {
03789 *(unsigned char *)transt = 'T';
03790 } else {
03791 *(unsigned char *)transt = 'N';
03792 }
03793
03794 if (lsame_(storev, "C")) {
03795
03796 if (lsame_(direct, "F")) {
03797
03798
03799
03800
03801
03802 if (lsame_(side, "L")) {
03803
03804
03805
03806
03807
03808
03809
03810
03811 i__1 = *k;
03812 for (j = 1; j <= i__1; ++j) {
03813 scopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1);
03814
03815 }
03816
03817
03818
03819 strmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14,
03820 &v[v_offset], ldv, &work[work_offset], ldwork);
03821 if (*m > *k) {
03822
03823
03824
03825 i__1 = *m - *k;
03826 sgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, &
03827 c___ref(*k + 1, 1), ldc, &v_ref(*k + 1, 1), ldv, &
03828 c_b14, &work[work_offset], ldwork);
03829 }
03830
03831
03832
03833 strmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[
03834 t_offset], ldt, &work[work_offset], ldwork);
03835
03836
03837
03838 if (*m > *k) {
03839
03840
03841
03842 i__1 = *m - *k;
03843 sgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, &
03844 v_ref(*k + 1, 1), ldv, &work[work_offset], ldwork,
03845 &c_b14, &c___ref(*k + 1, 1), ldc);
03846 }
03847
03848
03849
03850 strmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, &
03851 v[v_offset], ldv, &work[work_offset], ldwork);
03852
03853
03854
03855 i__1 = *k;
03856 for (j = 1; j <= i__1; ++j) {
03857 i__2 = *n;
03858 for (i__ = 1; i__ <= i__2; ++i__) {
03859 c___ref(j, i__) = c___ref(j, i__) - work_ref(i__, j);
03860
03861 }
03862
03863 }
03864
03865 } else if (lsame_(side, "R")) {
03866
03867
03868
03869
03870
03871
03872
03873 i__1 = *k;
03874 for (j = 1; j <= i__1; ++j) {
03875 scopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1);
03876
03877 }
03878
03879
03880
03881 strmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14,
03882 &v[v_offset], ldv, &work[work_offset], ldwork);
03883 if (*n > *k) {
03884
03885
03886
03887 i__1 = *n - *k;
03888 sgemm_("No transpose", "No transpose", m, k, &i__1, &
03889 c_b14, &c___ref(1, *k + 1), ldc, &v_ref(*k + 1, 1)
03890 , ldv, &c_b14, &work[work_offset], ldwork);
03891 }
03892
03893
03894
03895 strmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[
03896 t_offset], ldt, &work[work_offset], ldwork);
03897
03898
03899
03900 if (*n > *k) {
03901
03902
03903
03904 i__1 = *n - *k;
03905 sgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, &
03906 work[work_offset], ldwork, &v_ref(*k + 1, 1), ldv,
03907 &c_b14, &c___ref(1, *k + 1), ldc);
03908 }
03909
03910
03911
03912 strmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, &
03913 v[v_offset], ldv, &work[work_offset], ldwork);
03914
03915
03916
03917 i__1 = *k;
03918 for (j = 1; j <= i__1; ++j) {
03919 i__2 = *m;
03920 for (i__ = 1; i__ <= i__2; ++i__) {
03921 c___ref(i__, j) = c___ref(i__, j) - work_ref(i__, j);
03922
03923 }
03924
03925 }
03926 }
03927
03928 } else {
03929
03930
03931
03932
03933
03934 if (lsame_(side, "L")) {
03935
03936
03937
03938
03939
03940
03941
03942
03943 i__1 = *k;
03944 for (j = 1; j <= i__1; ++j) {
03945 scopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j),
03946 &c__1);
03947
03948 }
03949
03950
03951
03952 strmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14,
03953 &v_ref(*m - *k + 1, 1), ldv, &work[work_offset],
03954 ldwork);
03955 if (*m > *k) {
03956
03957
03958
03959 i__1 = *m - *k;
03960 sgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, &
03961 c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
03962 work[work_offset], ldwork);
03963 }
03964
03965
03966
03967 strmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[
03968 t_offset], ldt, &work[work_offset], ldwork);
03969
03970
03971
03972 if (*m > *k) {
03973
03974
03975
03976 i__1 = *m - *k;
03977 sgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, &
03978 v[v_offset], ldv, &work[work_offset], ldwork, &
03979 c_b14, &c__[c_offset], ldc)
03980 ;
03981 }
03982
03983
03984
03985 strmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, &
03986 v_ref(*m - *k + 1, 1), ldv, &work[work_offset],
03987 ldwork);
03988
03989
03990
03991 i__1 = *k;
03992 for (j = 1; j <= i__1; ++j) {
03993 i__2 = *n;
03994 for (i__ = 1; i__ <= i__2; ++i__) {
03995 c___ref(*m - *k + j, i__) = c___ref(*m - *k + j, i__)
03996 - work_ref(i__, j);
03997
03998 }
03999
04000 }
04001
04002 } else if (lsame_(side, "R")) {
04003
04004
04005
04006
04007
04008
04009
04010 i__1 = *k;
04011 for (j = 1; j <= i__1; ++j) {
04012 scopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j)
04013 , &c__1);
04014
04015 }
04016
04017
04018
04019 strmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14,
04020 &v_ref(*n - *k + 1, 1), ldv, &work[work_offset],
04021 ldwork);
04022 if (*n > *k) {
04023
04024
04025
04026 i__1 = *n - *k;
04027 sgemm_("No transpose", "No transpose", m, k, &i__1, &
04028 c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
04029 c_b14, &work[work_offset], ldwork);
04030 }
04031
04032
04033
04034 strmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[
04035 t_offset], ldt, &work[work_offset], ldwork);
04036
04037
04038
04039 if (*n > *k) {
04040
04041
04042
04043 i__1 = *n - *k;
04044 sgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, &
04045 work[work_offset], ldwork, &v[v_offset], ldv, &
04046 c_b14, &c__[c_offset], ldc)
04047 ;
04048 }
04049
04050
04051
04052 strmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, &
04053 v_ref(*n - *k + 1, 1), ldv, &work[work_offset],
04054 ldwork);
04055
04056
04057
04058 i__1 = *k;
04059 for (j = 1; j <= i__1; ++j) {
04060 i__2 = *m;
04061 for (i__ = 1; i__ <= i__2; ++i__) {
04062 c___ref(i__, *n - *k + j) = c___ref(i__, *n - *k + j)
04063 - work_ref(i__, j);
04064
04065 }
04066
04067 }
04068 }
04069 }
04070
04071 } else if (lsame_(storev, "R")) {
04072
04073 if (lsame_(direct, "F")) {
04074
04075
04076
04077
04078 if (lsame_(side, "L")) {
04079
04080
04081
04082
04083
04084
04085
04086
04087 i__1 = *k;
04088 for (j = 1; j <= i__1; ++j) {
04089 scopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1);
04090
04091 }
04092
04093
04094
04095 strmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, &
04096 v[v_offset], ldv, &work[work_offset], ldwork);
04097 if (*m > *k) {
04098
04099
04100
04101 i__1 = *m - *k;
04102 sgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, &
04103 c___ref(*k + 1, 1), ldc, &v_ref(1, *k + 1), ldv, &
04104 c_b14, &work[work_offset], ldwork);
04105 }
04106
04107
04108
04109 strmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[
04110 t_offset], ldt, &work[work_offset], ldwork);
04111
04112
04113
04114 if (*m > *k) {
04115
04116
04117
04118 i__1 = *m - *k;
04119 sgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &
04120 v_ref(1, *k + 1), ldv, &work[work_offset], ldwork,
04121 &c_b14, &c___ref(*k + 1, 1), ldc);
04122 }
04123
04124
04125
04126 strmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14,
04127 &v[v_offset], ldv, &work[work_offset], ldwork);
04128
04129
04130
04131 i__1 = *k;
04132 for (j = 1; j <= i__1; ++j) {
04133 i__2 = *n;
04134 for (i__ = 1; i__ <= i__2; ++i__) {
04135 c___ref(j, i__) = c___ref(j, i__) - work_ref(i__, j);
04136
04137 }
04138
04139 }
04140
04141 } else if (lsame_(side, "R")) {
04142
04143
04144
04145
04146
04147
04148
04149 i__1 = *k;
04150 for (j = 1; j <= i__1; ++j) {
04151 scopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1);
04152
04153 }
04154
04155
04156
04157 strmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, &
04158 v[v_offset], ldv, &work[work_offset], ldwork);
04159 if (*n > *k) {
04160
04161
04162
04163 i__1 = *n - *k;
04164 sgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, &
04165 c___ref(1, *k + 1), ldc, &v_ref(1, *k + 1), ldv, &
04166 c_b14, &work[work_offset], ldwork);
04167 }
04168
04169
04170
04171 strmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[
04172 t_offset], ldt, &work[work_offset], ldwork);
04173
04174
04175
04176 if (*n > *k) {
04177
04178
04179
04180 i__1 = *n - *k;
04181 sgemm_("No transpose", "No transpose", m, &i__1, k, &
04182 c_b25, &work[work_offset], ldwork, &v_ref(1, *k +
04183 1), ldv, &c_b14, &c___ref(1, *k + 1), ldc);
04184 }
04185
04186
04187
04188 strmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14,
04189 &v[v_offset], ldv, &work[work_offset], ldwork);
04190
04191
04192
04193 i__1 = *k;
04194 for (j = 1; j <= i__1; ++j) {
04195 i__2 = *m;
04196 for (i__ = 1; i__ <= i__2; ++i__) {
04197 c___ref(i__, j) = c___ref(i__, j) - work_ref(i__, j);
04198
04199 }
04200
04201 }
04202
04203 }
04204
04205 } else {
04206
04207
04208
04209
04210 if (lsame_(side, "L")) {
04211
04212
04213
04214
04215
04216
04217
04218
04219 i__1 = *k;
04220 for (j = 1; j <= i__1; ++j) {
04221 scopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j),
04222 &c__1);
04223
04224 }
04225
04226
04227
04228 strmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, &
04229 v_ref(1, *m - *k + 1), ldv, &work[work_offset],
04230 ldwork);
04231 if (*m > *k) {
04232
04233
04234
04235 i__1 = *m - *k;
04236 sgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, &
04237 c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
04238 work[work_offset], ldwork);
04239 }
04240
04241
04242
04243 strmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[
04244 t_offset], ldt, &work[work_offset], ldwork);
04245
04246
04247
04248 if (*m > *k) {
04249
04250
04251
04252 i__1 = *m - *k;
04253 sgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &v[
04254 v_offset], ldv, &work[work_offset], ldwork, &
04255 c_b14, &c__[c_offset], ldc);
04256 }
04257
04258
04259
04260 strmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14,
04261 &v_ref(1, *m - *k + 1), ldv, &work[work_offset],
04262 ldwork);
04263
04264
04265
04266 i__1 = *k;
04267 for (j = 1; j <= i__1; ++j) {
04268 i__2 = *n;
04269 for (i__ = 1; i__ <= i__2; ++i__) {
04270 c___ref(*m - *k + j, i__) = c___ref(*m - *k + j, i__)
04271 - work_ref(i__, j);
04272
04273 }
04274
04275 }
04276
04277 } else if (lsame_(side, "R")) {
04278
04279
04280
04281
04282
04283
04284
04285 i__1 = *k;
04286 for (j = 1; j <= i__1; ++j) {
04287 scopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j)
04288 , &c__1);
04289
04290 }
04291
04292
04293
04294 strmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, &
04295 v_ref(1, *n - *k + 1), ldv, &work[work_offset],
04296 ldwork);
04297 if (*n > *k) {
04298
04299
04300
04301 i__1 = *n - *k;
04302 sgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, &
04303 c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
04304 work[work_offset], ldwork);
04305 }
04306
04307
04308
04309 strmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[
04310 t_offset], ldt, &work[work_offset], ldwork);
04311
04312
04313
04314 if (*n > *k) {
04315
04316
04317
04318 i__1 = *n - *k;
04319 sgemm_("No transpose", "No transpose", m, &i__1, k, &
04320 c_b25, &work[work_offset], ldwork, &v[v_offset],
04321 ldv, &c_b14, &c__[c_offset], ldc);
04322 }
04323
04324
04325
04326 strmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14,
04327 &v_ref(1, *n - *k + 1), ldv, &work[work_offset],
04328 ldwork);
04329
04330
04331
04332 i__1 = *k;
04333 for (j = 1; j <= i__1; ++j) {
04334 i__2 = *m;
04335 for (i__ = 1; i__ <= i__2; ++i__) {
04336 c___ref(i__, *n - *k + j) = c___ref(i__, *n - *k + j)
04337 - work_ref(i__, j);
04338
04339 }
04340
04341 }
04342
04343 }
04344
04345 }
04346 }
04347
04348 return 0;
04349
04350
04351
04352 }
04353
04354 #undef v_ref
04355 #undef c___ref
04356 #undef work_ref
04357
04358
04359
04360
04361
04362 int slarf_(const char *side, integer *m, integer *n, real *v,
04363 integer *incv, real *tau, real *c__, integer *ldc, real *work)
04364 {
04365
04366
04367
04368
04369
04370
04371
04372
04373
04374
04375
04376
04377
04378
04379
04380
04381
04382
04383
04384
04385
04386
04387
04388
04389
04390
04391
04392
04393
04394
04395
04396
04397
04398
04399
04400
04401
04402
04403
04404
04405
04406
04407
04408
04409
04410
04411
04412
04413
04414
04415
04416
04417
04418
04419
04420
04421
04422
04423
04424
04425 static real c_b4 = 1.f;
04426 static real c_b5 = 0.f;
04427 static integer c__1 = 1;
04428
04429
04430 integer c_dim1, c_offset;
04431 real r__1;
04432
04433 extern int sger_(integer *, integer *, real *, real *,
04434 integer *, real *, integer *, real *, integer *);
04435 extern logical lsame_(const char *, const char *);
04436 extern int sgemv_(const char *, integer *, integer *, real *,
04437 real *, integer *, real *, integer *, real *, real *, integer *);
04438
04439
04440 --v;
04441 c_dim1 = *ldc;
04442 c_offset = 1 + c_dim1 * 1;
04443 c__ -= c_offset;
04444 --work;
04445
04446
04447 if (lsame_(side, "L")) {
04448
04449
04450
04451 if (*tau != 0.f) {
04452
04453
04454
04455 sgemv_("Transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1], incv,
04456 &c_b5, &work[1], &c__1);
04457
04458
04459
04460 r__1 = -(*tau);
04461 sger_(m, n, &r__1, &v[1], incv, &work[1], &c__1, &c__[c_offset],
04462 ldc);
04463 }
04464 } else {
04465
04466
04467
04468 if (*tau != 0.f) {
04469
04470
04471
04472 sgemv_("No transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1],
04473 incv, &c_b5, &work[1], &c__1);
04474
04475
04476
04477 r__1 = -(*tau);
04478 sger_(m, n, &r__1, &work[1], &c__1, &v[1], incv, &c__[c_offset],
04479 ldc);
04480 }
04481 }
04482 return 0;
04483
04484
04485
04486 }
04487
04488
04489
04490
04491 int slarfg_(integer *n, real *alpha, real *x, integer *incx,
04492 real *tau)
04493 {
04494
04495
04496
04497
04498
04499
04500
04501
04502
04503
04504
04505
04506
04507
04508
04509
04510
04511
04512
04513
04514
04515
04516
04517
04518
04519
04520
04521
04522
04523
04524
04525
04526
04527
04528
04529
04530
04531
04532
04533
04534
04535
04536
04537
04538
04539
04540
04541
04542
04543
04544
04545
04546
04547
04548
04549 integer i__1;
04550 real r__1;
04551
04552 double r_sign(real *, real *);
04553
04554 static real beta;
04555 extern doublereal snrm2_(integer *, real *, integer *);
04556 static integer j;
04557 extern int sscal_(integer *, real *, real *, integer *);
04558 static real xnorm;
04559 extern doublereal slapy2_(real *, real *), slamch_(const char *);
04560 static real safmin, rsafmn;
04561 static integer knt;
04562
04563 --x;
04564
04565
04566 if (*n <= 1) {
04567 *tau = 0.f;
04568 return 0;
04569 }
04570
04571 i__1 = *n - 1;
04572 xnorm = snrm2_(&i__1, &x[1], incx);
04573
04574 if (xnorm == 0.f) {
04575
04576
04577
04578 *tau = 0.f;
04579 } else {
04580
04581
04582
04583 r__1 = slapy2_(alpha, &xnorm);
04584 beta = -r_sign(&r__1, alpha);
04585 safmin = slamch_("S") / slamch_("E");
04586 if (dabs(beta) < safmin) {
04587
04588
04589
04590 rsafmn = 1.f / safmin;
04591 knt = 0;
04592 L10:
04593 ++knt;
04594 i__1 = *n - 1;
04595 sscal_(&i__1, &rsafmn, &x[1], incx);
04596 beta *= rsafmn;
04597 *alpha *= rsafmn;
04598 if (dabs(beta) < safmin) {
04599 goto L10;
04600 }
04601
04602
04603
04604 i__1 = *n - 1;
04605 xnorm = snrm2_(&i__1, &x[1], incx);
04606 r__1 = slapy2_(alpha, &xnorm);
04607 beta = -r_sign(&r__1, alpha);
04608 *tau = (beta - *alpha) / beta;
04609 i__1 = *n - 1;
04610 r__1 = 1.f / (*alpha - beta);
04611 sscal_(&i__1, &r__1, &x[1], incx);
04612
04613
04614
04615 *alpha = beta;
04616 i__1 = knt;
04617 for (j = 1; j <= i__1; ++j) {
04618 *alpha *= safmin;
04619
04620 }
04621 } else {
04622 *tau = (beta - *alpha) / beta;
04623 i__1 = *n - 1;
04624 r__1 = 1.f / (*alpha - beta);
04625 sscal_(&i__1, &r__1, &x[1], incx);
04626 *alpha = beta;
04627 }
04628 }
04629
04630 return 0;
04631
04632
04633
04634 }
04635
04636
04637
04638
04639 int slarft_(const char *direct, const char *storev, integer *n, integer *
04640 k, real *v, integer *ldv, real *tau, real *t, integer *ldt)
04641 {
04642
04643
04644
04645
04646
04647
04648
04649
04650
04651
04652
04653
04654
04655
04656
04657
04658
04659
04660
04661
04662
04663
04664
04665
04666
04667
04668
04669
04670
04671
04672
04673
04674
04675
04676
04677
04678
04679
04680
04681
04682
04683
04684
04685
04686
04687
04688
04689
04690
04691
04692
04693
04694
04695
04696
04697
04698
04699
04700
04701
04702
04703
04704
04705
04706
04707
04708
04709
04710
04711
04712
04713
04714
04715
04716
04717
04718
04719
04720
04721
04722
04723
04724
04725
04726
04727
04728
04729
04730
04731
04732
04733
04734
04735
04736
04737
04738
04739
04740
04741
04742
04743 static integer c__1 = 1;
04744 static real c_b8 = 0.f;
04745
04746
04747 integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
04748 real r__1;
04749
04750 static integer i__, j;
04751 extern logical lsame_(const char *, const char *);
04752 extern int sgemv_(const char *, integer *, integer *, real *,
04753 real *, integer *, real *, integer *, real *, real *, integer *), strmv_(const char *, const char *, const char *, integer *, real *,
04754 integer *, real *, integer *);
04755 static real vii;
04756 #define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
04757 #define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1]
04758
04759
04760 v_dim1 = *ldv;
04761 v_offset = 1 + v_dim1 * 1;
04762 v -= v_offset;
04763 --tau;
04764 t_dim1 = *ldt;
04765 t_offset = 1 + t_dim1 * 1;
04766 t -= t_offset;
04767
04768
04769 if (*n == 0) {
04770 return 0;
04771 }
04772
04773 if (lsame_(direct, "F")) {
04774 i__1 = *k;
04775 for (i__ = 1; i__ <= i__1; ++i__) {
04776 if (tau[i__] == 0.f) {
04777
04778
04779
04780 i__2 = i__;
04781 for (j = 1; j <= i__2; ++j) {
04782 t_ref(j, i__) = 0.f;
04783
04784 }
04785 } else {
04786
04787
04788
04789 vii = v_ref(i__, i__);
04790 v_ref(i__, i__) = 1.f;
04791 if (lsame_(storev, "C")) {
04792
04793
04794
04795 i__2 = *n - i__ + 1;
04796 i__3 = i__ - 1;
04797 r__1 = -tau[i__];
04798 sgemv_("Transpose", &i__2, &i__3, &r__1, &v_ref(i__, 1),
04799 ldv, &v_ref(i__, i__), &c__1, &c_b8, &t_ref(1,
04800 i__), &c__1);
04801 } else {
04802
04803
04804
04805 i__2 = i__ - 1;
04806 i__3 = *n - i__ + 1;
04807 r__1 = -tau[i__];
04808 sgemv_("No transpose", &i__2, &i__3, &r__1, &v_ref(1, i__)
04809 , ldv, &v_ref(i__, i__), ldv, &c_b8, &t_ref(1,
04810 i__), &c__1);
04811 }
04812 v_ref(i__, i__) = vii;
04813
04814
04815
04816 i__2 = i__ - 1;
04817 strmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
04818 t_offset], ldt, &t_ref(1, i__), &c__1);
04819 t_ref(i__, i__) = tau[i__];
04820 }
04821
04822 }
04823 } else {
04824 for (i__ = *k; i__ >= 1; --i__) {
04825 if (tau[i__] == 0.f) {
04826
04827
04828
04829 i__1 = *k;
04830 for (j = i__; j <= i__1; ++j) {
04831 t_ref(j, i__) = 0.f;
04832
04833 }
04834 } else {
04835
04836
04837
04838 if (i__ < *k) {
04839 if (lsame_(storev, "C")) {
04840 vii = v_ref(*n - *k + i__, i__);
04841 v_ref(*n - *k + i__, i__) = 1.f;
04842
04843
04844
04845
04846 i__1 = *n - *k + i__;
04847 i__2 = *k - i__;
04848 r__1 = -tau[i__];
04849 sgemv_("Transpose", &i__1, &i__2, &r__1, &v_ref(1,
04850 i__ + 1), ldv, &v_ref(1, i__), &c__1, &c_b8, &
04851 t_ref(i__ + 1, i__), &c__1);
04852 v_ref(*n - *k + i__, i__) = vii;
04853 } else {
04854 vii = v_ref(i__, *n - *k + i__);
04855 v_ref(i__, *n - *k + i__) = 1.f;
04856
04857
04858
04859
04860 i__1 = *k - i__;
04861 i__2 = *n - *k + i__;
04862 r__1 = -tau[i__];
04863 sgemv_("No transpose", &i__1, &i__2, &r__1, &v_ref(
04864 i__ + 1, 1), ldv, &v_ref(i__, 1), ldv, &c_b8,
04865 &t_ref(i__ + 1, i__), &c__1);
04866 v_ref(i__, *n - *k + i__) = vii;
04867 }
04868
04869
04870
04871 i__1 = *k - i__;
04872 strmv_("Lower", "No transpose", "Non-unit", &i__1, &t_ref(
04873 i__ + 1, i__ + 1), ldt, &t_ref(i__ + 1, i__), &
04874 c__1);
04875 }
04876 t_ref(i__, i__) = tau[i__];
04877 }
04878
04879 }
04880 }
04881 return 0;
04882
04883
04884
04885 }
04886
04887 #undef v_ref
04888 #undef t_ref
04889
04890
04891
04892
04893
04894 int slartg_(real *f, real *g, real *cs, real *sn, real *r__)
04895 {
04896
04897
04898
04899
04900
04901
04902
04903
04904
04905
04906
04907
04908
04909
04910
04911
04912
04913
04914
04915
04916
04917
04918
04919
04920
04921
04922
04923
04924
04925
04926
04927
04928
04929
04930
04931
04932
04933
04934
04935
04936
04937
04938
04939
04940 static logical first = TRUE_;
04941
04942 integer i__1;
04943 real r__1, r__2;
04944
04945
04946 double pow_ri(real *, integer *);
04947
04948 static integer i__;
04949 static real scale;
04950 static integer count;
04951 static real f1, g1, safmn2, safmx2;
04952 extern doublereal slamch_(const char *);
04953 static real safmin, eps;
04954
04955
04956
04957 if (first) {
04958 first = FALSE_;
04959 safmin = slamch_("S");
04960 eps = slamch_("E");
04961 r__1 = slamch_("B");
04962 i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) /
04963 2.f);
04964 safmn2 = pow_ri(&r__1, &i__1);
04965 safmx2 = 1.f / safmn2;
04966 }
04967 if (*g == 0.f) {
04968 *cs = 1.f;
04969 *sn = 0.f;
04970 *r__ = *f;
04971 } else if (*f == 0.f) {
04972 *cs = 0.f;
04973 *sn = 1.f;
04974 *r__ = *g;
04975 } else {
04976 f1 = *f;
04977 g1 = *g;
04978
04979 r__1 = dabs(f1), r__2 = dabs(g1);
04980 scale = df2cmax(r__1,r__2);
04981 if (scale >= safmx2) {
04982 count = 0;
04983 L10:
04984 ++count;
04985 f1 *= safmn2;
04986 g1 *= safmn2;
04987
04988 r__1 = dabs(f1), r__2 = dabs(g1);
04989 scale = df2cmax(r__1,r__2);
04990 if (scale >= safmx2) {
04991 goto L10;
04992 }
04993
04994 r__1 = f1;
04995
04996 r__2 = g1;
04997 *r__ = sqrt(r__1 * r__1 + r__2 * r__2);
04998 *cs = f1 / *r__;
04999 *sn = g1 / *r__;
05000 i__1 = count;
05001 for (i__ = 1; i__ <= i__1; ++i__) {
05002 *r__ *= safmx2;
05003
05004 }
05005 } else if (scale <= safmn2) {
05006 count = 0;
05007 L30:
05008 ++count;
05009 f1 *= safmx2;
05010 g1 *= safmx2;
05011
05012 r__1 = dabs(f1), r__2 = dabs(g1);
05013 scale = df2cmax(r__1,r__2);
05014 if (scale <= safmn2) {
05015 goto L30;
05016 }
05017
05018 r__1 = f1;
05019
05020 r__2 = g1;
05021 *r__ = sqrt(r__1 * r__1 + r__2 * r__2);
05022 *cs = f1 / *r__;
05023 *sn = g1 / *r__;
05024 i__1 = count;
05025 for (i__ = 1; i__ <= i__1; ++i__) {
05026 *r__ *= safmn2;
05027
05028 }
05029 } else {
05030
05031 r__1 = f1;
05032
05033 r__2 = g1;
05034 *r__ = sqrt(r__1 * r__1 + r__2 * r__2);
05035 *cs = f1 / *r__;
05036 *sn = g1 / *r__;
05037 }
05038 if (dabs(*f) > dabs(*g) && *cs < 0.f) {
05039 *cs = -(*cs);
05040 *sn = -(*sn);
05041 *r__ = -(*r__);
05042 }
05043 }
05044 return 0;
05045
05046
05047
05048 }
05049
05050
05051
05052
05053 int slascl_(const char *type__, integer *kl, integer *ku, real *
05054 cfrom, real *cto, integer *m, integer *n, real *a, integer *lda,
05055 integer *info)
05056 {
05057
05058
05059
05060
05061
05062
05063
05064
05065
05066
05067
05068
05069
05070
05071
05072
05073
05074
05075
05076
05077
05078
05079
05080
05081
05082
05083
05084
05085
05086
05087
05088
05089
05090
05091
05092
05093
05094
05095
05096
05097
05098
05099
05100
05101
05102
05103
05104
05105
05106
05107
05108
05109
05110
05111
05112
05113
05114
05115
05116
05117
05118
05119
05120
05121
05122
05123
05124
05125
05126
05127
05128
05129 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
05130
05131 static logical done;
05132 static real ctoc;
05133 static integer i__, j;
05134 extern logical lsame_(const char *, const char *);
05135 static integer itype, k1, k2, k3, k4;
05136 static real cfrom1;
05137 extern doublereal slamch_(const char *);
05138 static real cfromc;
05139 extern int xerbla_(const char *, integer *);
05140 static real bignum, smlnum, mul, cto1;
05141 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
05142
05143 a_dim1 = *lda;
05144 a_offset = 1 + a_dim1 * 1;
05145 a -= a_offset;
05146
05147
05148 *info = 0;
05149
05150 if (lsame_(type__, "G")) {
05151 itype = 0;
05152 } else if (lsame_(type__, "L")) {
05153 itype = 1;
05154 } else if (lsame_(type__, "U")) {
05155 itype = 2;
05156 } else if (lsame_(type__, "H")) {
05157 itype = 3;
05158 } else if (lsame_(type__, "B")) {
05159 itype = 4;
05160 } else if (lsame_(type__, "Q")) {
05161 itype = 5;
05162 } else if (lsame_(type__, "Z")) {
05163 itype = 6;
05164 } else {
05165 itype = -1;
05166 }
05167
05168 if (itype == -1) {
05169 *info = -1;
05170 } else if (*cfrom == 0.f) {
05171 *info = -4;
05172 } else if (*m < 0) {
05173 *info = -6;
05174 } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
05175 *info = -7;
05176 } else if (itype <= 3 && *lda < f2cmax(1,*m)) {
05177 *info = -9;
05178 } else if (itype >= 4) {
05179
05180 i__1 = *m - 1;
05181 if (*kl < 0 || *kl > f2cmax(i__1,0)) {
05182 *info = -2;
05183 } else {
05184
05185 i__1 = *n - 1;
05186 if (*ku < 0 || *ku > f2cmax(i__1,0) || (itype == 4 || itype == 5) &&
05187 *kl != *ku) {
05188 *info = -3;
05189 } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
05190 ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
05191 *info = -9;
05192 }
05193 }
05194 }
05195
05196 if (*info != 0) {
05197 i__1 = -(*info);
05198 xerbla_("SLASCL", &i__1);
05199 return 0;
05200 }
05201
05202
05203
05204 if (*n == 0 || *m == 0) {
05205 return 0;
05206 }
05207
05208
05209
05210 smlnum = slamch_("S");
05211 bignum = 1.f / smlnum;
05212
05213 cfromc = *cfrom;
05214 ctoc = *cto;
05215
05216 L10:
05217 cfrom1 = cfromc * smlnum;
05218 cto1 = ctoc / bignum;
05219 if (dabs(cfrom1) > dabs(ctoc) && ctoc != 0.f) {
05220 mul = smlnum;
05221 done = FALSE_;
05222 cfromc = cfrom1;
05223 } else if (dabs(cto1) > dabs(cfromc)) {
05224 mul = bignum;
05225 done = FALSE_;
05226 ctoc = cto1;
05227 } else {
05228 mul = ctoc / cfromc;
05229 done = TRUE_;
05230 }
05231
05232 if (itype == 0) {
05233
05234
05235
05236 i__1 = *n;
05237 for (j = 1; j <= i__1; ++j) {
05238 i__2 = *m;
05239 for (i__ = 1; i__ <= i__2; ++i__) {
05240 a_ref(i__, j) = a_ref(i__, j) * mul;
05241
05242 }
05243
05244 }
05245
05246 } else if (itype == 1) {
05247
05248
05249
05250 i__1 = *n;
05251 for (j = 1; j <= i__1; ++j) {
05252 i__2 = *m;
05253 for (i__ = j; i__ <= i__2; ++i__) {
05254 a_ref(i__, j) = a_ref(i__, j) * mul;
05255
05256 }
05257
05258 }
05259
05260 } else if (itype == 2) {
05261
05262
05263
05264 i__1 = *n;
05265 for (j = 1; j <= i__1; ++j) {
05266 i__2 = f2cmin(j,*m);
05267 for (i__ = 1; i__ <= i__2; ++i__) {
05268 a_ref(i__, j) = a_ref(i__, j) * mul;
05269
05270 }
05271
05272 }
05273
05274 } else if (itype == 3) {
05275
05276
05277
05278 i__1 = *n;
05279 for (j = 1; j <= i__1; ++j) {
05280
05281 i__3 = j + 1;
05282 i__2 = f2cmin(i__3,*m);
05283 for (i__ = 1; i__ <= i__2; ++i__) {
05284 a_ref(i__, j) = a_ref(i__, j) * mul;
05285
05286 }
05287
05288 }
05289
05290 } else if (itype == 4) {
05291
05292
05293
05294 k3 = *kl + 1;
05295 k4 = *n + 1;
05296 i__1 = *n;
05297 for (j = 1; j <= i__1; ++j) {
05298
05299 i__3 = k3, i__4 = k4 - j;
05300 i__2 = f2cmin(i__3,i__4);
05301 for (i__ = 1; i__ <= i__2; ++i__) {
05302 a_ref(i__, j) = a_ref(i__, j) * mul;
05303
05304 }
05305
05306 }
05307
05308 } else if (itype == 5) {
05309
05310
05311
05312 k1 = *ku + 2;
05313 k3 = *ku + 1;
05314 i__1 = *n;
05315 for (j = 1; j <= i__1; ++j) {
05316
05317 i__2 = k1 - j;
05318 i__3 = k3;
05319 for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) {
05320 a_ref(i__, j) = a_ref(i__, j) * mul;
05321
05322 }
05323
05324 }
05325
05326 } else if (itype == 6) {
05327
05328
05329
05330 k1 = *kl + *ku + 2;
05331 k2 = *kl + 1;
05332 k3 = (*kl << 1) + *ku + 1;
05333 k4 = *kl + *ku + 1 + *m;
05334 i__1 = *n;
05335 for (j = 1; j <= i__1; ++j) {
05336
05337 i__3 = k1 - j;
05338
05339 i__4 = k3, i__5 = k4 - j;
05340 i__2 = f2cmin(i__4,i__5);
05341 for (i__ = f2cmax(i__3,k2); i__ <= i__2; ++i__) {
05342 a_ref(i__, j) = a_ref(i__, j) * mul;
05343
05344 }
05345
05346 }
05347
05348 }
05349
05350 if (! done) {
05351 goto L10;
05352 }
05353
05354 return 0;
05355
05356
05357
05358 }
05359
05360 #undef a_ref
05361
05362
05363
05364
05365
05366 int slaset_(const char *uplo, integer *m, integer *n, real *alpha,
05367 real *beta, real *a, integer *lda)
05368 {
05369
05370
05371
05372
05373
05374
05375
05376
05377
05378
05379
05380
05381
05382
05383
05384
05385
05386
05387
05388
05389
05390
05391
05392
05393
05394
05395
05396
05397
05398
05399
05400
05401
05402
05403
05404
05405
05406
05407
05408
05409
05410
05411
05412
05413
05414
05415
05416
05417
05418
05419
05420
05421 integer a_dim1, a_offset, i__1, i__2, i__3;
05422
05423 static integer i__, j;
05424 extern logical lsame_(const char *, const char *);
05425 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
05426
05427 a_dim1 = *lda;
05428 a_offset = 1 + a_dim1 * 1;
05429 a -= a_offset;
05430
05431
05432 if (lsame_(uplo, "U")) {
05433
05434
05435
05436
05437 i__1 = *n;
05438 for (j = 2; j <= i__1; ++j) {
05439
05440 i__3 = j - 1;
05441 i__2 = f2cmin(i__3,*m);
05442 for (i__ = 1; i__ <= i__2; ++i__) {
05443 a_ref(i__, j) = *alpha;
05444
05445 }
05446
05447 }
05448
05449 } else if (lsame_(uplo, "L")) {
05450
05451
05452
05453
05454 i__1 = f2cmin(*m,*n);
05455 for (j = 1; j <= i__1; ++j) {
05456 i__2 = *m;
05457 for (i__ = j + 1; i__ <= i__2; ++i__) {
05458 a_ref(i__, j) = *alpha;
05459
05460 }
05461
05462 }
05463
05464 } else {
05465
05466
05467
05468 i__1 = *n;
05469 for (j = 1; j <= i__1; ++j) {
05470 i__2 = *m;
05471 for (i__ = 1; i__ <= i__2; ++i__) {
05472 a_ref(i__, j) = *alpha;
05473
05474 }
05475
05476 }
05477 }
05478
05479
05480
05481 i__1 = f2cmin(*m,*n);
05482 for (i__ = 1; i__ <= i__1; ++i__) {
05483 a_ref(i__, i__) = *beta;
05484
05485 }
05486
05487 return 0;
05488
05489
05490
05491 }
05492
05493 #undef a_ref
05494
05495
05496
05497
05498
05499 int slasr_(const char *side, const char *pivot, const char *direct, integer *m,
05500 integer *n, real *c__, real *s, real *a, integer *lda)
05501 {
05502
05503
05504
05505
05506
05507
05508
05509
05510
05511
05512
05513
05514
05515
05516
05517
05518
05519
05520
05521
05522
05523
05524
05525
05526
05527
05528
05529
05530
05531
05532
05533
05534
05535
05536
05537
05538
05539
05540
05541
05542
05543
05544
05545
05546
05547
05548
05549
05550
05551
05552
05553
05554
05555
05556
05557
05558
05559
05560
05561
05562
05563
05564
05565
05566
05567
05568
05569
05570
05571
05572
05573
05574
05575
05576
05577
05578
05579
05580
05581
05582
05583
05584
05585
05586
05587
05588
05589
05590
05591
05592
05593
05594
05595
05596
05597
05598
05599
05600
05601
05602
05603 integer a_dim1, a_offset, i__1, i__2;
05604
05605 static integer info;
05606 static real temp;
05607 static integer i__, j;
05608 extern logical lsame_(const char *, const char *);
05609 static real ctemp, stemp;
05610 extern int xerbla_(const char *, integer *);
05611 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
05612
05613 --c__;
05614 --s;
05615 a_dim1 = *lda;
05616 a_offset = 1 + a_dim1 * 1;
05617 a -= a_offset;
05618
05619
05620 info = 0;
05621 if (! (lsame_(side, "L") || lsame_(side, "R"))) {
05622 info = 1;
05623 } else if (! (lsame_(pivot, "V") || lsame_(pivot,
05624 "T") || lsame_(pivot, "B"))) {
05625 info = 2;
05626 } else if (! (lsame_(direct, "F") || lsame_(direct,
05627 "B"))) {
05628 info = 3;
05629 } else if (*m < 0) {
05630 info = 4;
05631 } else if (*n < 0) {
05632 info = 5;
05633 } else if (*lda < f2cmax(1,*m)) {
05634 info = 9;
05635 }
05636 if (info != 0) {
05637 xerbla_("SLASR ", &info);
05638 return 0;
05639 }
05640
05641
05642
05643 if (*m == 0 || *n == 0) {
05644 return 0;
05645 }
05646 if (lsame_(side, "L")) {
05647
05648
05649
05650 if (lsame_(pivot, "V")) {
05651 if (lsame_(direct, "F")) {
05652 i__1 = *m - 1;
05653 for (j = 1; j <= i__1; ++j) {
05654 ctemp = c__[j];
05655 stemp = s[j];
05656 if (ctemp != 1.f || stemp != 0.f) {
05657 i__2 = *n;
05658 for (i__ = 1; i__ <= i__2; ++i__) {
05659 temp = a_ref(j + 1, i__);
05660 a_ref(j + 1, i__) = ctemp * temp - stemp * a_ref(
05661 j, i__);
05662 a_ref(j, i__) = stemp * temp + ctemp * a_ref(j,
05663 i__);
05664
05665 }
05666 }
05667
05668 }
05669 } else if (lsame_(direct, "B")) {
05670 for (j = *m - 1; j >= 1; --j) {
05671 ctemp = c__[j];
05672 stemp = s[j];
05673 if (ctemp != 1.f || stemp != 0.f) {
05674 i__1 = *n;
05675 for (i__ = 1; i__ <= i__1; ++i__) {
05676 temp = a_ref(j + 1, i__);
05677 a_ref(j + 1, i__) = ctemp * temp - stemp * a_ref(
05678 j, i__);
05679 a_ref(j, i__) = stemp * temp + ctemp * a_ref(j,
05680 i__);
05681
05682 }
05683 }
05684
05685 }
05686 }
05687 } else if (lsame_(pivot, "T")) {
05688 if (lsame_(direct, "F")) {
05689 i__1 = *m;
05690 for (j = 2; j <= i__1; ++j) {
05691 ctemp = c__[j - 1];
05692 stemp = s[j - 1];
05693 if (ctemp != 1.f || stemp != 0.f) {
05694 i__2 = *n;
05695 for (i__ = 1; i__ <= i__2; ++i__) {
05696 temp = a_ref(j, i__);
05697 a_ref(j, i__) = ctemp * temp - stemp * a_ref(1,
05698 i__);
05699 a_ref(1, i__) = stemp * temp + ctemp * a_ref(1,
05700 i__);
05701
05702 }
05703 }
05704
05705 }
05706 } else if (lsame_(direct, "B")) {
05707 for (j = *m; j >= 2; --j) {
05708 ctemp = c__[j - 1];
05709 stemp = s[j - 1];
05710 if (ctemp != 1.f || stemp != 0.f) {
05711 i__1 = *n;
05712 for (i__ = 1; i__ <= i__1; ++i__) {
05713 temp = a_ref(j, i__);
05714 a_ref(j, i__) = ctemp * temp - stemp * a_ref(1,
05715 i__);
05716 a_ref(1, i__) = stemp * temp + ctemp * a_ref(1,
05717 i__);
05718
05719 }
05720 }
05721
05722 }
05723 }
05724 } else if (lsame_(pivot, "B")) {
05725 if (lsame_(direct, "F")) {
05726 i__1 = *m - 1;
05727 for (j = 1; j <= i__1; ++j) {
05728 ctemp = c__[j];
05729 stemp = s[j];
05730 if (ctemp != 1.f || stemp != 0.f) {
05731 i__2 = *n;
05732 for (i__ = 1; i__ <= i__2; ++i__) {
05733 temp = a_ref(j, i__);
05734 a_ref(j, i__) = stemp * a_ref(*m, i__) + ctemp *
05735 temp;
05736 a_ref(*m, i__) = ctemp * a_ref(*m, i__) - stemp *
05737 temp;
05738
05739 }
05740 }
05741
05742 }
05743 } else if (lsame_(direct, "B")) {
05744 for (j = *m - 1; j >= 1; --j) {
05745 ctemp = c__[j];
05746 stemp = s[j];
05747 if (ctemp != 1.f || stemp != 0.f) {
05748 i__1 = *n;
05749 for (i__ = 1; i__ <= i__1; ++i__) {
05750 temp = a_ref(j, i__);
05751 a_ref(j, i__) = stemp * a_ref(*m, i__) + ctemp *
05752 temp;
05753 a_ref(*m, i__) = ctemp * a_ref(*m, i__) - stemp *
05754 temp;
05755
05756 }
05757 }
05758
05759 }
05760 }
05761 }
05762 } else if (lsame_(side, "R")) {
05763
05764
05765
05766 if (lsame_(pivot, "V")) {
05767 if (lsame_(direct, "F")) {
05768 i__1 = *n - 1;
05769 for (j = 1; j <= i__1; ++j) {
05770 ctemp = c__[j];
05771 stemp = s[j];
05772 if (ctemp != 1.f || stemp != 0.f) {
05773 i__2 = *m;
05774 for (i__ = 1; i__ <= i__2; ++i__) {
05775 temp = a_ref(i__, j + 1);
05776 a_ref(i__, j + 1) = ctemp * temp - stemp * a_ref(
05777 i__, j);
05778 a_ref(i__, j) = stemp * temp + ctemp * a_ref(i__,
05779 j);
05780
05781 }
05782 }
05783
05784 }
05785 } else if (lsame_(direct, "B")) {
05786 for (j = *n - 1; j >= 1; --j) {
05787 ctemp = c__[j];
05788 stemp = s[j];
05789 if (ctemp != 1.f || stemp != 0.f) {
05790 i__1 = *m;
05791 for (i__ = 1; i__ <= i__1; ++i__) {
05792 temp = a_ref(i__, j + 1);
05793 a_ref(i__, j + 1) = ctemp * temp - stemp * a_ref(
05794 i__, j);
05795 a_ref(i__, j) = stemp * temp + ctemp * a_ref(i__,
05796 j);
05797
05798 }
05799 }
05800
05801 }
05802 }
05803 } else if (lsame_(pivot, "T")) {
05804 if (lsame_(direct, "F")) {
05805 i__1 = *n;
05806 for (j = 2; j <= i__1; ++j) {
05807 ctemp = c__[j - 1];
05808 stemp = s[j - 1];
05809 if (ctemp != 1.f || stemp != 0.f) {
05810 i__2 = *m;
05811 for (i__ = 1; i__ <= i__2; ++i__) {
05812 temp = a_ref(i__, j);
05813 a_ref(i__, j) = ctemp * temp - stemp * a_ref(i__,
05814 1);
05815 a_ref(i__, 1) = stemp * temp + ctemp * a_ref(i__,
05816 1);
05817
05818 }
05819 }
05820
05821 }
05822 } else if (lsame_(direct, "B")) {
05823 for (j = *n; j >= 2; --j) {
05824 ctemp = c__[j - 1];
05825 stemp = s[j - 1];
05826 if (ctemp != 1.f || stemp != 0.f) {
05827 i__1 = *m;
05828 for (i__ = 1; i__ <= i__1; ++i__) {
05829 temp = a_ref(i__, j);
05830 a_ref(i__, j) = ctemp * temp - stemp * a_ref(i__,
05831 1);
05832 a_ref(i__, 1) = stemp * temp + ctemp * a_ref(i__,
05833 1);
05834
05835 }
05836 }
05837
05838 }
05839 }
05840 } else if (lsame_(pivot, "B")) {
05841 if (lsame_(direct, "F")) {
05842 i__1 = *n - 1;
05843 for (j = 1; j <= i__1; ++j) {
05844 ctemp = c__[j];
05845 stemp = s[j];
05846 if (ctemp != 1.f || stemp != 0.f) {
05847 i__2 = *m;
05848 for (i__ = 1; i__ <= i__2; ++i__) {
05849 temp = a_ref(i__, j);
05850 a_ref(i__, j) = stemp * a_ref(i__, *n) + ctemp *
05851 temp;
05852 a_ref(i__, *n) = ctemp * a_ref(i__, *n) - stemp *
05853 temp;
05854
05855 }
05856 }
05857
05858 }
05859 } else if (lsame_(direct, "B")) {
05860 for (j = *n - 1; j >= 1; --j) {
05861 ctemp = c__[j];
05862 stemp = s[j];
05863 if (ctemp != 1.f || stemp != 0.f) {
05864 i__1 = *m;
05865 for (i__ = 1; i__ <= i__1; ++i__) {
05866 temp = a_ref(i__, j);
05867 a_ref(i__, j) = stemp * a_ref(i__, *n) + ctemp *
05868 temp;
05869 a_ref(i__, *n) = ctemp * a_ref(i__, *n) - stemp *
05870 temp;
05871
05872 }
05873 }
05874
05875 }
05876 }
05877 }
05878 }
05879
05880 return 0;
05881
05882
05883
05884 }
05885
05886 #undef a_ref
05887
05888
05889
05890
05891
05892 int slasrt_(const char *id, integer *n, real *d__, integer *info)
05893 {
05894
05895
05896
05897
05898
05899
05900
05901
05902
05903
05904
05905
05906
05907
05908
05909
05910
05911
05912
05913
05914
05915
05916
05917
05918
05919
05920
05921
05922
05923
05924
05925
05926
05927
05928
05929
05930
05931
05932
05933
05934
05935
05936 integer i__1, i__2;
05937
05938 static integer endd, i__, j;
05939 extern logical lsame_(const char *, const char *);
05940 static integer stack[64] ;
05941 static real dmnmx, d1, d2, d3;
05942 static integer start;
05943 extern int xerbla_(const char *, integer *);
05944 static integer stkpnt, dir;
05945 static real tmp;
05946 #define stack_ref(a_1,a_2) stack[(a_2)*2 + a_1 - 3]
05947
05948 --d__;
05949
05950
05951 *info = 0;
05952 dir = -1;
05953 if (lsame_(id, "D")) {
05954 dir = 0;
05955 } else if (lsame_(id, "I")) {
05956 dir = 1;
05957 }
05958 if (dir == -1) {
05959 *info = -1;
05960 } else if (*n < 0) {
05961 *info = -2;
05962 }
05963 if (*info != 0) {
05964 i__1 = -(*info);
05965 xerbla_("SLASRT", &i__1);
05966 return 0;
05967 }
05968
05969
05970
05971 if (*n <= 1) {
05972 return 0;
05973 }
05974
05975 stkpnt = 1;
05976 stack_ref(1, 1) = 1;
05977 stack_ref(2, 1) = *n;
05978 L10:
05979 start = stack_ref(1, stkpnt);
05980 endd = stack_ref(2, stkpnt);
05981 --stkpnt;
05982 if (endd - start <= 20 && endd - start > 0) {
05983
05984
05985
05986 if (dir == 0) {
05987
05988
05989
05990 i__1 = endd;
05991 for (i__ = start + 1; i__ <= i__1; ++i__) {
05992 i__2 = start + 1;
05993 for (j = i__; j >= i__2; --j) {
05994 if (d__[j] > d__[j - 1]) {
05995 dmnmx = d__[j];
05996 d__[j] = d__[j - 1];
05997 d__[j - 1] = dmnmx;
05998 } else {
05999 goto L30;
06000 }
06001
06002 }
06003 L30:
06004 ;
06005 }
06006
06007 } else {
06008
06009
06010
06011 i__1 = endd;
06012 for (i__ = start + 1; i__ <= i__1; ++i__) {
06013 i__2 = start + 1;
06014 for (j = i__; j >= i__2; --j) {
06015 if (d__[j] < d__[j - 1]) {
06016 dmnmx = d__[j];
06017 d__[j] = d__[j - 1];
06018 d__[j - 1] = dmnmx;
06019 } else {
06020 goto L50;
06021 }
06022
06023 }
06024 L50:
06025 ;
06026 }
06027
06028 }
06029
06030 } else if (endd - start > 20) {
06031
06032
06033
06034
06035
06036 d1 = d__[start];
06037 d2 = d__[endd];
06038 i__ = (start + endd) / 2;
06039 d3 = d__[i__];
06040 if (d1 < d2) {
06041 if (d3 < d1) {
06042 dmnmx = d1;
06043 } else if (d3 < d2) {
06044 dmnmx = d3;
06045 } else {
06046 dmnmx = d2;
06047 }
06048 } else {
06049 if (d3 < d2) {
06050 dmnmx = d2;
06051 } else if (d3 < d1) {
06052 dmnmx = d3;
06053 } else {
06054 dmnmx = d1;
06055 }
06056 }
06057
06058 if (dir == 0) {
06059
06060
06061
06062 i__ = start - 1;
06063 j = endd + 1;
06064 L60:
06065 L70:
06066 --j;
06067 if (d__[j] < dmnmx) {
06068 goto L70;
06069 }
06070 L80:
06071 ++i__;
06072 if (d__[i__] > dmnmx) {
06073 goto L80;
06074 }
06075 if (i__ < j) {
06076 tmp = d__[i__];
06077 d__[i__] = d__[j];
06078 d__[j] = tmp;
06079 goto L60;
06080 }
06081 if (j - start > endd - j - 1) {
06082 ++stkpnt;
06083 stack_ref(1, stkpnt) = start;
06084 stack_ref(2, stkpnt) = j;
06085 ++stkpnt;
06086 stack_ref(1, stkpnt) = j + 1;
06087 stack_ref(2, stkpnt) = endd;
06088 } else {
06089 ++stkpnt;
06090 stack_ref(1, stkpnt) = j + 1;
06091 stack_ref(2, stkpnt) = endd;
06092 ++stkpnt;
06093 stack_ref(1, stkpnt) = start;
06094 stack_ref(2, stkpnt) = j;
06095 }
06096 } else {
06097
06098
06099
06100 i__ = start - 1;
06101 j = endd + 1;
06102 L90:
06103 L100:
06104 --j;
06105 if (d__[j] > dmnmx) {
06106 goto L100;
06107 }
06108 L110:
06109 ++i__;
06110 if (d__[i__] < dmnmx) {
06111 goto L110;
06112 }
06113 if (i__ < j) {
06114 tmp = d__[i__];
06115 d__[i__] = d__[j];
06116 d__[j] = tmp;
06117 goto L90;
06118 }
06119 if (j - start > endd - j - 1) {
06120 ++stkpnt;
06121 stack_ref(1, stkpnt) = start;
06122 stack_ref(2, stkpnt) = j;
06123 ++stkpnt;
06124 stack_ref(1, stkpnt) = j + 1;
06125 stack_ref(2, stkpnt) = endd;
06126 } else {
06127 ++stkpnt;
06128 stack_ref(1, stkpnt) = j + 1;
06129 stack_ref(2, stkpnt) = endd;
06130 ++stkpnt;
06131 stack_ref(1, stkpnt) = start;
06132 stack_ref(2, stkpnt) = j;
06133 }
06134 }
06135 }
06136 if (stkpnt > 0) {
06137 goto L10;
06138 }
06139 return 0;
06140
06141
06142
06143 }
06144
06145 #undef stack_ref
06146
06147
06148
06149
06150
06151 int slassq_(integer *n, real *x, integer *incx, real *scale,
06152 real *sumsq)
06153 {
06154
06155
06156
06157
06158
06159
06160
06161
06162
06163
06164
06165
06166
06167
06168
06169
06170
06171
06172
06173
06174
06175
06176
06177
06178
06179
06180
06181
06182
06183
06184
06185
06186
06187
06188
06189
06190
06191
06192
06193
06194
06195
06196
06197
06198
06199
06200
06201
06202
06203
06204
06205
06206 integer i__1, i__2;
06207 real r__1;
06208
06209 static real absxi;
06210 static integer ix;
06211
06212 --x;
06213
06214
06215 if (*n > 0) {
06216 i__1 = (*n - 1) * *incx + 1;
06217 i__2 = *incx;
06218 for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
06219 if (x[ix] != 0.f) {
06220 absxi = (r__1 = x[ix], dabs(r__1));
06221 if (*scale < absxi) {
06222
06223 r__1 = *scale / absxi;
06224 *sumsq = *sumsq * (r__1 * r__1) + 1;
06225 *scale = absxi;
06226 } else {
06227
06228 r__1 = absxi / *scale;
06229 *sumsq += r__1 * r__1;
06230 }
06231 }
06232
06233 }
06234 }
06235 return 0;
06236
06237
06238
06239 }
06240
06241
06242
06243
06244 int slatrd_(char *uplo, integer *n, integer *nb, real *a,
06245 integer *lda, real *e, real *tau, real *w, integer *ldw)
06246 {
06247
06248
06249
06250
06251
06252
06253
06254
06255
06256
06257
06258
06259
06260
06261
06262
06263
06264
06265
06266
06267
06268
06269
06270
06271
06272
06273
06274
06275
06276
06277
06278
06279
06280
06281
06282
06283
06284
06285
06286
06287
06288
06289
06290
06291
06292
06293
06294
06295
06296
06297
06298
06299
06300
06301
06302
06303
06304
06305
06306
06307
06308
06309
06310
06311
06312
06313
06314
06315
06316
06317
06318
06319
06320
06321
06322
06323
06324
06325
06326
06327
06328
06329
06330
06331
06332
06333
06334
06335
06336
06337
06338
06339
06340
06341
06342
06343
06344
06345
06346
06347
06348
06349
06350
06351
06352
06353
06354
06355
06356
06357
06358
06359
06360
06361
06362
06363
06364
06365
06366
06367
06368
06369
06370
06371
06372
06373
06374
06375
06376
06377
06378
06379
06380
06381 static real c_b5 = -1.f;
06382 static real c_b6 = 1.f;
06383 static integer c__1 = 1;
06384 static real c_b16 = 0.f;
06385
06386
06387 integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
06388
06389 extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
06390 static integer i__;
06391 static real alpha;
06392 extern logical lsame_(const char *, const char *);
06393 extern int sscal_(integer *, real *, real *, integer *),
06394 sgemv_(const char *, integer *, integer *, real *, real *, integer *,
06395 real *, integer *, real *, real *, integer *), saxpy_(
06396 integer *, real *, real *, integer *, real *, integer *), ssymv_(
06397 const char *, integer *, real *, real *, integer *, real *, integer *,
06398 real *, real *, integer *);
06399 static integer iw;
06400 extern int slarfg_(integer *, real *, real *, integer *,
06401 real *);
06402 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
06403 #define w_ref(a_1,a_2) w[(a_2)*w_dim1 + a_1]
06404
06405
06406 a_dim1 = *lda;
06407 a_offset = 1 + a_dim1 * 1;
06408 a -= a_offset;
06409 --e;
06410 --tau;
06411 w_dim1 = *ldw;
06412 w_offset = 1 + w_dim1 * 1;
06413 w -= w_offset;
06414
06415
06416 if (*n <= 0) {
06417 return 0;
06418 }
06419
06420 if (lsame_(uplo, "U")) {
06421
06422
06423
06424 i__1 = *n - *nb + 1;
06425 for (i__ = *n; i__ >= i__1; --i__) {
06426 iw = i__ - *n + *nb;
06427 if (i__ < *n) {
06428
06429
06430
06431 i__2 = *n - i__;
06432 sgemv_("No transpose", &i__, &i__2, &c_b5, &a_ref(1, i__ + 1),
06433 lda, &w_ref(i__, iw + 1), ldw, &c_b6, &a_ref(1, i__),
06434 &c__1);
06435 i__2 = *n - i__;
06436 sgemv_("No transpose", &i__, &i__2, &c_b5, &w_ref(1, iw + 1),
06437 ldw, &a_ref(i__, i__ + 1), lda, &c_b6, &a_ref(1, i__),
06438 &c__1);
06439 }
06440 if (i__ > 1) {
06441
06442
06443
06444
06445 i__2 = i__ - 1;
06446 slarfg_(&i__2, &a_ref(i__ - 1, i__), &a_ref(1, i__), &c__1, &
06447 tau[i__ - 1]);
06448 e[i__ - 1] = a_ref(i__ - 1, i__);
06449 a_ref(i__ - 1, i__) = 1.f;
06450
06451
06452
06453 i__2 = i__ - 1;
06454 ssymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a_ref(1,
06455 i__), &c__1, &c_b16, &w_ref(1, iw), &c__1);
06456 if (i__ < *n) {
06457 i__2 = i__ - 1;
06458 i__3 = *n - i__;
06459 sgemv_("Transpose", &i__2, &i__3, &c_b6, &w_ref(1, iw + 1)
06460 , ldw, &a_ref(1, i__), &c__1, &c_b16, &w_ref(i__
06461 + 1, iw), &c__1);
06462 i__2 = i__ - 1;
06463 i__3 = *n - i__;
06464 sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(1, i__
06465 + 1), lda, &w_ref(i__ + 1, iw), &c__1, &c_b6, &
06466 w_ref(1, iw), &c__1);
06467 i__2 = i__ - 1;
06468 i__3 = *n - i__;
06469 sgemv_("Transpose", &i__2, &i__3, &c_b6, &a_ref(1, i__ +
06470 1), lda, &a_ref(1, i__), &c__1, &c_b16, &w_ref(
06471 i__ + 1, iw), &c__1);
06472 i__2 = i__ - 1;
06473 i__3 = *n - i__;
06474 sgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(1, iw
06475 + 1), ldw, &w_ref(i__ + 1, iw), &c__1, &c_b6, &
06476 w_ref(1, iw), &c__1);
06477 }
06478 i__2 = i__ - 1;
06479 sscal_(&i__2, &tau[i__ - 1], &w_ref(1, iw), &c__1);
06480 i__2 = i__ - 1;
06481 alpha = tau[i__ - 1] * -.5f * sdot_(&i__2, &w_ref(1, iw), &
06482 c__1, &a_ref(1, i__), &c__1);
06483 i__2 = i__ - 1;
06484 saxpy_(&i__2, &alpha, &a_ref(1, i__), &c__1, &w_ref(1, iw), &
06485 c__1);
06486 }
06487
06488
06489 }
06490 } else {
06491
06492
06493
06494 i__1 = *nb;
06495 for (i__ = 1; i__ <= i__1; ++i__) {
06496
06497
06498
06499 i__2 = *n - i__ + 1;
06500 i__3 = i__ - 1;
06501 sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__, 1), lda, &
06502 w_ref(i__, 1), ldw, &c_b6, &a_ref(i__, i__), &c__1);
06503 i__2 = *n - i__ + 1;
06504 i__3 = i__ - 1;
06505 sgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(i__, 1), ldw, &
06506 a_ref(i__, 1), lda, &c_b6, &a_ref(i__, i__), &c__1);
06507 if (i__ < *n) {
06508
06509
06510
06511
06512
06513 i__2 = i__ + 2;
06514 i__3 = *n - i__;
06515 slarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(f2cmin(i__2,*n), i__)
06516 , &c__1, &tau[i__]);
06517 e[i__] = a_ref(i__ + 1, i__);
06518 a_ref(i__ + 1, i__) = 1.f;
06519
06520
06521
06522 i__2 = *n - i__;
06523 ssymv_("Lower", &i__2, &c_b6, &a_ref(i__ + 1, i__ + 1), lda, &
06524 a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(i__ + 1,
06525 i__), &c__1);
06526 i__2 = *n - i__;
06527 i__3 = i__ - 1;
06528 sgemv_("Transpose", &i__2, &i__3, &c_b6, &w_ref(i__ + 1, 1),
06529 ldw, &a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(1,
06530 i__), &c__1);
06531 i__2 = *n - i__;
06532 i__3 = i__ - 1;
06533 sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, 1)
06534 , lda, &w_ref(1, i__), &c__1, &c_b6, &w_ref(i__ + 1,
06535 i__), &c__1);
06536 i__2 = *n - i__;
06537 i__3 = i__ - 1;
06538 sgemv_("Transpose", &i__2, &i__3, &c_b6, &a_ref(i__ + 1, 1),
06539 lda, &a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(1,
06540 i__), &c__1);
06541 i__2 = *n - i__;
06542 i__3 = i__ - 1;
06543 sgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(i__ + 1, 1)
06544 , ldw, &w_ref(1, i__), &c__1, &c_b6, &w_ref(i__ + 1,
06545 i__), &c__1);
06546 i__2 = *n - i__;
06547 sscal_(&i__2, &tau[i__], &w_ref(i__ + 1, i__), &c__1);
06548 i__2 = *n - i__;
06549 alpha = tau[i__] * -.5f * sdot_(&i__2, &w_ref(i__ + 1, i__), &
06550 c__1, &a_ref(i__ + 1, i__), &c__1);
06551 i__2 = *n - i__;
06552 saxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &w_ref(i__
06553 + 1, i__), &c__1);
06554 }
06555
06556
06557 }
06558 }
06559
06560 return 0;
06561
06562
06563
06564 }
06565
06566 #undef w_ref
06567 #undef a_ref
06568
06569
06570
06571
06572
06573 doublereal snrm2_(integer *n, real *x, integer *incx)
06574 {
06575
06576
06577
06578
06579 integer i__1, i__2;
06580 real ret_val, r__1;
06581
06582
06583
06584 static real norm, scale, absxi;
06585 static integer ix;
06586 static real ssq;
06587
06588
06589
06590
06591
06592
06593
06594 --x;
06595
06596 if (*n < 1 || *incx < 1) {
06597 norm = 0.f;
06598 } else if (*n == 1) {
06599 norm = dabs(x[1]);
06600 } else {
06601 scale = 0.f;
06602 ssq = 1.f;
06603
06604
06605 i__1 = (*n - 1) * *incx + 1;
06606 i__2 = *incx;
06607 for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
06608 if (x[ix] != 0.f) {
06609 absxi = (r__1 = x[ix], dabs(r__1));
06610 if (scale < absxi) {
06611
06612 r__1 = scale / absxi;
06613 ssq = ssq * (r__1 * r__1) + 1.f;
06614 scale = absxi;
06615 } else {
06616
06617 r__1 = absxi / scale;
06618 ssq += r__1 * r__1;
06619 }
06620 }
06621
06622 }
06623 norm = scale * sqrt(ssq);
06624 }
06625
06626 ret_val = norm;
06627 return ret_val;
06628
06629
06630
06631 }
06632
06633
06634
06635
06636 int sorg2l_(integer *m, integer *n, integer *k, real *a,
06637 integer *lda, real *tau, real *work, integer *info)
06638 {
06639
06640
06641
06642
06643
06644
06645
06646
06647
06648
06649
06650
06651
06652
06653
06654
06655
06656
06657
06658
06659
06660
06661
06662
06663
06664
06665
06666
06667
06668
06669
06670
06671
06672
06673
06674
06675
06676
06677
06678
06679
06680
06681
06682
06683
06684
06685
06686
06687
06688
06689
06690
06691
06692
06693
06694
06695
06696 static integer c__1 = 1;
06697
06698
06699 integer a_dim1, a_offset, i__1, i__2, i__3;
06700 real r__1;
06701
06702 static integer i__, j, l;
06703 extern int sscal_(integer *, real *, real *, integer *),
06704 slarf_(const char *, integer *, integer *, real *, integer *, real *,
06705 real *, integer *, real *);
06706 static integer ii;
06707 extern int xerbla_(const char *, integer *);
06708 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
06709
06710
06711 a_dim1 = *lda;
06712 a_offset = 1 + a_dim1 * 1;
06713 a -= a_offset;
06714 --tau;
06715 --work;
06716
06717
06718 *info = 0;
06719 if (*m < 0) {
06720 *info = -1;
06721 } else if (*n < 0 || *n > *m) {
06722 *info = -2;
06723 } else if (*k < 0 || *k > *n) {
06724 *info = -3;
06725 } else if (*lda < f2cmax(1,*m)) {
06726 *info = -5;
06727 }
06728 if (*info != 0) {
06729 i__1 = -(*info);
06730 xerbla_("SORG2L", &i__1);
06731 return 0;
06732 }
06733
06734
06735
06736 if (*n <= 0) {
06737 return 0;
06738 }
06739
06740
06741
06742 i__1 = *n - *k;
06743 for (j = 1; j <= i__1; ++j) {
06744 i__2 = *m;
06745 for (l = 1; l <= i__2; ++l) {
06746 a_ref(l, j) = 0.f;
06747
06748 }
06749 a_ref(*m - *n + j, j) = 1.f;
06750
06751 }
06752
06753 i__1 = *k;
06754 for (i__ = 1; i__ <= i__1; ++i__) {
06755 ii = *n - *k + i__;
06756
06757
06758
06759 a_ref(*m - *n + ii, ii) = 1.f;
06760 i__2 = *m - *n + ii;
06761 i__3 = ii - 1;
06762 slarf_("Left", &i__2, &i__3, &a_ref(1, ii), &c__1, &tau[i__], &a[
06763 a_offset], lda, &work[1]);
06764 i__2 = *m - *n + ii - 1;
06765 r__1 = -tau[i__];
06766 sscal_(&i__2, &r__1, &a_ref(1, ii), &c__1);
06767 a_ref(*m - *n + ii, ii) = 1.f - tau[i__];
06768
06769
06770
06771 i__2 = *m;
06772 for (l = *m - *n + ii + 1; l <= i__2; ++l) {
06773 a_ref(l, ii) = 0.f;
06774
06775 }
06776
06777 }
06778 return 0;
06779
06780
06781
06782 }
06783
06784 #undef a_ref
06785
06786
06787
06788
06789
06790 int sorg2r_(integer *m, integer *n, integer *k, real *a,
06791 integer *lda, real *tau, real *work, integer *info)
06792 {
06793
06794
06795
06796
06797
06798
06799
06800
06801
06802
06803
06804
06805
06806
06807
06808
06809
06810
06811
06812
06813
06814
06815
06816
06817
06818
06819
06820
06821
06822
06823
06824
06825
06826
06827
06828
06829
06830
06831
06832
06833
06834
06835
06836
06837
06838
06839
06840
06841
06842
06843
06844
06845
06846
06847
06848
06849
06850 static integer c__1 = 1;
06851
06852
06853 integer a_dim1, a_offset, i__1, i__2;
06854 real r__1;
06855
06856 static integer i__, j, l;
06857 extern int sscal_(integer *, real *, real *, integer *),
06858 slarf_(const char *, integer *, integer *, real *, integer *, real *,
06859 real *, integer *, real *), xerbla_(const char *, integer *);
06860 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
06861
06862
06863 a_dim1 = *lda;
06864 a_offset = 1 + a_dim1 * 1;
06865 a -= a_offset;
06866 --tau;
06867 --work;
06868
06869
06870 *info = 0;
06871 if (*m < 0) {
06872 *info = -1;
06873 } else if (*n < 0 || *n > *m) {
06874 *info = -2;
06875 } else if (*k < 0 || *k > *n) {
06876 *info = -3;
06877 } else if (*lda < f2cmax(1,*m)) {
06878 *info = -5;
06879 }
06880 if (*info != 0) {
06881 i__1 = -(*info);
06882 xerbla_("SORG2R", &i__1);
06883 return 0;
06884 }
06885
06886
06887
06888 if (*n <= 0) {
06889 return 0;
06890 }
06891
06892
06893
06894 i__1 = *n;
06895 for (j = *k + 1; j <= i__1; ++j) {
06896 i__2 = *m;
06897 for (l = 1; l <= i__2; ++l) {
06898 a_ref(l, j) = 0.f;
06899
06900 }
06901 a_ref(j, j) = 1.f;
06902
06903 }
06904
06905 for (i__ = *k; i__ >= 1; --i__) {
06906
06907
06908
06909 if (i__ < *n) {
06910 a_ref(i__, i__) = 1.f;
06911 i__1 = *m - i__ + 1;
06912 i__2 = *n - i__;
06913 slarf_("Left", &i__1, &i__2, &a_ref(i__, i__), &c__1, &tau[i__], &
06914 a_ref(i__, i__ + 1), lda, &work[1]);
06915 }
06916 if (i__ < *m) {
06917 i__1 = *m - i__;
06918 r__1 = -tau[i__];
06919 sscal_(&i__1, &r__1, &a_ref(i__ + 1, i__), &c__1);
06920 }
06921 a_ref(i__, i__) = 1.f - tau[i__];
06922
06923
06924
06925 i__1 = i__ - 1;
06926 for (l = 1; l <= i__1; ++l) {
06927 a_ref(l, i__) = 0.f;
06928
06929 }
06930
06931 }
06932 return 0;
06933
06934
06935
06936 }
06937
06938 #undef a_ref
06939
06940
06941
06942
06943
06944 int sorgql_(integer *m, integer *n, integer *k, real *a,
06945 integer *lda, real *tau, real *work, integer *lwork, integer *info)
06946 {
06947
06948
06949
06950
06951
06952
06953
06954
06955
06956
06957
06958
06959
06960
06961
06962
06963
06964
06965
06966
06967
06968
06969
06970
06971
06972
06973
06974
06975
06976
06977
06978
06979
06980
06981
06982
06983
06984
06985
06986
06987
06988
06989
06990
06991
06992
06993
06994
06995
06996
06997
06998
06999
07000
07001
07002
07003
07004
07005
07006
07007
07008
07009
07010
07011
07012
07013
07014
07015 static integer c__1 = 1;
07016 static integer c_n1 = -1;
07017 static integer c__3 = 3;
07018 static integer c__2 = 2;
07019
07020
07021 integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
07022
07023 static integer i__, j, l, nbmin, iinfo;
07024 extern int sorg2l_(integer *, integer *, integer *, real
07025 *, integer *, real *, real *, integer *);
07026 static integer ib, nb, kk, nx;
07027 extern int slarfb_(const char *, const char *, const char *, const char *,
07028 integer *, integer *, integer *, real *, integer *, real *,
07029 integer *, real *, integer *, real *, integer *), xerbla_(const char *, integer *);
07030 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
07031 integer *, integer *, ftnlen, ftnlen);
07032 extern int slarft_(const char *, const char *, integer *, integer *,
07033 real *, integer *, real *, real *, integer *);
07034 static integer ldwork, lwkopt;
07035 static logical lquery;
07036 static integer iws;
07037 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
07038
07039
07040 a_dim1 = *lda;
07041 a_offset = 1 + a_dim1 * 1;
07042 a -= a_offset;
07043 --tau;
07044 --work;
07045
07046
07047 *info = 0;
07048 nb = ilaenv_(&c__1, "SORGQL", " ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
07049 lwkopt = f2cmax(1,*n) * nb;
07050 work[1] = (real) lwkopt;
07051 lquery = *lwork == -1;
07052 if (*m < 0) {
07053 *info = -1;
07054 } else if (*n < 0 || *n > *m) {
07055 *info = -2;
07056 } else if (*k < 0 || *k > *n) {
07057 *info = -3;
07058 } else if (*lda < f2cmax(1,*m)) {
07059 *info = -5;
07060 } else if (*lwork < f2cmax(1,*n) && ! lquery) {
07061 *info = -8;
07062 }
07063 if (*info != 0) {
07064 i__1 = -(*info);
07065 xerbla_("SORGQL", &i__1);
07066 return 0;
07067 } else if (lquery) {
07068 return 0;
07069 }
07070
07071
07072
07073 if (*n <= 0) {
07074 work[1] = 1.f;
07075 return 0;
07076 }
07077
07078 nbmin = 2;
07079 nx = 0;
07080 iws = *n;
07081 if (nb > 1 && nb < *k) {
07082
07083
07084
07085
07086 i__1 = 0, i__2 = ilaenv_(&c__3, "SORGQL", " ", m, n, k, &c_n1, (
07087 ftnlen)6, (ftnlen)1);
07088 nx = f2cmax(i__1,i__2);
07089 if (nx < *k) {
07090
07091
07092
07093 ldwork = *n;
07094 iws = ldwork * nb;
07095 if (*lwork < iws) {
07096
07097
07098
07099
07100 nb = *lwork / ldwork;
07101
07102 i__1 = 2, i__2 = ilaenv_(&c__2, "SORGQL", " ", m, n, k, &c_n1,
07103 (ftnlen)6, (ftnlen)1);
07104 nbmin = f2cmax(i__1,i__2);
07105 }
07106 }
07107 }
07108
07109 if (nb >= nbmin && nb < *k && nx < *k) {
07110
07111
07112
07113
07114
07115 i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
07116 kk = f2cmin(i__1,i__2);
07117
07118
07119
07120 i__1 = *n - kk;
07121 for (j = 1; j <= i__1; ++j) {
07122 i__2 = *m;
07123 for (i__ = *m - kk + 1; i__ <= i__2; ++i__) {
07124 a_ref(i__, j) = 0.f;
07125
07126 }
07127
07128 }
07129 } else {
07130 kk = 0;
07131 }
07132
07133
07134
07135 i__1 = *m - kk;
07136 i__2 = *n - kk;
07137 i__3 = *k - kk;
07138 sorg2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo)
07139 ;
07140
07141 if (kk > 0) {
07142
07143
07144
07145 i__1 = *k;
07146 i__2 = nb;
07147 for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
07148 i__2) {
07149
07150 i__3 = nb, i__4 = *k - i__ + 1;
07151 ib = f2cmin(i__3,i__4);
07152 if (*n - *k + i__ > 1) {
07153
07154
07155
07156
07157 i__3 = *m - *k + i__ + ib - 1;
07158 slarft_("Backward", "Columnwise", &i__3, &ib, &a_ref(1, *n - *
07159 k + i__), lda, &tau[i__], &work[1], &ldwork);
07160
07161
07162
07163 i__3 = *m - *k + i__ + ib - 1;
07164 i__4 = *n - *k + i__ - 1;
07165 slarfb_("Left", "No transpose", "Backward", "Columnwise", &
07166 i__3, &i__4, &ib, &a_ref(1, *n - *k + i__), lda, &
07167 work[1], &ldwork, &a[a_offset], lda, &work[ib + 1], &
07168 ldwork);
07169 }
07170
07171
07172
07173 i__3 = *m - *k + i__ + ib - 1;
07174 sorg2l_(&i__3, &ib, &ib, &a_ref(1, *n - *k + i__), lda, &tau[i__],
07175 &work[1], &iinfo);
07176
07177
07178
07179 i__3 = *n - *k + i__ + ib - 1;
07180 for (j = *n - *k + i__; j <= i__3; ++j) {
07181 i__4 = *m;
07182 for (l = *m - *k + i__ + ib; l <= i__4; ++l) {
07183 a_ref(l, j) = 0.f;
07184
07185 }
07186
07187 }
07188
07189 }
07190 }
07191
07192 work[1] = (real) iws;
07193 return 0;
07194
07195
07196
07197 }
07198
07199 #undef a_ref
07200
07201
07202
07203
07204
07205 int sorgqr_(integer *m, integer *n, integer *k, real *a,
07206 integer *lda, real *tau, real *work, integer *lwork, integer *info)
07207 {
07208
07209
07210
07211
07212
07213
07214
07215
07216
07217
07218
07219
07220
07221
07222
07223
07224
07225
07226
07227
07228
07229
07230
07231
07232
07233
07234
07235
07236
07237
07238
07239
07240
07241
07242
07243
07244
07245
07246
07247
07248
07249
07250
07251
07252
07253
07254
07255
07256
07257
07258
07259
07260
07261
07262
07263
07264
07265
07266
07267
07268
07269
07270
07271
07272
07273
07274
07275
07276 static integer c__1 = 1;
07277 static integer c_n1 = -1;
07278 static integer c__3 = 3;
07279 static integer c__2 = 2;
07280
07281
07282 integer a_dim1, a_offset, i__1, i__2, i__3;
07283
07284 static integer i__, j, l, nbmin, iinfo, ib;
07285 extern int sorg2r_(integer *, integer *, integer *, real
07286 *, integer *, real *, real *, integer *);
07287 static integer nb, ki, kk, nx;
07288 extern int slarfb_(const char *, const char *, const char *, const char *,
07289 integer *, integer *, integer *, real *, integer *, real *,
07290 integer *, real *, integer *, real *, integer *), xerbla_(const char *, integer *);
07291 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
07292 integer *, integer *, ftnlen, ftnlen);
07293 extern int slarft_(const char *, const char *, integer *, integer *,
07294 real *, integer *, real *, real *, integer *);
07295 static integer ldwork, lwkopt;
07296 static logical lquery;
07297 static integer iws;
07298 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
07299
07300
07301 a_dim1 = *lda;
07302 a_offset = 1 + a_dim1 * 1;
07303 a -= a_offset;
07304 --tau;
07305 --work;
07306
07307
07308 *info = 0;
07309 nb = ilaenv_(&c__1, "SORGQR", " ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
07310 lwkopt = f2cmax(1,*n) * nb;
07311 work[1] = (real) lwkopt;
07312 lquery = *lwork == -1;
07313 if (*m < 0) {
07314 *info = -1;
07315 } else if (*n < 0 || *n > *m) {
07316 *info = -2;
07317 } else if (*k < 0 || *k > *n) {
07318 *info = -3;
07319 } else if (*lda < f2cmax(1,*m)) {
07320 *info = -5;
07321 } else if (*lwork < f2cmax(1,*n) && ! lquery) {
07322 *info = -8;
07323 }
07324 if (*info != 0) {
07325 i__1 = -(*info);
07326 xerbla_("SORGQR", &i__1);
07327 return 0;
07328 } else if (lquery) {
07329 return 0;
07330 }
07331
07332
07333
07334 if (*n <= 0) {
07335 work[1] = 1.f;
07336 return 0;
07337 }
07338
07339 nbmin = 2;
07340 nx = 0;
07341 iws = *n;
07342 if (nb > 1 && nb < *k) {
07343
07344
07345
07346
07347 i__1 = 0, i__2 = ilaenv_(&c__3, "SORGQR", " ", m, n, k, &c_n1, (
07348 ftnlen)6, (ftnlen)1);
07349 nx = f2cmax(i__1,i__2);
07350 if (nx < *k) {
07351
07352
07353
07354 ldwork = *n;
07355 iws = ldwork * nb;
07356 if (*lwork < iws) {
07357
07358
07359
07360
07361 nb = *lwork / ldwork;
07362
07363 i__1 = 2, i__2 = ilaenv_(&c__2, "SORGQR", " ", m, n, k, &c_n1,
07364 (ftnlen)6, (ftnlen)1);
07365 nbmin = f2cmax(i__1,i__2);
07366 }
07367 }
07368 }
07369
07370 if (nb >= nbmin && nb < *k && nx < *k) {
07371
07372
07373
07374
07375 ki = (*k - nx - 1) / nb * nb;
07376
07377 i__1 = *k, i__2 = ki + nb;
07378 kk = f2cmin(i__1,i__2);
07379
07380
07381
07382 i__1 = *n;
07383 for (j = kk + 1; j <= i__1; ++j) {
07384 i__2 = kk;
07385 for (i__ = 1; i__ <= i__2; ++i__) {
07386 a_ref(i__, j) = 0.f;
07387
07388 }
07389
07390 }
07391 } else {
07392 kk = 0;
07393 }
07394
07395
07396
07397 if (kk < *n) {
07398 i__1 = *m - kk;
07399 i__2 = *n - kk;
07400 i__3 = *k - kk;
07401 sorg2r_(&i__1, &i__2, &i__3, &a_ref(kk + 1, kk + 1), lda, &tau[kk + 1]
07402 , &work[1], &iinfo);
07403 }
07404
07405 if (kk > 0) {
07406
07407
07408
07409 i__1 = -nb;
07410 for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
07411
07412 i__2 = nb, i__3 = *k - i__ + 1;
07413 ib = f2cmin(i__2,i__3);
07414 if (i__ + ib <= *n) {
07415
07416
07417
07418
07419 i__2 = *m - i__ + 1;
07420 slarft_("Forward", "Columnwise", &i__2, &ib, &a_ref(i__, i__),
07421 lda, &tau[i__], &work[1], &ldwork);
07422
07423
07424
07425 i__2 = *m - i__ + 1;
07426 i__3 = *n - i__ - ib + 1;
07427 slarfb_("Left", "No transpose", "Forward", "Columnwise", &
07428 i__2, &i__3, &ib, &a_ref(i__, i__), lda, &work[1], &
07429 ldwork, &a_ref(i__, i__ + ib), lda, &work[ib + 1], &
07430 ldwork);
07431 }
07432
07433
07434
07435 i__2 = *m - i__ + 1;
07436 sorg2r_(&i__2, &ib, &ib, &a_ref(i__, i__), lda, &tau[i__], &work[
07437 1], &iinfo);
07438
07439
07440
07441 i__2 = i__ + ib - 1;
07442 for (j = i__; j <= i__2; ++j) {
07443 i__3 = i__ - 1;
07444 for (l = 1; l <= i__3; ++l) {
07445 a_ref(l, j) = 0.f;
07446
07447 }
07448
07449 }
07450
07451 }
07452 }
07453
07454 work[1] = (real) iws;
07455 return 0;
07456
07457
07458
07459 }
07460
07461 #undef a_ref
07462
07463
07464
07465
07466
07467 int sorgtr_(char *uplo, integer *n, real *a, integer *lda,
07468 real *tau, real *work, integer *lwork, integer *info)
07469 {
07470
07471
07472
07473
07474
07475
07476
07477
07478
07479
07480
07481
07482
07483
07484
07485
07486
07487
07488
07489
07490
07491
07492
07493
07494
07495
07496
07497
07498
07499
07500
07501
07502
07503
07504
07505
07506
07507
07508
07509
07510
07511
07512
07513
07514
07515
07516
07517
07518
07519
07520
07521
07522
07523
07524
07525
07526
07527
07528
07529
07530
07531
07532
07533
07534
07535 static integer c__1 = 1;
07536 static integer c_n1 = -1;
07537
07538
07539 integer a_dim1, a_offset, i__1, i__2, i__3;
07540
07541 static integer i__, j;
07542 extern logical lsame_(const char *, const char *);
07543 static integer iinfo;
07544 static logical upper;
07545 static integer nb;
07546 extern int xerbla_(const char *, integer *);
07547 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
07548 integer *, integer *, ftnlen, ftnlen);
07549 extern int sorgql_(integer *, integer *, integer *, real
07550 *, integer *, real *, real *, integer *, integer *), sorgqr_(
07551 integer *, integer *, integer *, real *, integer *, real *, real *
07552 , integer *, integer *);
07553 static logical lquery;
07554 static integer lwkopt;
07555 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
07556
07557
07558 a_dim1 = *lda;
07559 a_offset = 1 + a_dim1 * 1;
07560 a -= a_offset;
07561 --tau;
07562 --work;
07563
07564
07565 *info = 0;
07566 lquery = *lwork == -1;
07567 upper = lsame_(uplo, "U");
07568 if (! upper && ! lsame_(uplo, "L")) {
07569 *info = -1;
07570 } else if (*n < 0) {
07571 *info = -2;
07572 } else if (*lda < f2cmax(1,*n)) {
07573 *info = -4;
07574 } else {
07575
07576 i__1 = 1, i__2 = *n - 1;
07577 if (*lwork < f2cmax(i__1,i__2) && ! lquery) {
07578 *info = -7;
07579 }
07580 }
07581
07582 if (*info == 0) {
07583 if (upper) {
07584 i__1 = *n - 1;
07585 i__2 = *n - 1;
07586 i__3 = *n - 1;
07587 nb = ilaenv_(&c__1, "SORGQL", " ", &i__1, &i__2, &i__3, &c_n1, (
07588 ftnlen)6, (ftnlen)1);
07589 } else {
07590 i__1 = *n - 1;
07591 i__2 = *n - 1;
07592 i__3 = *n - 1;
07593 nb = ilaenv_(&c__1, "SORGQR", " ", &i__1, &i__2, &i__3, &c_n1, (
07594 ftnlen)6, (ftnlen)1);
07595 }
07596
07597 i__1 = 1, i__2 = *n - 1;
07598 lwkopt = f2cmax(i__1,i__2) * nb;
07599 work[1] = (real) lwkopt;
07600 }
07601
07602 if (*info != 0) {
07603 i__1 = -(*info);
07604 xerbla_("SORGTR", &i__1);
07605 return 0;
07606 } else if (lquery) {
07607 return 0;
07608 }
07609
07610
07611
07612 if (*n == 0) {
07613 work[1] = 1.f;
07614 return 0;
07615 }
07616
07617 if (upper) {
07618
07619
07620
07621
07622
07623
07624
07625 i__1 = *n - 1;
07626 for (j = 1; j <= i__1; ++j) {
07627 i__2 = j - 1;
07628 for (i__ = 1; i__ <= i__2; ++i__) {
07629 a_ref(i__, j) = a_ref(i__, j + 1);
07630
07631 }
07632 a_ref(*n, j) = 0.f;
07633
07634 }
07635 i__1 = *n - 1;
07636 for (i__ = 1; i__ <= i__1; ++i__) {
07637 a_ref(i__, *n) = 0.f;
07638
07639 }
07640 a_ref(*n, *n) = 1.f;
07641
07642
07643
07644 i__1 = *n - 1;
07645 i__2 = *n - 1;
07646 i__3 = *n - 1;
07647 sorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1],
07648 lwork, &iinfo);
07649
07650 } else {
07651
07652
07653
07654
07655
07656
07657
07658 for (j = *n; j >= 2; --j) {
07659 a_ref(1, j) = 0.f;
07660 i__1 = *n;
07661 for (i__ = j + 1; i__ <= i__1; ++i__) {
07662 a_ref(i__, j) = a_ref(i__, j - 1);
07663
07664 }
07665
07666 }
07667 a_ref(1, 1) = 1.f;
07668 i__1 = *n;
07669 for (i__ = 2; i__ <= i__1; ++i__) {
07670 a_ref(i__, 1) = 0.f;
07671
07672 }
07673 if (*n > 1) {
07674
07675
07676
07677 i__1 = *n - 1;
07678 i__2 = *n - 1;
07679 i__3 = *n - 1;
07680 sorgqr_(&i__1, &i__2, &i__3, &a_ref(2, 2), lda, &tau[1], &work[1],
07681 lwork, &iinfo);
07682 }
07683 }
07684 work[1] = (real) lwkopt;
07685 return 0;
07686
07687
07688
07689 }
07690
07691 #undef a_ref
07692
07693
07694
07695
07696
07697 int sscal_(integer *n, real *sa, real *sx, integer *incx)
07698 {
07699
07700 integer i__1, i__2;
07701
07702 static integer i__, m, nincx, mp1;
07703
07704
07705
07706
07707
07708
07709 --sx;
07710
07711 if (*n <= 0 || *incx <= 0) {
07712 return 0;
07713 }
07714 if (*incx == 1) {
07715 goto L20;
07716 }
07717
07718 nincx = *n * *incx;
07719 i__1 = nincx;
07720 i__2 = *incx;
07721 for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
07722 sx[i__] = *sa * sx[i__];
07723
07724 }
07725 return 0;
07726
07727
07728 L20:
07729 m = *n % 5;
07730 if (m == 0) {
07731 goto L40;
07732 }
07733 i__2 = m;
07734 for (i__ = 1; i__ <= i__2; ++i__) {
07735 sx[i__] = *sa * sx[i__];
07736
07737 }
07738 if (*n < 5) {
07739 return 0;
07740 }
07741 L40:
07742 mp1 = m + 1;
07743 i__2 = *n;
07744 for (i__ = mp1; i__ <= i__2; i__ += 5) {
07745 sx[i__] = *sa * sx[i__];
07746 sx[i__ + 1] = *sa * sx[i__ + 1];
07747 sx[i__ + 2] = *sa * sx[i__ + 2];
07748 sx[i__ + 3] = *sa * sx[i__ + 3];
07749 sx[i__ + 4] = *sa * sx[i__ + 4];
07750
07751 }
07752 return 0;
07753 }
07754
07755
07756
07757
07758 int ssteqr_(const char *compz, integer *n, real *d__, real *e,
07759 real *z__, integer *ldz, real *work, integer *info)
07760 {
07761
07762
07763
07764
07765
07766
07767
07768
07769
07770
07771
07772
07773
07774
07775
07776
07777
07778
07779
07780
07781
07782
07783
07784
07785
07786
07787
07788
07789
07790
07791
07792
07793
07794
07795
07796
07797
07798
07799
07800
07801
07802
07803
07804
07805
07806
07807
07808
07809
07810
07811
07812
07813
07814
07815
07816
07817
07818
07819
07820
07821
07822
07823
07824
07825
07826
07827
07828
07829
07830
07831
07832
07833
07834 static real c_b9 = 0.f;
07835 static real c_b10 = 1.f;
07836 static integer c__0 = 0;
07837 static integer c__1 = 1;
07838 static integer c__2 = 2;
07839
07840
07841 integer z_dim1, z_offset, i__1, i__2;
07842 real r__1, r__2;
07843
07844
07845 double r_sign(real *, real *);
07846
07847 static integer lend, jtot;
07848 extern int slae2_(real *, real *, real *, real *, real *)
07849 ;
07850 static real b, c__, f, g;
07851 static integer i__, j, k, l, m;
07852 static real p, r__, s;
07853 extern logical lsame_(const char *, const char *);
07854 static real anorm;
07855 extern int slasr_(const char *, const char *, const char *, integer *,
07856 integer *, real *, real *, real *, integer *);
07857 static integer l1;
07858 extern int sswap_(integer *, real *, integer *, real *,
07859 integer *);
07860 static integer lendm1, lendp1;
07861 extern int slaev2_(real *, real *, real *, real *, real *
07862 , real *, real *);
07863 extern doublereal slapy2_(real *, real *);
07864 static integer ii, mm, iscale;
07865 extern doublereal slamch_(const char *);
07866 static real safmin;
07867 extern int xerbla_(const char *, integer *);
07868 static real safmax;
07869 extern int slascl_(const char *, integer *, integer *, real *,
07870 real *, integer *, integer *, real *, integer *, integer *);
07871 static integer lendsv;
07872 extern int slartg_(real *, real *, real *, real *, real *
07873 ), slaset_(const char *, integer *, integer *, real *, real *, real *,
07874 integer *);
07875 static real ssfmin;
07876 static integer nmaxit, icompz;
07877 static real ssfmax;
07878 extern doublereal slanst_(const char *, integer *, real *, real *);
07879 extern int slasrt_(const char *, integer *, real *, integer *);
07880 static integer lm1, mm1, nm1;
07881 static real rt1, rt2, eps;
07882 static integer lsv;
07883 static real tst, eps2;
07884 #define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
07885
07886
07887 --d__;
07888 --e;
07889 z_dim1 = *ldz;
07890 z_offset = 1 + z_dim1 * 1;
07891 z__ -= z_offset;
07892 --work;
07893
07894
07895 *info = 0;
07896
07897 if (lsame_(compz, "N")) {
07898 icompz = 0;
07899 } else if (lsame_(compz, "V")) {
07900 icompz = 1;
07901 } else if (lsame_(compz, "I")) {
07902 icompz = 2;
07903 } else {
07904 icompz = -1;
07905 }
07906 if (icompz < 0) {
07907 *info = -1;
07908 } else if (*n < 0) {
07909 *info = -2;
07910 } else if (*ldz < 1 || icompz > 0 && *ldz < f2cmax(1,*n)) {
07911 *info = -6;
07912 }
07913 if (*info != 0) {
07914 i__1 = -(*info);
07915 xerbla_("SSTEQR", &i__1);
07916 return 0;
07917 }
07918
07919
07920
07921 if (*n == 0) {
07922 return 0;
07923 }
07924
07925 if (*n == 1) {
07926 if (icompz == 2) {
07927 z___ref(1, 1) = 1.f;
07928 }
07929 return 0;
07930 }
07931
07932
07933
07934 eps = slamch_("E");
07935
07936 r__1 = eps;
07937 eps2 = r__1 * r__1;
07938 safmin = slamch_("S");
07939 safmax = 1.f / safmin;
07940 ssfmax = sqrt(safmax) / 3.f;
07941 ssfmin = sqrt(safmin) / eps2;
07942
07943
07944
07945
07946 if (icompz == 2) {
07947 slaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
07948 }
07949
07950 nmaxit = *n * 30;
07951 jtot = 0;
07952
07953
07954
07955
07956
07957 l1 = 1;
07958 nm1 = *n - 1;
07959
07960 L10:
07961 if (l1 > *n) {
07962 goto L160;
07963 }
07964 if (l1 > 1) {
07965 e[l1 - 1] = 0.f;
07966 }
07967 if (l1 <= nm1) {
07968 i__1 = nm1;
07969 for (m = l1; m <= i__1; ++m) {
07970 tst = (r__1 = e[m], dabs(r__1));
07971 if (tst == 0.f) {
07972 goto L30;
07973 }
07974 if (tst <= sqrt((r__1 = d__[m], dabs(r__1))) * sqrt((r__2 = d__[m
07975 + 1], dabs(r__2))) * eps) {
07976 e[m] = 0.f;
07977 goto L30;
07978 }
07979
07980 }
07981 }
07982 m = *n;
07983
07984 L30:
07985 l = l1;
07986 lsv = l;
07987 lend = m;
07988 lendsv = lend;
07989 l1 = m + 1;
07990 if (lend == l) {
07991 goto L10;
07992 }
07993
07994
07995
07996 i__1 = lend - l + 1;
07997 anorm = slanst_("I", &i__1, &d__[l], &e[l]);
07998 iscale = 0;
07999 if (anorm == 0.f) {
08000 goto L10;
08001 }
08002 if (anorm > ssfmax) {
08003 iscale = 1;
08004 i__1 = lend - l + 1;
08005 slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
08006 info);
08007 i__1 = lend - l;
08008 slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
08009 info);
08010 } else if (anorm < ssfmin) {
08011 iscale = 2;
08012 i__1 = lend - l + 1;
08013 slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
08014 info);
08015 i__1 = lend - l;
08016 slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
08017 info);
08018 }
08019
08020
08021
08022 if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
08023 lend = lsv;
08024 l = lendsv;
08025 }
08026
08027 if (lend > l) {
08028
08029
08030
08031
08032
08033 L40:
08034 if (l != lend) {
08035 lendm1 = lend - 1;
08036 i__1 = lendm1;
08037 for (m = l; m <= i__1; ++m) {
08038
08039 r__2 = (r__1 = e[m], dabs(r__1));
08040 tst = r__2 * r__2;
08041 if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m
08042 + 1], dabs(r__2)) + safmin) {
08043 goto L60;
08044 }
08045
08046 }
08047 }
08048
08049 m = lend;
08050
08051 L60:
08052 if (m < lend) {
08053 e[m] = 0.f;
08054 }
08055 p = d__[l];
08056 if (m == l) {
08057 goto L80;
08058 }
08059
08060
08061
08062
08063 if (m == l + 1) {
08064 if (icompz > 0) {
08065 slaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
08066 work[l] = c__;
08067 work[*n - 1 + l] = s;
08068 slasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
08069 z___ref(1, l), ldz);
08070 } else {
08071 slae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
08072 }
08073 d__[l] = rt1;
08074 d__[l + 1] = rt2;
08075 e[l] = 0.f;
08076 l += 2;
08077 if (l <= lend) {
08078 goto L40;
08079 }
08080 goto L140;
08081 }
08082
08083 if (jtot == nmaxit) {
08084 goto L140;
08085 }
08086 ++jtot;
08087
08088
08089
08090 g = (d__[l + 1] - p) / (e[l] * 2.f);
08091 r__ = slapy2_(&g, &c_b10);
08092 g = d__[m] - p + e[l] / (g + r_sign(&r__, &g));
08093
08094 s = 1.f;
08095 c__ = 1.f;
08096 p = 0.f;
08097
08098
08099
08100 mm1 = m - 1;
08101 i__1 = l;
08102 for (i__ = mm1; i__ >= i__1; --i__) {
08103 f = s * e[i__];
08104 b = c__ * e[i__];
08105 slartg_(&g, &f, &c__, &s, &r__);
08106 if (i__ != m - 1) {
08107 e[i__ + 1] = r__;
08108 }
08109 g = d__[i__ + 1] - p;
08110 r__ = (d__[i__] - g) * s + c__ * 2.f * b;
08111 p = s * r__;
08112 d__[i__ + 1] = g + p;
08113 g = c__ * r__ - b;
08114
08115
08116
08117 if (icompz > 0) {
08118 work[i__] = c__;
08119 work[*n - 1 + i__] = -s;
08120 }
08121
08122
08123 }
08124
08125
08126
08127 if (icompz > 0) {
08128 mm = m - l + 1;
08129 slasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &
08130 z___ref(1, l), ldz);
08131 }
08132
08133 d__[l] -= p;
08134 e[l] = g;
08135 goto L40;
08136
08137
08138
08139 L80:
08140 d__[l] = p;
08141
08142 ++l;
08143 if (l <= lend) {
08144 goto L40;
08145 }
08146 goto L140;
08147
08148 } else {
08149
08150
08151
08152
08153
08154 L90:
08155 if (l != lend) {
08156 lendp1 = lend + 1;
08157 i__1 = lendp1;
08158 for (m = l; m >= i__1; --m) {
08159
08160 r__2 = (r__1 = e[m - 1], dabs(r__1));
08161 tst = r__2 * r__2;
08162 if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m
08163 - 1], dabs(r__2)) + safmin) {
08164 goto L110;
08165 }
08166
08167 }
08168 }
08169
08170 m = lend;
08171
08172 L110:
08173 if (m > lend) {
08174 e[m - 1] = 0.f;
08175 }
08176 p = d__[l];
08177 if (m == l) {
08178 goto L130;
08179 }
08180
08181
08182
08183
08184 if (m == l - 1) {
08185 if (icompz > 0) {
08186 slaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
08187 ;
08188 work[m] = c__;
08189 work[*n - 1 + m] = s;
08190 slasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
08191 z___ref(1, l - 1), ldz);
08192 } else {
08193 slae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
08194 }
08195 d__[l - 1] = rt1;
08196 d__[l] = rt2;
08197 e[l - 1] = 0.f;
08198 l += -2;
08199 if (l >= lend) {
08200 goto L90;
08201 }
08202 goto L140;
08203 }
08204
08205 if (jtot == nmaxit) {
08206 goto L140;
08207 }
08208 ++jtot;
08209
08210
08211
08212 g = (d__[l - 1] - p) / (e[l - 1] * 2.f);
08213 r__ = slapy2_(&g, &c_b10);
08214 g = d__[m] - p + e[l - 1] / (g + r_sign(&r__, &g));
08215
08216 s = 1.f;
08217 c__ = 1.f;
08218 p = 0.f;
08219
08220
08221
08222 lm1 = l - 1;
08223 i__1 = lm1;
08224 for (i__ = m; i__ <= i__1; ++i__) {
08225 f = s * e[i__];
08226 b = c__ * e[i__];
08227 slartg_(&g, &f, &c__, &s, &r__);
08228 if (i__ != m) {
08229 e[i__ - 1] = r__;
08230 }
08231 g = d__[i__] - p;
08232 r__ = (d__[i__ + 1] - g) * s + c__ * 2.f * b;
08233 p = s * r__;
08234 d__[i__] = g + p;
08235 g = c__ * r__ - b;
08236
08237
08238
08239 if (icompz > 0) {
08240 work[i__] = c__;
08241 work[*n - 1 + i__] = s;
08242 }
08243
08244
08245 }
08246
08247
08248
08249 if (icompz > 0) {
08250 mm = l - m + 1;
08251 slasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &
08252 z___ref(1, m), ldz);
08253 }
08254
08255 d__[l] -= p;
08256 e[lm1] = g;
08257 goto L90;
08258
08259
08260
08261 L130:
08262 d__[l] = p;
08263
08264 --l;
08265 if (l >= lend) {
08266 goto L90;
08267 }
08268 goto L140;
08269
08270 }
08271
08272
08273
08274 L140:
08275 if (iscale == 1) {
08276 i__1 = lendsv - lsv + 1;
08277 slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
08278 n, info);
08279 i__1 = lendsv - lsv;
08280 slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
08281 info);
08282 } else if (iscale == 2) {
08283 i__1 = lendsv - lsv + 1;
08284 slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
08285 n, info);
08286 i__1 = lendsv - lsv;
08287 slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
08288 info);
08289 }
08290
08291
08292
08293
08294 if (jtot < nmaxit) {
08295 goto L10;
08296 }
08297 i__1 = *n - 1;
08298 for (i__ = 1; i__ <= i__1; ++i__) {
08299 if (e[i__] != 0.f) {
08300 ++(*info);
08301 }
08302
08303 }
08304 goto L190;
08305
08306
08307
08308 L160:
08309 if (icompz == 0) {
08310
08311
08312
08313 slasrt_("I", n, &d__[1], info);
08314
08315 } else {
08316
08317
08318
08319 i__1 = *n;
08320 for (ii = 2; ii <= i__1; ++ii) {
08321 i__ = ii - 1;
08322 k = i__;
08323 p = d__[i__];
08324 i__2 = *n;
08325 for (j = ii; j <= i__2; ++j) {
08326 if (d__[j] < p) {
08327 k = j;
08328 p = d__[j];
08329 }
08330
08331 }
08332 if (k != i__) {
08333 d__[k] = d__[i__];
08334 d__[i__] = p;
08335 sswap_(n, &z___ref(1, i__), &c__1, &z___ref(1, k), &c__1);
08336 }
08337
08338 }
08339 }
08340
08341 L190:
08342 return 0;
08343
08344
08345
08346 }
08347
08348 #undef z___ref
08349
08350
08351
08352
08353
08354 int ssterf_(integer *n, real *d__, real *e, integer *info)
08355 {
08356
08357
08358
08359
08360
08361
08362
08363
08364
08365
08366
08367
08368
08369
08370
08371
08372
08373
08374
08375
08376
08377
08378
08379
08380
08381
08382
08383
08384
08385
08386
08387
08388
08389
08390
08391
08392
08393
08394
08395
08396
08397 static integer c__0 = 0;
08398 static integer c__1 = 1;
08399 static real c_b32 = 1.f;
08400
08401
08402 integer i__1;
08403 real r__1, r__2, r__3;
08404
08405
08406 double r_sign(real *, real *);
08407
08408 static real oldc;
08409 static integer lend, jtot;
08410 extern int slae2_(real *, real *, real *, real *, real *)
08411 ;
08412 static real c__;
08413 static integer i__, l, m;
08414 static real p, gamma, r__, s, alpha, sigma, anorm;
08415 static integer l1;
08416 static real bb;
08417 extern doublereal slapy2_(real *, real *);
08418 static integer iscale;
08419 static real oldgam;
08420 extern doublereal slamch_(const char *);
08421 static real safmin;
08422 extern int xerbla_(const char *, integer *);
08423 static real safmax;
08424 extern int slascl_(const char *, integer *, integer *, real *,
08425 real *, integer *, integer *, real *, integer *, integer *);
08426 static integer lendsv;
08427 static real ssfmin;
08428 static integer nmaxit;
08429 static real ssfmax;
08430 extern doublereal slanst_(const char *, integer *, real *, real *);
08431 extern int slasrt_(const char *, integer *, real *, integer *);
08432 static real rt1, rt2, eps, rte;
08433 static integer lsv;
08434 static real eps2;
08435
08436
08437 --e;
08438 --d__;
08439
08440
08441 *info = 0;
08442
08443
08444
08445 if (*n < 0) {
08446 *info = -1;
08447 i__1 = -(*info);
08448 xerbla_("SSTERF", &i__1);
08449 return 0;
08450 }
08451 if (*n <= 1) {
08452 return 0;
08453 }
08454
08455
08456
08457 eps = slamch_("E");
08458
08459 r__1 = eps;
08460 eps2 = r__1 * r__1;
08461 safmin = slamch_("S");
08462 safmax = 1.f / safmin;
08463 ssfmax = sqrt(safmax) / 3.f;
08464 ssfmin = sqrt(safmin) / eps2;
08465
08466
08467
08468 nmaxit = *n * 30;
08469 sigma = 0.f;
08470 jtot = 0;
08471
08472
08473
08474
08475
08476 l1 = 1;
08477
08478 L10:
08479 if (l1 > *n) {
08480 goto L170;
08481 }
08482 if (l1 > 1) {
08483 e[l1 - 1] = 0.f;
08484 }
08485 i__1 = *n - 1;
08486 for (m = l1; m <= i__1; ++m) {
08487 if ((r__3 = e[m], dabs(r__3)) <= sqrt((r__1 = d__[m], dabs(r__1))) *
08488 sqrt((r__2 = d__[m + 1], dabs(r__2))) * eps) {
08489 e[m] = 0.f;
08490 goto L30;
08491 }
08492
08493 }
08494 m = *n;
08495
08496 L30:
08497 l = l1;
08498 lsv = l;
08499 lend = m;
08500 lendsv = lend;
08501 l1 = m + 1;
08502 if (lend == l) {
08503 goto L10;
08504 }
08505
08506
08507
08508 i__1 = lend - l + 1;
08509 anorm = slanst_("I", &i__1, &d__[l], &e[l]);
08510 iscale = 0;
08511 if (anorm > ssfmax) {
08512 iscale = 1;
08513 i__1 = lend - l + 1;
08514 slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
08515 info);
08516 i__1 = lend - l;
08517 slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
08518 info);
08519 } else if (anorm < ssfmin) {
08520 iscale = 2;
08521 i__1 = lend - l + 1;
08522 slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
08523 info);
08524 i__1 = lend - l;
08525 slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
08526 info);
08527 }
08528
08529 i__1 = lend - 1;
08530 for (i__ = l; i__ <= i__1; ++i__) {
08531
08532 r__1 = e[i__];
08533 e[i__] = r__1 * r__1;
08534
08535 }
08536
08537
08538
08539 if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
08540 lend = lsv;
08541 l = lendsv;
08542 }
08543
08544 if (lend >= l) {
08545
08546
08547
08548
08549
08550 L50:
08551 if (l != lend) {
08552 i__1 = lend - 1;
08553 for (m = l; m <= i__1; ++m) {
08554 if ((r__2 = e[m], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
08555 m + 1], dabs(r__1))) {
08556 goto L70;
08557 }
08558
08559 }
08560 }
08561 m = lend;
08562
08563 L70:
08564 if (m < lend) {
08565 e[m] = 0.f;
08566 }
08567 p = d__[l];
08568 if (m == l) {
08569 goto L90;
08570 }
08571
08572
08573
08574
08575 if (m == l + 1) {
08576 rte = sqrt(e[l]);
08577 slae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
08578 d__[l] = rt1;
08579 d__[l + 1] = rt2;
08580 e[l] = 0.f;
08581 l += 2;
08582 if (l <= lend) {
08583 goto L50;
08584 }
08585 goto L150;
08586 }
08587
08588 if (jtot == nmaxit) {
08589 goto L150;
08590 }
08591 ++jtot;
08592
08593
08594
08595 rte = sqrt(e[l]);
08596 sigma = (d__[l + 1] - p) / (rte * 2.f);
08597 r__ = slapy2_(&sigma, &c_b32);
08598 sigma = p - rte / (sigma + r_sign(&r__, &sigma));
08599
08600 c__ = 1.f;
08601 s = 0.f;
08602 gamma = d__[m] - sigma;
08603 p = gamma * gamma;
08604
08605
08606
08607 i__1 = l;
08608 for (i__ = m - 1; i__ >= i__1; --i__) {
08609 bb = e[i__];
08610 r__ = p + bb;
08611 if (i__ != m - 1) {
08612 e[i__ + 1] = s * r__;
08613 }
08614 oldc = c__;
08615 c__ = p / r__;
08616 s = bb / r__;
08617 oldgam = gamma;
08618 alpha = d__[i__];
08619 gamma = c__ * (alpha - sigma) - s * oldgam;
08620 d__[i__ + 1] = oldgam + (alpha - gamma);
08621 if (c__ != 0.f) {
08622 p = gamma * gamma / c__;
08623 } else {
08624 p = oldc * bb;
08625 }
08626
08627 }
08628
08629 e[l] = s * p;
08630 d__[l] = sigma + gamma;
08631 goto L50;
08632
08633
08634
08635 L90:
08636 d__[l] = p;
08637
08638 ++l;
08639 if (l <= lend) {
08640 goto L50;
08641 }
08642 goto L150;
08643
08644 } else {
08645
08646
08647
08648
08649
08650 L100:
08651 i__1 = lend + 1;
08652 for (m = l; m >= i__1; --m) {
08653 if ((r__2 = e[m - 1], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
08654 m - 1], dabs(r__1))) {
08655 goto L120;
08656 }
08657
08658 }
08659 m = lend;
08660
08661 L120:
08662 if (m > lend) {
08663 e[m - 1] = 0.f;
08664 }
08665 p = d__[l];
08666 if (m == l) {
08667 goto L140;
08668 }
08669
08670
08671
08672
08673 if (m == l - 1) {
08674 rte = sqrt(e[l - 1]);
08675 slae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
08676 d__[l] = rt1;
08677 d__[l - 1] = rt2;
08678 e[l - 1] = 0.f;
08679 l += -2;
08680 if (l >= lend) {
08681 goto L100;
08682 }
08683 goto L150;
08684 }
08685
08686 if (jtot == nmaxit) {
08687 goto L150;
08688 }
08689 ++jtot;
08690
08691
08692
08693 rte = sqrt(e[l - 1]);
08694 sigma = (d__[l - 1] - p) / (rte * 2.f);
08695 r__ = slapy2_(&sigma, &c_b32);
08696 sigma = p - rte / (sigma + r_sign(&r__, &sigma));
08697
08698 c__ = 1.f;
08699 s = 0.f;
08700 gamma = d__[m] - sigma;
08701 p = gamma * gamma;
08702
08703
08704
08705 i__1 = l - 1;
08706 for (i__ = m; i__ <= i__1; ++i__) {
08707 bb = e[i__];
08708 r__ = p + bb;
08709 if (i__ != m) {
08710 e[i__ - 1] = s * r__;
08711 }
08712 oldc = c__;
08713 c__ = p / r__;
08714 s = bb / r__;
08715 oldgam = gamma;
08716 alpha = d__[i__ + 1];
08717 gamma = c__ * (alpha - sigma) - s * oldgam;
08718 d__[i__] = oldgam + (alpha - gamma);
08719 if (c__ != 0.f) {
08720 p = gamma * gamma / c__;
08721 } else {
08722 p = oldc * bb;
08723 }
08724
08725 }
08726
08727 e[l - 1] = s * p;
08728 d__[l] = sigma + gamma;
08729 goto L100;
08730
08731
08732
08733 L140:
08734 d__[l] = p;
08735
08736 --l;
08737 if (l >= lend) {
08738 goto L100;
08739 }
08740 goto L150;
08741
08742 }
08743
08744
08745
08746 L150:
08747 if (iscale == 1) {
08748 i__1 = lendsv - lsv + 1;
08749 slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
08750 n, info);
08751 }
08752 if (iscale == 2) {
08753 i__1 = lendsv - lsv + 1;
08754 slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
08755 n, info);
08756 }
08757
08758
08759
08760
08761 if (jtot < nmaxit) {
08762 goto L10;
08763 }
08764 i__1 = *n - 1;
08765 for (i__ = 1; i__ <= i__1; ++i__) {
08766 if (e[i__] != 0.f) {
08767 ++(*info);
08768 }
08769
08770 }
08771 goto L180;
08772
08773
08774
08775 L170:
08776 slasrt_("I", n, &d__[1], info);
08777
08778 L180:
08779 return 0;
08780
08781
08782
08783 }
08784
08785
08786
08787
08788 int sswap_(integer *n, real *sx, integer *incx, real *sy,
08789 integer *incy)
08790 {
08791
08792 integer i__1;
08793
08794 static integer i__, m;
08795 static real stemp;
08796 static integer ix, iy, mp1;
08797
08798
08799
08800
08801
08802 --sy;
08803 --sx;
08804
08805 if (*n <= 0) {
08806 return 0;
08807 }
08808 if (*incx == 1 && *incy == 1) {
08809 goto L20;
08810 }
08811
08812
08813 ix = 1;
08814 iy = 1;
08815 if (*incx < 0) {
08816 ix = (-(*n) + 1) * *incx + 1;
08817 }
08818 if (*incy < 0) {
08819 iy = (-(*n) + 1) * *incy + 1;
08820 }
08821 i__1 = *n;
08822 for (i__ = 1; i__ <= i__1; ++i__) {
08823 stemp = sx[ix];
08824 sx[ix] = sy[iy];
08825 sy[iy] = stemp;
08826 ix += *incx;
08827 iy += *incy;
08828
08829 }
08830 return 0;
08831
08832
08833 L20:
08834 m = *n % 3;
08835 if (m == 0) {
08836 goto L40;
08837 }
08838 i__1 = m;
08839 for (i__ = 1; i__ <= i__1; ++i__) {
08840 stemp = sx[i__];
08841 sx[i__] = sy[i__];
08842 sy[i__] = stemp;
08843
08844 }
08845 if (*n < 3) {
08846 return 0;
08847 }
08848 L40:
08849 mp1 = m + 1;
08850 i__1 = *n;
08851 for (i__ = mp1; i__ <= i__1; i__ += 3) {
08852 stemp = sx[i__];
08853 sx[i__] = sy[i__];
08854 sy[i__] = stemp;
08855 stemp = sx[i__ + 1];
08856 sx[i__ + 1] = sy[i__ + 1];
08857 sy[i__ + 1] = stemp;
08858 stemp = sx[i__ + 2];
08859 sx[i__ + 2] = sy[i__ + 2];
08860 sy[i__ + 2] = stemp;
08861
08862 }
08863 return 0;
08864 }
08865
08866
08867
08868
08869 int ssyev_(char *jobz, char *uplo, integer *n, real *a,
08870 integer *lda, real *w, real *work, integer *lwork, integer *info)
08871 {
08872
08873
08874
08875
08876
08877
08878
08879
08880
08881
08882
08883
08884
08885
08886
08887
08888
08889
08890
08891
08892
08893
08894
08895
08896
08897
08898
08899
08900
08901
08902
08903
08904
08905
08906
08907
08908
08909
08910
08911
08912
08913
08914
08915
08916
08917
08918
08919
08920
08921
08922
08923
08924
08925
08926
08927
08928
08929
08930
08931
08932
08933
08934
08935
08936
08937
08938
08939
08940
08941
08942
08943 static integer c__1 = 1;
08944 static integer c_n1 = -1;
08945 static integer c__0 = 0;
08946 static real c_b17 = 1.f;
08947
08948
08949 integer a_dim1, a_offset, i__1, i__2;
08950 real r__1;
08951
08952
08953
08954 static integer inde;
08955 static real anrm;
08956 static integer imax;
08957 static real rmin, rmax;
08958 static integer lopt;
08959 static real sigma;
08960 extern logical lsame_(const char *, const char *);
08961 static integer iinfo;
08962 extern int sscal_(integer *, real *, real *, integer *);
08963 static logical lower, wantz;
08964 static integer nb, iscale;
08965 extern doublereal slamch_(const char *);
08966 static real safmin;
08967 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
08968 integer *, integer *, ftnlen, ftnlen);
08969 extern int xerbla_(const char *, integer *);
08970 static real bignum;
08971 extern int slascl_(const char *, integer *, integer *, real *,
08972 real *, integer *, integer *, real *, integer *, integer *);
08973 static integer indtau, indwrk;
08974 extern int ssterf_(integer *, real *, real *, integer *);
08975 extern doublereal slansy_(const char *, char *, integer *, real *, integer *,
08976 real *);
08977 static integer llwork;
08978 static real smlnum;
08979 static integer lwkopt;
08980 static logical lquery;
08981 extern int sorgtr_(char *, integer *, real *, integer *,
08982 real *, real *, integer *, integer *), ssteqr_(const char *,
08983 integer *, real *, real *, real *, integer *, real *, integer *), ssytrd_(char *, integer *, real *, integer *, real *,
08984 real *, real *, real *, integer *, integer *);
08985 static real eps;
08986 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
08987
08988
08989 a_dim1 = *lda;
08990 a_offset = 1 + a_dim1 * 1;
08991 a -= a_offset;
08992 --w;
08993 --work;
08994
08995
08996 wantz = lsame_(jobz, "V");
08997 lower = lsame_(uplo, "L");
08998 lquery = *lwork == -1;
08999
09000 *info = 0;
09001 if (! (wantz || lsame_(jobz, "N"))) {
09002 *info = -1;
09003 } else if (! (lower || lsame_(uplo, "U"))) {
09004 *info = -2;
09005 } else if (*n < 0) {
09006 *info = -3;
09007 } else if (*lda < f2cmax(1,*n)) {
09008 *info = -5;
09009 } else {
09010
09011 i__1 = 1, i__2 = *n * 3 - 1;
09012 if (*lwork < f2cmax(i__1,i__2) && ! lquery) {
09013 *info = -8;
09014 }
09015 }
09016
09017 if (*info == 0) {
09018 nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
09019 (ftnlen)1);
09020
09021 i__1 = 1, i__2 = (nb + 2) * *n;
09022 lwkopt = f2cmax(i__1,i__2);
09023 work[1] = (real) lwkopt;
09024 }
09025
09026 if (*info != 0) {
09027 i__1 = -(*info);
09028 xerbla_("SSYEV ", &i__1);
09029 return 0;
09030 } else if (lquery) {
09031 return 0;
09032 }
09033
09034
09035
09036 if (*n == 0) {
09037 work[1] = 1.f;
09038 return 0;
09039 }
09040
09041 if (*n == 1) {
09042 w[1] = a_ref(1, 1);
09043 work[1] = 3.f;
09044 if (wantz) {
09045 a_ref(1, 1) = 1.f;
09046 }
09047 return 0;
09048 }
09049
09050
09051
09052 safmin = slamch_("Safe minimum");
09053 eps = slamch_("Precision");
09054 smlnum = safmin / eps;
09055 bignum = 1.f / smlnum;
09056 rmin = sqrt(smlnum);
09057 rmax = sqrt(bignum);
09058
09059
09060
09061 anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
09062 iscale = 0;
09063 if (anrm > 0.f && anrm < rmin) {
09064 iscale = 1;
09065 sigma = rmin / anrm;
09066 } else if (anrm > rmax) {
09067 iscale = 1;
09068 sigma = rmax / anrm;
09069 }
09070 if (iscale == 1) {
09071 slascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda,
09072 info);
09073 }
09074
09075
09076
09077 inde = 1;
09078 indtau = inde + *n;
09079 indwrk = indtau + *n;
09080 llwork = *lwork - indwrk + 1;
09081 ssytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
09082 work[indwrk], &llwork, &iinfo);
09083 lopt = static_cast<integer>( (*n << 1) + work[indwrk] );
09084
09085
09086
09087
09088 if (! wantz) {
09089 ssterf_(n, &w[1], &work[inde], info);
09090 } else {
09091 sorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
09092 llwork, &iinfo);
09093 ssteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau],
09094 info);
09095 }
09096
09097
09098
09099 if (iscale == 1) {
09100 if (*info == 0) {
09101 imax = *n;
09102 } else {
09103 imax = *info - 1;
09104 }
09105 r__1 = 1.f / sigma;
09106 sscal_(&imax, &r__1, &w[1], &c__1);
09107 }
09108
09109
09110
09111 work[1] = (real) lwkopt;
09112
09113 return 0;
09114
09115
09116
09117 }
09118
09119 #undef a_ref
09120
09121
09122
09123
09124
09125 int ssymv_(const char *uplo, integer *n, real *alpha, real *a,
09126 integer *lda, real *x, integer *incx, real *beta, real *y, integer *
09127 incy)
09128 {
09129
09130 integer a_dim1, a_offset, i__1, i__2;
09131
09132 static integer info;
09133 static real temp1, temp2;
09134 static integer i__, j;
09135 extern logical lsame_(const char *, const char *);
09136 static integer ix, iy, jx, jy, kx, ky;
09137 extern int xerbla_(const char *, integer *);
09138 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
09139
09140
09141
09142
09143
09144
09145
09146
09147
09148
09149
09150
09151
09152
09153
09154
09155
09156
09157
09158
09159
09160
09161
09162
09163
09164
09165
09166
09167
09168
09169
09170
09171
09172
09173
09174
09175
09176
09177
09178
09179
09180
09181
09182
09183
09184
09185
09186
09187
09188
09189
09190
09191
09192
09193
09194
09195
09196
09197
09198
09199
09200
09201
09202
09203
09204
09205
09206
09207
09208 a_dim1 = *lda;
09209 a_offset = 1 + a_dim1 * 1;
09210 a -= a_offset;
09211 --x;
09212 --y;
09213
09214 info = 0;
09215 if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
09216 info = 1;
09217 } else if (*n < 0) {
09218 info = 2;
09219 } else if (*lda < f2cmax(1,*n)) {
09220 info = 5;
09221 } else if (*incx == 0) {
09222 info = 7;
09223 } else if (*incy == 0) {
09224 info = 10;
09225 }
09226 if (info != 0) {
09227 xerbla_("SSYMV ", &info);
09228 return 0;
09229 }
09230
09231 if (*n == 0 || *alpha == 0.f && *beta == 1.f) {
09232 return 0;
09233 }
09234
09235 if (*incx > 0) {
09236 kx = 1;
09237 } else {
09238 kx = 1 - (*n - 1) * *incx;
09239 }
09240 if (*incy > 0) {
09241 ky = 1;
09242 } else {
09243 ky = 1 - (*n - 1) * *incy;
09244 }
09245
09246
09247
09248
09249 if (*beta != 1.f) {
09250 if (*incy == 1) {
09251 if (*beta == 0.f) {
09252 i__1 = *n;
09253 for (i__ = 1; i__ <= i__1; ++i__) {
09254 y[i__] = 0.f;
09255
09256 }
09257 } else {
09258 i__1 = *n;
09259 for (i__ = 1; i__ <= i__1; ++i__) {
09260 y[i__] = *beta * y[i__];
09261
09262 }
09263 }
09264 } else {
09265 iy = ky;
09266 if (*beta == 0.f) {
09267 i__1 = *n;
09268 for (i__ = 1; i__ <= i__1; ++i__) {
09269 y[iy] = 0.f;
09270 iy += *incy;
09271
09272 }
09273 } else {
09274 i__1 = *n;
09275 for (i__ = 1; i__ <= i__1; ++i__) {
09276 y[iy] = *beta * y[iy];
09277 iy += *incy;
09278
09279 }
09280 }
09281 }
09282 }
09283 if (*alpha == 0.f) {
09284 return 0;
09285 }
09286 if (lsame_(uplo, "U")) {
09287
09288 if (*incx == 1 && *incy == 1) {
09289 i__1 = *n;
09290 for (j = 1; j <= i__1; ++j) {
09291 temp1 = *alpha * x[j];
09292 temp2 = 0.f;
09293 i__2 = j - 1;
09294 for (i__ = 1; i__ <= i__2; ++i__) {
09295 y[i__] += temp1 * a_ref(i__, j);
09296 temp2 += a_ref(i__, j) * x[i__];
09297
09298 }
09299 y[j] = y[j] + temp1 * a_ref(j, j) + *alpha * temp2;
09300
09301 }
09302 } else {
09303 jx = kx;
09304 jy = ky;
09305 i__1 = *n;
09306 for (j = 1; j <= i__1; ++j) {
09307 temp1 = *alpha * x[jx];
09308 temp2 = 0.f;
09309 ix = kx;
09310 iy = ky;
09311 i__2 = j - 1;
09312 for (i__ = 1; i__ <= i__2; ++i__) {
09313 y[iy] += temp1 * a_ref(i__, j);
09314 temp2 += a_ref(i__, j) * x[ix];
09315 ix += *incx;
09316 iy += *incy;
09317
09318 }
09319 y[jy] = y[jy] + temp1 * a_ref(j, j) + *alpha * temp2;
09320 jx += *incx;
09321 jy += *incy;
09322
09323 }
09324 }
09325 } else {
09326
09327 if (*incx == 1 && *incy == 1) {
09328 i__1 = *n;
09329 for (j = 1; j <= i__1; ++j) {
09330 temp1 = *alpha * x[j];
09331 temp2 = 0.f;
09332 y[j] += temp1 * a_ref(j, j);
09333 i__2 = *n;
09334 for (i__ = j + 1; i__ <= i__2; ++i__) {
09335 y[i__] += temp1 * a_ref(i__, j);
09336 temp2 += a_ref(i__, j) * x[i__];
09337
09338 }
09339 y[j] += *alpha * temp2;
09340
09341 }
09342 } else {
09343 jx = kx;
09344 jy = ky;
09345 i__1 = *n;
09346 for (j = 1; j <= i__1; ++j) {
09347 temp1 = *alpha * x[jx];
09348 temp2 = 0.f;
09349 y[jy] += temp1 * a_ref(j, j);
09350 ix = jx;
09351 iy = jy;
09352 i__2 = *n;
09353 for (i__ = j + 1; i__ <= i__2; ++i__) {
09354 ix += *incx;
09355 iy += *incy;
09356 y[iy] += temp1 * a_ref(i__, j);
09357 temp2 += a_ref(i__, j) * x[ix];
09358
09359 }
09360 y[jy] += *alpha * temp2;
09361 jx += *incx;
09362 jy += *incy;
09363
09364 }
09365 }
09366 }
09367 return 0;
09368
09369 }
09370 #undef a_ref
09371
09372
09373
09374
09375 int ssyr2_(char *uplo, integer *n, real *alpha, real *x,
09376 integer *incx, real *y, integer *incy, real *a, integer *lda)
09377 {
09378
09379 integer a_dim1, a_offset, i__1, i__2;
09380
09381 static integer info;
09382 static real temp1, temp2;
09383 static integer i__, j;
09384 extern logical lsame_(const char *, const char *);
09385 static integer ix, iy, jx, jy, kx, ky;
09386 extern int xerbla_(const char *, integer *);
09387 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
09388
09389
09390
09391
09392
09393
09394
09395
09396
09397
09398
09399
09400
09401
09402
09403
09404
09405
09406
09407
09408
09409
09410
09411
09412
09413
09414
09415
09416
09417
09418
09419
09420
09421
09422
09423
09424
09425
09426
09427
09428
09429
09430
09431
09432
09433
09434
09435
09436
09437
09438
09439
09440
09441
09442
09443
09444
09445
09446
09447
09448
09449
09450
09451
09452
09453
09454
09455
09456 --x;
09457 --y;
09458 a_dim1 = *lda;
09459 a_offset = 1 + a_dim1 * 1;
09460 a -= a_offset;
09461
09462 info = 0;
09463 if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
09464 info = 1;
09465 } else if (*n < 0) {
09466 info = 2;
09467 } else if (*incx == 0) {
09468 info = 5;
09469 } else if (*incy == 0) {
09470 info = 7;
09471 } else if (*lda < f2cmax(1,*n)) {
09472 info = 9;
09473 }
09474 if (info != 0) {
09475 xerbla_("SSYR2 ", &info);
09476 return 0;
09477 }
09478
09479 if (*n == 0 || *alpha == 0.f) {
09480 return 0;
09481 }
09482
09483
09484 if (*incx != 1 || *incy != 1) {
09485 if (*incx > 0) {
09486 kx = 1;
09487 } else {
09488 kx = 1 - (*n - 1) * *incx;
09489 }
09490 if (*incy > 0) {
09491 ky = 1;
09492 } else {
09493 ky = 1 - (*n - 1) * *incy;
09494 }
09495 jx = kx;
09496 jy = ky;
09497 }
09498
09499
09500
09501 if (lsame_(uplo, "U")) {
09502
09503 if (*incx == 1 && *incy == 1) {
09504 i__1 = *n;
09505 for (j = 1; j <= i__1; ++j) {
09506 if (x[j] != 0.f || y[j] != 0.f) {
09507 temp1 = *alpha * y[j];
09508 temp2 = *alpha * x[j];
09509 i__2 = j;
09510 for (i__ = 1; i__ <= i__2; ++i__) {
09511 a_ref(i__, j) = a_ref(i__, j) + x[i__] * temp1 + y[
09512 i__] * temp2;
09513
09514 }
09515 }
09516
09517 }
09518 } else {
09519 i__1 = *n;
09520 for (j = 1; j <= i__1; ++j) {
09521 if (x[jx] != 0.f || y[jy] != 0.f) {
09522 temp1 = *alpha * y[jy];
09523 temp2 = *alpha * x[jx];
09524 ix = kx;
09525 iy = ky;
09526 i__2 = j;
09527 for (i__ = 1; i__ <= i__2; ++i__) {
09528 a_ref(i__, j) = a_ref(i__, j) + x[ix] * temp1 + y[iy]
09529 * temp2;
09530 ix += *incx;
09531 iy += *incy;
09532
09533 }
09534 }
09535 jx += *incx;
09536 jy += *incy;
09537
09538 }
09539 }
09540 } else {
09541
09542 if (*incx == 1 && *incy == 1) {
09543 i__1 = *n;
09544 for (j = 1; j <= i__1; ++j) {
09545 if (x[j] != 0.f || y[j] != 0.f) {
09546 temp1 = *alpha * y[j];
09547 temp2 = *alpha * x[j];
09548 i__2 = *n;
09549 for (i__ = j; i__ <= i__2; ++i__) {
09550 a_ref(i__, j) = a_ref(i__, j) + x[i__] * temp1 + y[
09551 i__] * temp2;
09552
09553 }
09554 }
09555
09556 }
09557 } else {
09558 i__1 = *n;
09559 for (j = 1; j <= i__1; ++j) {
09560 if (x[jx] != 0.f || y[jy] != 0.f) {
09561 temp1 = *alpha * y[jy];
09562 temp2 = *alpha * x[jx];
09563 ix = jx;
09564 iy = jy;
09565 i__2 = *n;
09566 for (i__ = j; i__ <= i__2; ++i__) {
09567 a_ref(i__, j) = a_ref(i__, j) + x[ix] * temp1 + y[iy]
09568 * temp2;
09569 ix += *incx;
09570 iy += *incy;
09571
09572 }
09573 }
09574 jx += *incx;
09575 jy += *incy;
09576
09577 }
09578 }
09579 }
09580 return 0;
09581
09582 }
09583 #undef a_ref
09584
09585
09586
09587
09588 int ssyr2k_(char *uplo, const char *trans, integer *n, integer *k,
09589 real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta,
09590 real *c__, integer *ldc)
09591 {
09592
09593 integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
09594 i__3;
09595
09596 static integer info;
09597 static real temp1, temp2;
09598 static integer i__, j, l;
09599 extern logical lsame_(const char *, const char *);
09600 static integer nrowa;
09601 static logical upper;
09602 extern int xerbla_(const char *, integer *);
09603 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
09604 #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
09605 #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
09606
09607
09608
09609
09610
09611
09612
09613
09614
09615
09616
09617
09618
09619
09620
09621
09622
09623
09624
09625
09626
09627
09628
09629
09630
09631
09632
09633
09634
09635
09636
09637
09638
09639
09640
09641
09642
09643
09644
09645
09646
09647
09648
09649
09650
09651
09652
09653
09654
09655
09656
09657
09658
09659
09660
09661
09662
09663
09664
09665
09666
09667
09668
09669
09670
09671
09672
09673
09674
09675
09676
09677
09678
09679
09680
09681
09682
09683
09684
09685
09686
09687
09688
09689
09690
09691
09692
09693
09694
09695
09696
09697
09698
09699
09700
09701
09702
09703
09704 a_dim1 = *lda;
09705 a_offset = 1 + a_dim1 * 1;
09706 a -= a_offset;
09707 b_dim1 = *ldb;
09708 b_offset = 1 + b_dim1 * 1;
09709 b -= b_offset;
09710 c_dim1 = *ldc;
09711 c_offset = 1 + c_dim1 * 1;
09712 c__ -= c_offset;
09713
09714 if (lsame_(trans, "N")) {
09715 nrowa = *n;
09716 } else {
09717 nrowa = *k;
09718 }
09719 upper = lsame_(uplo, "U");
09720 info = 0;
09721 if (! upper && ! lsame_(uplo, "L")) {
09722 info = 1;
09723 } else if (! lsame_(trans, "N") && ! lsame_(trans,
09724 "T") && ! lsame_(trans, "C")) {
09725 info = 2;
09726 } else if (*n < 0) {
09727 info = 3;
09728 } else if (*k < 0) {
09729 info = 4;
09730 } else if (*lda < f2cmax(1,nrowa)) {
09731 info = 7;
09732 } else if (*ldb < f2cmax(1,nrowa)) {
09733 info = 9;
09734 } else if (*ldc < f2cmax(1,*n)) {
09735 info = 12;
09736 }
09737 if (info != 0) {
09738 xerbla_("SSYR2K", &info);
09739 return 0;
09740 }
09741
09742 if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
09743 return 0;
09744 }
09745
09746 if (*alpha == 0.f) {
09747 if (upper) {
09748 if (*beta == 0.f) {
09749 i__1 = *n;
09750 for (j = 1; j <= i__1; ++j) {
09751 i__2 = j;
09752 for (i__ = 1; i__ <= i__2; ++i__) {
09753 c___ref(i__, j) = 0.f;
09754
09755 }
09756
09757 }
09758 } else {
09759 i__1 = *n;
09760 for (j = 1; j <= i__1; ++j) {
09761 i__2 = j;
09762 for (i__ = 1; i__ <= i__2; ++i__) {
09763 c___ref(i__, j) = *beta * c___ref(i__, j);
09764
09765 }
09766
09767 }
09768 }
09769 } else {
09770 if (*beta == 0.f) {
09771 i__1 = *n;
09772 for (j = 1; j <= i__1; ++j) {
09773 i__2 = *n;
09774 for (i__ = j; i__ <= i__2; ++i__) {
09775 c___ref(i__, j) = 0.f;
09776
09777 }
09778
09779 }
09780 } else {
09781 i__1 = *n;
09782 for (j = 1; j <= i__1; ++j) {
09783 i__2 = *n;
09784 for (i__ = j; i__ <= i__2; ++i__) {
09785 c___ref(i__, j) = *beta * c___ref(i__, j);
09786
09787 }
09788
09789 }
09790 }
09791 }
09792 return 0;
09793 }
09794
09795 if (lsame_(trans, "N")) {
09796
09797 if (upper) {
09798 i__1 = *n;
09799 for (j = 1; j <= i__1; ++j) {
09800 if (*beta == 0.f) {
09801 i__2 = j;
09802 for (i__ = 1; i__ <= i__2; ++i__) {
09803 c___ref(i__, j) = 0.f;
09804
09805 }
09806 } else if (*beta != 1.f) {
09807 i__2 = j;
09808 for (i__ = 1; i__ <= i__2; ++i__) {
09809 c___ref(i__, j) = *beta * c___ref(i__, j);
09810
09811 }
09812 }
09813 i__2 = *k;
09814 for (l = 1; l <= i__2; ++l) {
09815 if (a_ref(j, l) != 0.f || b_ref(j, l) != 0.f) {
09816 temp1 = *alpha * b_ref(j, l);
09817 temp2 = *alpha * a_ref(j, l);
09818 i__3 = j;
09819 for (i__ = 1; i__ <= i__3; ++i__) {
09820 c___ref(i__, j) = c___ref(i__, j) + a_ref(i__, l)
09821 * temp1 + b_ref(i__, l) * temp2;
09822
09823 }
09824 }
09825
09826 }
09827
09828 }
09829 } else {
09830 i__1 = *n;
09831 for (j = 1; j <= i__1; ++j) {
09832 if (*beta == 0.f) {
09833 i__2 = *n;
09834 for (i__ = j; i__ <= i__2; ++i__) {
09835 c___ref(i__, j) = 0.f;
09836
09837 }
09838 } else if (*beta != 1.f) {
09839 i__2 = *n;
09840 for (i__ = j; i__ <= i__2; ++i__) {
09841 c___ref(i__, j) = *beta * c___ref(i__, j);
09842
09843 }
09844 }
09845 i__2 = *k;
09846 for (l = 1; l <= i__2; ++l) {
09847 if (a_ref(j, l) != 0.f || b_ref(j, l) != 0.f) {
09848 temp1 = *alpha * b_ref(j, l);
09849 temp2 = *alpha * a_ref(j, l);
09850 i__3 = *n;
09851 for (i__ = j; i__ <= i__3; ++i__) {
09852 c___ref(i__, j) = c___ref(i__, j) + a_ref(i__, l)
09853 * temp1 + b_ref(i__, l) * temp2;
09854
09855 }
09856 }
09857
09858 }
09859
09860 }
09861 }
09862 } else {
09863
09864 if (upper) {
09865 i__1 = *n;
09866 for (j = 1; j <= i__1; ++j) {
09867 i__2 = j;
09868 for (i__ = 1; i__ <= i__2; ++i__) {
09869 temp1 = 0.f;
09870 temp2 = 0.f;
09871 i__3 = *k;
09872 for (l = 1; l <= i__3; ++l) {
09873 temp1 += a_ref(l, i__) * b_ref(l, j);
09874 temp2 += b_ref(l, i__) * a_ref(l, j);
09875
09876 }
09877 if (*beta == 0.f) {
09878 c___ref(i__, j) = *alpha * temp1 + *alpha * temp2;
09879 } else {
09880 c___ref(i__, j) = *beta * c___ref(i__, j) + *alpha *
09881 temp1 + *alpha * temp2;
09882 }
09883
09884 }
09885
09886 }
09887 } else {
09888 i__1 = *n;
09889 for (j = 1; j <= i__1; ++j) {
09890 i__2 = *n;
09891 for (i__ = j; i__ <= i__2; ++i__) {
09892 temp1 = 0.f;
09893 temp2 = 0.f;
09894 i__3 = *k;
09895 for (l = 1; l <= i__3; ++l) {
09896 temp1 += a_ref(l, i__) * b_ref(l, j);
09897 temp2 += b_ref(l, i__) * a_ref(l, j);
09898
09899 }
09900 if (*beta == 0.f) {
09901 c___ref(i__, j) = *alpha * temp1 + *alpha * temp2;
09902 } else {
09903 c___ref(i__, j) = *beta * c___ref(i__, j) + *alpha *
09904 temp1 + *alpha * temp2;
09905 }
09906
09907 }
09908
09909 }
09910 }
09911 }
09912 return 0;
09913
09914 }
09915 #undef c___ref
09916 #undef b_ref
09917 #undef a_ref
09918
09919
09920
09921
09922 int ssytd2_(char *uplo, integer *n, real *a, integer *lda,
09923 real *d__, real *e, real *tau, integer *info)
09924 {
09925
09926
09927
09928
09929
09930
09931
09932
09933
09934
09935
09936
09937
09938
09939
09940
09941
09942
09943
09944
09945
09946
09947
09948
09949
09950
09951
09952
09953
09954
09955
09956
09957
09958
09959
09960
09961
09962
09963
09964
09965
09966
09967
09968
09969
09970
09971
09972
09973
09974
09975
09976
09977
09978
09979
09980
09981
09982
09983
09984
09985
09986
09987
09988
09989
09990
09991
09992
09993
09994
09995
09996
09997
09998
09999
10000
10001
10002
10003
10004
10005
10006
10007
10008
10009
10010
10011
10012
10013
10014
10015
10016
10017
10018
10019
10020
10021
10022
10023
10024
10025
10026
10027
10028
10029
10030
10031
10032
10033
10034
10035
10036
10037 static integer c__1 = 1;
10038 static real c_b8 = 0.f;
10039 static real c_b14 = -1.f;
10040
10041
10042 integer a_dim1, a_offset, i__1, i__2, i__3;
10043
10044 static real taui;
10045 extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
10046 static integer i__;
10047 extern int ssyr2_(char *, integer *, real *, real *,
10048 integer *, real *, integer *, real *, integer *);
10049 static real alpha;
10050 extern logical lsame_(const char *, const char *);
10051 static logical upper;
10052 extern int saxpy_(integer *, real *, real *, integer *,
10053 real *, integer *), ssymv_(const char *, integer *, real *, real *,
10054 integer *, real *, integer *, real *, real *, integer *),
10055 xerbla_(const char *, integer *), slarfg_(integer *, real *,
10056 real *, integer *, real *);
10057 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
10058
10059
10060 a_dim1 = *lda;
10061 a_offset = 1 + a_dim1 * 1;
10062 a -= a_offset;
10063 --d__;
10064 --e;
10065 --tau;
10066
10067
10068 *info = 0;
10069 upper = lsame_(uplo, "U");
10070 if (! upper && ! lsame_(uplo, "L")) {
10071 *info = -1;
10072 } else if (*n < 0) {
10073 *info = -2;
10074 } else if (*lda < f2cmax(1,*n)) {
10075 *info = -4;
10076 }
10077 if (*info != 0) {
10078 i__1 = -(*info);
10079 xerbla_("SSYTD2", &i__1);
10080 return 0;
10081 }
10082
10083
10084
10085 if (*n <= 0) {
10086 return 0;
10087 }
10088
10089 if (upper) {
10090
10091
10092
10093 for (i__ = *n - 1; i__ >= 1; --i__) {
10094
10095
10096
10097
10098 slarfg_(&i__, &a_ref(i__, i__ + 1), &a_ref(1, i__ + 1), &c__1, &
10099 taui);
10100 e[i__] = a_ref(i__, i__ + 1);
10101
10102 if (taui != 0.f) {
10103
10104
10105
10106 a_ref(i__, i__ + 1) = 1.f;
10107
10108
10109
10110 ssymv_(uplo, &i__, &taui, &a[a_offset], lda, &a_ref(1, i__ +
10111 1), &c__1, &c_b8, &tau[1], &c__1);
10112
10113
10114
10115 alpha = taui * -.5f * sdot_(&i__, &tau[1], &c__1, &a_ref(1,
10116 i__ + 1), &c__1);
10117 saxpy_(&i__, &alpha, &a_ref(1, i__ + 1), &c__1, &tau[1], &
10118 c__1);
10119
10120
10121
10122
10123 ssyr2_(uplo, &i__, &c_b14, &a_ref(1, i__ + 1), &c__1, &tau[1],
10124 &c__1, &a[a_offset], lda);
10125
10126 a_ref(i__, i__ + 1) = e[i__];
10127 }
10128 d__[i__ + 1] = a_ref(i__ + 1, i__ + 1);
10129 tau[i__] = taui;
10130
10131 }
10132 d__[1] = a_ref(1, 1);
10133 } else {
10134
10135
10136
10137 i__1 = *n - 1;
10138 for (i__ = 1; i__ <= i__1; ++i__) {
10139
10140
10141
10142
10143
10144 i__2 = i__ + 2;
10145 i__3 = *n - i__;
10146 slarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(f2cmin(i__2,*n), i__), &
10147 c__1, &taui);
10148 e[i__] = a_ref(i__ + 1, i__);
10149
10150 if (taui != 0.f) {
10151
10152
10153
10154 a_ref(i__ + 1, i__) = 1.f;
10155
10156
10157
10158 i__2 = *n - i__;
10159 ssymv_(uplo, &i__2, &taui, &a_ref(i__ + 1, i__ + 1), lda, &
10160 a_ref(i__ + 1, i__), &c__1, &c_b8, &tau[i__], &c__1);
10161
10162
10163
10164 i__2 = *n - i__;
10165 alpha = taui * -.5f * sdot_(&i__2, &tau[i__], &c__1, &a_ref(
10166 i__ + 1, i__), &c__1);
10167 i__2 = *n - i__;
10168 saxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &tau[i__],
10169 &c__1);
10170
10171
10172
10173
10174 i__2 = *n - i__;
10175 ssyr2_(uplo, &i__2, &c_b14, &a_ref(i__ + 1, i__), &c__1, &tau[
10176 i__], &c__1, &a_ref(i__ + 1, i__ + 1), lda)
10177 ;
10178
10179 a_ref(i__ + 1, i__) = e[i__];
10180 }
10181 d__[i__] = a_ref(i__, i__);
10182 tau[i__] = taui;
10183
10184 }
10185 d__[*n] = a_ref(*n, *n);
10186 }
10187
10188 return 0;
10189
10190
10191
10192 }
10193
10194 #undef a_ref
10195
10196
10197
10198
10199
10200 int ssytrd_(char *uplo, integer *n, real *a, integer *lda,
10201 real *d__, real *e, real *tau, real *work, integer *lwork, integer *
10202 info)
10203 {
10204
10205
10206
10207
10208
10209
10210
10211
10212
10213
10214
10215
10216
10217
10218
10219
10220
10221
10222
10223
10224
10225
10226
10227
10228
10229
10230
10231
10232
10233
10234
10235
10236
10237
10238
10239
10240
10241
10242
10243
10244
10245
10246
10247
10248
10249
10250
10251
10252
10253
10254
10255
10256
10257
10258
10259
10260
10261
10262
10263
10264
10265
10266
10267
10268
10269
10270
10271
10272
10273
10274
10275
10276
10277
10278
10279
10280
10281
10282
10283
10284
10285
10286
10287
10288
10289
10290
10291
10292
10293
10294
10295
10296
10297
10298
10299
10300
10301
10302
10303
10304
10305
10306
10307
10308
10309
10310
10311
10312
10313
10314
10315
10316
10317
10318
10319
10320
10321
10322
10323
10324
10325
10326
10327
10328 static integer c__1 = 1;
10329 static integer c_n1 = -1;
10330 static integer c__3 = 3;
10331 static integer c__2 = 2;
10332 static real c_b22 = -1.f;
10333 static real c_b23 = 1.f;
10334
10335
10336 integer a_dim1, a_offset, i__1, i__2, i__3;
10337
10338 static integer i__, j;
10339 extern logical lsame_(const char *, const char *);
10340 static integer nbmin, iinfo;
10341 static logical upper;
10342 static integer nb, kk;
10343 extern int ssytd2_(char *, integer *, real *, integer *,
10344 real *, real *, real *, integer *), ssyr2k_(char *, const char *
10345 , integer *, integer *, real *, real *, integer *, real *,
10346 integer *, real *, real *, integer *);
10347 static integer nx;
10348 extern int xerbla_(const char *, integer *);
10349 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
10350 integer *, integer *, ftnlen, ftnlen);
10351 extern int slatrd_(char *, integer *, integer *, real *,
10352 integer *, real *, real *, real *, integer *);
10353 static integer ldwork, lwkopt;
10354 static logical lquery;
10355 static integer iws;
10356 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
10357
10358
10359 a_dim1 = *lda;
10360 a_offset = 1 + a_dim1 * 1;
10361 a -= a_offset;
10362 --d__;
10363 --e;
10364 --tau;
10365 --work;
10366
10367
10368 *info = 0;
10369 upper = lsame_(uplo, "U");
10370 lquery = *lwork == -1;
10371 if (! upper && ! lsame_(uplo, "L")) {
10372 *info = -1;
10373 } else if (*n < 0) {
10374 *info = -2;
10375 } else if (*lda < f2cmax(1,*n)) {
10376 *info = -4;
10377 } else if (*lwork < 1 && ! lquery) {
10378 *info = -9;
10379 }
10380
10381 if (*info == 0) {
10382
10383
10384
10385 nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
10386 (ftnlen)1);
10387 lwkopt = *n * nb;
10388 work[1] = (real) lwkopt;
10389 }
10390
10391 if (*info != 0) {
10392 i__1 = -(*info);
10393 xerbla_("SSYTRD", &i__1);
10394 return 0;
10395 } else if (lquery) {
10396 return 0;
10397 }
10398
10399
10400
10401 if (*n == 0) {
10402 work[1] = 1.f;
10403 return 0;
10404 }
10405
10406 nx = *n;
10407 iws = 1;
10408 if (nb > 1 && nb < *n) {
10409
10410
10411
10412
10413
10414 i__1 = nb, i__2 = ilaenv_(&c__3, "SSYTRD", uplo, n, &c_n1, &c_n1, &
10415 c_n1, (ftnlen)6, (ftnlen)1);
10416 nx = f2cmax(i__1,i__2);
10417 if (nx < *n) {
10418
10419
10420
10421 ldwork = *n;
10422 iws = ldwork * nb;
10423 if (*lwork < iws) {
10424
10425
10426
10427
10428
10429
10430 i__1 = *lwork / ldwork;
10431 nb = f2cmax(i__1,1);
10432 nbmin = ilaenv_(&c__2, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1,
10433 (ftnlen)6, (ftnlen)1);
10434 if (nb < nbmin) {
10435 nx = *n;
10436 }
10437 }
10438 } else {
10439 nx = *n;
10440 }
10441 } else {
10442 nb = 1;
10443 }
10444
10445 if (upper) {
10446
10447
10448
10449
10450 kk = *n - (*n - nx + nb - 1) / nb * nb;
10451 i__1 = kk + 1;
10452 i__2 = -nb;
10453 for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
10454 i__2) {
10455
10456
10457
10458
10459
10460 i__3 = i__ + nb - 1;
10461 slatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], &
10462 work[1], &ldwork);
10463
10464
10465
10466
10467 i__3 = i__ - 1;
10468 ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a_ref(1, i__),
10469 lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda);
10470
10471
10472
10473
10474 i__3 = i__ + nb - 1;
10475 for (j = i__; j <= i__3; ++j) {
10476 a_ref(j - 1, j) = e[j - 1];
10477 d__[j] = a_ref(j, j);
10478
10479 }
10480
10481 }
10482
10483
10484
10485 ssytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo);
10486 } else {
10487
10488
10489
10490 i__2 = *n - nx;
10491 i__1 = nb;
10492 for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
10493
10494
10495
10496
10497
10498 i__3 = *n - i__ + 1;
10499 slatrd_(uplo, &i__3, &nb, &a_ref(i__, i__), lda, &e[i__], &tau[
10500 i__], &work[1], &ldwork);
10501
10502
10503
10504
10505 i__3 = *n - i__ - nb + 1;
10506 ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a_ref(i__ + nb,
10507 i__), lda, &work[nb + 1], &ldwork, &c_b23, &a_ref(i__ +
10508 nb, i__ + nb), lda);
10509
10510
10511
10512
10513 i__3 = i__ + nb - 1;
10514 for (j = i__; j <= i__3; ++j) {
10515 a_ref(j + 1, j) = e[j];
10516 d__[j] = a_ref(j, j);
10517
10518 }
10519
10520 }
10521
10522
10523
10524 i__1 = *n - i__ + 1;
10525 ssytd2_(uplo, &i__1, &a_ref(i__, i__), lda, &d__[i__], &e[i__], &tau[
10526 i__], &iinfo);
10527 }
10528
10529 work[1] = (real) lwkopt;
10530 return 0;
10531
10532
10533
10534 }
10535
10536 #undef a_ref
10537
10538
10539
10540
10541
10542 int strmm_(const char *side, const char *uplo, const char *transa, const char *diag,
10543 integer *m, integer *n, real *alpha, real *a, integer *lda, real *b,
10544 integer *ldb)
10545 {
10546
10547 integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
10548
10549 static integer info;
10550 static real temp;
10551 static integer i__, j, k;
10552 static logical lside;
10553 extern logical lsame_(const char *, const char *);
10554 static integer nrowa;
10555 static logical upper;
10556 extern int xerbla_(const char *, integer *);
10557 static logical nounit;
10558 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
10559 #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
10560
10561
10562
10563
10564
10565
10566
10567
10568
10569
10570
10571
10572
10573
10574
10575
10576
10577
10578
10579
10580
10581
10582
10583
10584
10585
10586
10587
10588
10589
10590
10591
10592
10593
10594
10595
10596
10597
10598
10599
10600
10601
10602
10603
10604
10605
10606
10607
10608
10609
10610
10611
10612
10613
10614
10615
10616
10617
10618
10619
10620
10621
10622
10623
10624
10625
10626
10627
10628
10629
10630
10631
10632
10633
10634
10635
10636
10637
10638
10639
10640
10641
10642
10643
10644 a_dim1 = *lda;
10645 a_offset = 1 + a_dim1 * 1;
10646 a -= a_offset;
10647 b_dim1 = *ldb;
10648 b_offset = 1 + b_dim1 * 1;
10649 b -= b_offset;
10650
10651 lside = lsame_(side, "L");
10652 if (lside) {
10653 nrowa = *m;
10654 } else {
10655 nrowa = *n;
10656 }
10657 nounit = lsame_(diag, "N");
10658 upper = lsame_(uplo, "U");
10659 info = 0;
10660 if (! lside && ! lsame_(side, "R")) {
10661 info = 1;
10662 } else if (! upper && ! lsame_(uplo, "L")) {
10663 info = 2;
10664 } else if (! lsame_(transa, "N") && ! lsame_(transa,
10665 "T") && ! lsame_(transa, "C")) {
10666 info = 3;
10667 } else if (! lsame_(diag, "U") && ! lsame_(diag,
10668 "N")) {
10669 info = 4;
10670 } else if (*m < 0) {
10671 info = 5;
10672 } else if (*n < 0) {
10673 info = 6;
10674 } else if (*lda < f2cmax(1,nrowa)) {
10675 info = 9;
10676 } else if (*ldb < f2cmax(1,*m)) {
10677 info = 11;
10678 }
10679 if (info != 0) {
10680 xerbla_("STRMM ", &info);
10681 return 0;
10682 }
10683
10684 if (*n == 0) {
10685 return 0;
10686 }
10687
10688 if (*alpha == 0.f) {
10689 i__1 = *n;
10690 for (j = 1; j <= i__1; ++j) {
10691 i__2 = *m;
10692 for (i__ = 1; i__ <= i__2; ++i__) {
10693 b_ref(i__, j) = 0.f;
10694
10695 }
10696
10697 }
10698 return 0;
10699 }
10700
10701 if (lside) {
10702 if (lsame_(transa, "N")) {
10703
10704 if (upper) {
10705 i__1 = *n;
10706 for (j = 1; j <= i__1; ++j) {
10707 i__2 = *m;
10708 for (k = 1; k <= i__2; ++k) {
10709 if (b_ref(k, j) != 0.f) {
10710 temp = *alpha * b_ref(k, j);
10711 i__3 = k - 1;
10712 for (i__ = 1; i__ <= i__3; ++i__) {
10713 b_ref(i__, j) = b_ref(i__, j) + temp * a_ref(
10714 i__, k);
10715
10716 }
10717 if (nounit) {
10718 temp *= a_ref(k, k);
10719 }
10720 b_ref(k, j) = temp;
10721 }
10722
10723 }
10724
10725 }
10726 } else {
10727 i__1 = *n;
10728 for (j = 1; j <= i__1; ++j) {
10729 for (k = *m; k >= 1; --k) {
10730 if (b_ref(k, j) != 0.f) {
10731 temp = *alpha * b_ref(k, j);
10732 b_ref(k, j) = temp;
10733 if (nounit) {
10734 b_ref(k, j) = b_ref(k, j) * a_ref(k, k);
10735 }
10736 i__2 = *m;
10737 for (i__ = k + 1; i__ <= i__2; ++i__) {
10738 b_ref(i__, j) = b_ref(i__, j) + temp * a_ref(
10739 i__, k);
10740
10741 }
10742 }
10743
10744 }
10745
10746 }
10747 }
10748 } else {
10749
10750 if (upper) {
10751 i__1 = *n;
10752 for (j = 1; j <= i__1; ++j) {
10753 for (i__ = *m; i__ >= 1; --i__) {
10754 temp = b_ref(i__, j);
10755 if (nounit) {
10756 temp *= a_ref(i__, i__);
10757 }
10758 i__2 = i__ - 1;
10759 for (k = 1; k <= i__2; ++k) {
10760 temp += a_ref(k, i__) * b_ref(k, j);
10761
10762 }
10763 b_ref(i__, j) = *alpha * temp;
10764
10765 }
10766
10767 }
10768 } else {
10769 i__1 = *n;
10770 for (j = 1; j <= i__1; ++j) {
10771 i__2 = *m;
10772 for (i__ = 1; i__ <= i__2; ++i__) {
10773 temp = b_ref(i__, j);
10774 if (nounit) {
10775 temp *= a_ref(i__, i__);
10776 }
10777 i__3 = *m;
10778 for (k = i__ + 1; k <= i__3; ++k) {
10779 temp += a_ref(k, i__) * b_ref(k, j);
10780
10781 }
10782 b_ref(i__, j) = *alpha * temp;
10783
10784 }
10785
10786 }
10787 }
10788 }
10789 } else {
10790 if (lsame_(transa, "N")) {
10791
10792 if (upper) {
10793 for (j = *n; j >= 1; --j) {
10794 temp = *alpha;
10795 if (nounit) {
10796 temp *= a_ref(j, j);
10797 }
10798 i__1 = *m;
10799 for (i__ = 1; i__ <= i__1; ++i__) {
10800 b_ref(i__, j) = temp * b_ref(i__, j);
10801
10802 }
10803 i__1 = j - 1;
10804 for (k = 1; k <= i__1; ++k) {
10805 if (a_ref(k, j) != 0.f) {
10806 temp = *alpha * a_ref(k, j);
10807 i__2 = *m;
10808 for (i__ = 1; i__ <= i__2; ++i__) {
10809 b_ref(i__, j) = b_ref(i__, j) + temp * b_ref(
10810 i__, k);
10811
10812 }
10813 }
10814
10815 }
10816
10817 }
10818 } else {
10819 i__1 = *n;
10820 for (j = 1; j <= i__1; ++j) {
10821 temp = *alpha;
10822 if (nounit) {
10823 temp *= a_ref(j, j);
10824 }
10825 i__2 = *m;
10826 for (i__ = 1; i__ <= i__2; ++i__) {
10827 b_ref(i__, j) = temp * b_ref(i__, j);
10828
10829 }
10830 i__2 = *n;
10831 for (k = j + 1; k <= i__2; ++k) {
10832 if (a_ref(k, j) != 0.f) {
10833 temp = *alpha * a_ref(k, j);
10834 i__3 = *m;
10835 for (i__ = 1; i__ <= i__3; ++i__) {
10836 b_ref(i__, j) = b_ref(i__, j) + temp * b_ref(
10837 i__, k);
10838
10839 }
10840 }
10841
10842 }
10843
10844 }
10845 }
10846 } else {
10847
10848 if (upper) {
10849 i__1 = *n;
10850 for (k = 1; k <= i__1; ++k) {
10851 i__2 = k - 1;
10852 for (j = 1; j <= i__2; ++j) {
10853 if (a_ref(j, k) != 0.f) {
10854 temp = *alpha * a_ref(j, k);
10855 i__3 = *m;
10856 for (i__ = 1; i__ <= i__3; ++i__) {
10857 b_ref(i__, j) = b_ref(i__, j) + temp * b_ref(
10858 i__, k);
10859
10860 }
10861 }
10862
10863 }
10864 temp = *alpha;
10865 if (nounit) {
10866 temp *= a_ref(k, k);
10867 }
10868 if (temp != 1.f) {
10869 i__2 = *m;
10870 for (i__ = 1; i__ <= i__2; ++i__) {
10871 b_ref(i__, k) = temp * b_ref(i__, k);
10872
10873 }
10874 }
10875
10876 }
10877 } else {
10878 for (k = *n; k >= 1; --k) {
10879 i__1 = *n;
10880 for (j = k + 1; j <= i__1; ++j) {
10881 if (a_ref(j, k) != 0.f) {
10882 temp = *alpha * a_ref(j, k);
10883 i__2 = *m;
10884 for (i__ = 1; i__ <= i__2; ++i__) {
10885 b_ref(i__, j) = b_ref(i__, j) + temp * b_ref(
10886 i__, k);
10887
10888 }
10889 }
10890
10891 }
10892 temp = *alpha;
10893 if (nounit) {
10894 temp *= a_ref(k, k);
10895 }
10896 if (temp != 1.f) {
10897 i__1 = *m;
10898 for (i__ = 1; i__ <= i__1; ++i__) {
10899 b_ref(i__, k) = temp * b_ref(i__, k);
10900
10901 }
10902 }
10903
10904 }
10905 }
10906 }
10907 }
10908 return 0;
10909
10910 }
10911 #undef b_ref
10912 #undef a_ref
10913
10914
10915
10916
10917 int strmv_(const char *uplo, const char *trans, const char *diag, integer *n,
10918 real *a, integer *lda, real *x, integer *incx)
10919 {
10920
10921 integer a_dim1, a_offset, i__1, i__2;
10922
10923 static integer info;
10924 static real temp;
10925 static integer i__, j;
10926 extern logical lsame_(const char *, const char *);
10927 static integer ix, jx, kx;
10928 extern int xerbla_(const char *, integer *);
10929 static logical nounit;
10930 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
10931
10932
10933
10934
10935
10936
10937
10938
10939
10940
10941
10942
10943
10944
10945
10946
10947
10948
10949
10950
10951
10952
10953
10954
10955
10956
10957
10958
10959
10960
10961
10962
10963
10964
10965
10966
10967
10968
10969
10970
10971
10972
10973
10974
10975
10976
10977
10978
10979
10980
10981
10982
10983
10984
10985
10986
10987
10988
10989
10990
10991
10992
10993
10994
10995
10996
10997 a_dim1 = *lda;
10998 a_offset = 1 + a_dim1 * 1;
10999 a -= a_offset;
11000 --x;
11001
11002 info = 0;
11003 if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
11004 info = 1;
11005 } else if (! lsame_(trans, "N") && ! lsame_(trans,
11006 "T") && ! lsame_(trans, "C")) {
11007 info = 2;
11008 } else if (! lsame_(diag, "U") && ! lsame_(diag,
11009 "N")) {
11010 info = 3;
11011 } else if (*n < 0) {
11012 info = 4;
11013 } else if (*lda < f2cmax(1,*n)) {
11014 info = 6;
11015 } else if (*incx == 0) {
11016 info = 8;
11017 }
11018 if (info != 0) {
11019 xerbla_("STRMV ", &info);
11020 return 0;
11021 }
11022
11023 if (*n == 0) {
11024 return 0;
11025 }
11026 nounit = lsame_(diag, "N");
11027
11028
11029 if (*incx <= 0) {
11030 kx = 1 - (*n - 1) * *incx;
11031 } else if (*incx != 1) {
11032 kx = 1;
11033 }
11034
11035
11036 if (lsame_(trans, "N")) {
11037
11038 if (lsame_(uplo, "U")) {
11039 if (*incx == 1) {
11040 i__1 = *n;
11041 for (j = 1; j <= i__1; ++j) {
11042 if (x[j] != 0.f) {
11043 temp = x[j];
11044 i__2 = j - 1;
11045 for (i__ = 1; i__ <= i__2; ++i__) {
11046 x[i__] += temp * a_ref(i__, j);
11047
11048 }
11049 if (nounit) {
11050 x[j] *= a_ref(j, j);
11051 }
11052 }
11053
11054 }
11055 } else {
11056 jx = kx;
11057 i__1 = *n;
11058 for (j = 1; j <= i__1; ++j) {
11059 if (x[jx] != 0.f) {
11060 temp = x[jx];
11061 ix = kx;
11062 i__2 = j - 1;
11063 for (i__ = 1; i__ <= i__2; ++i__) {
11064 x[ix] += temp * a_ref(i__, j);
11065 ix += *incx;
11066
11067 }
11068 if (nounit) {
11069 x[jx] *= a_ref(j, j);
11070 }
11071 }
11072 jx += *incx;
11073
11074 }
11075 }
11076 } else {
11077 if (*incx == 1) {
11078 for (j = *n; j >= 1; --j) {
11079 if (x[j] != 0.f) {
11080 temp = x[j];
11081 i__1 = j + 1;
11082 for (i__ = *n; i__ >= i__1; --i__) {
11083 x[i__] += temp * a_ref(i__, j);
11084
11085 }
11086 if (nounit) {
11087 x[j] *= a_ref(j, j);
11088 }
11089 }
11090
11091 }
11092 } else {
11093 kx += (*n - 1) * *incx;
11094 jx = kx;
11095 for (j = *n; j >= 1; --j) {
11096 if (x[jx] != 0.f) {
11097 temp = x[jx];
11098 ix = kx;
11099 i__1 = j + 1;
11100 for (i__ = *n; i__ >= i__1; --i__) {
11101 x[ix] += temp * a_ref(i__, j);
11102 ix -= *incx;
11103
11104 }
11105 if (nounit) {
11106 x[jx] *= a_ref(j, j);
11107 }
11108 }
11109 jx -= *incx;
11110
11111 }
11112 }
11113 }
11114 } else {
11115
11116 if (lsame_(uplo, "U")) {
11117 if (*incx == 1) {
11118 for (j = *n; j >= 1; --j) {
11119 temp = x[j];
11120 if (nounit) {
11121 temp *= a_ref(j, j);
11122 }
11123 for (i__ = j - 1; i__ >= 1; --i__) {
11124 temp += a_ref(i__, j) * x[i__];
11125
11126 }
11127 x[j] = temp;
11128
11129 }
11130 } else {
11131 jx = kx + (*n - 1) * *incx;
11132 for (j = *n; j >= 1; --j) {
11133 temp = x[jx];
11134 ix = jx;
11135 if (nounit) {
11136 temp *= a_ref(j, j);
11137 }
11138 for (i__ = j - 1; i__ >= 1; --i__) {
11139 ix -= *incx;
11140 temp += a_ref(i__, j) * x[ix];
11141
11142 }
11143 x[jx] = temp;
11144 jx -= *incx;
11145
11146 }
11147 }
11148 } else {
11149 if (*incx == 1) {
11150 i__1 = *n;
11151 for (j = 1; j <= i__1; ++j) {
11152 temp = x[j];
11153 if (nounit) {
11154 temp *= a_ref(j, j);
11155 }
11156 i__2 = *n;
11157 for (i__ = j + 1; i__ <= i__2; ++i__) {
11158 temp += a_ref(i__, j) * x[i__];
11159
11160 }
11161 x[j] = temp;
11162
11163 }
11164 } else {
11165 jx = kx;
11166 i__1 = *n;
11167 for (j = 1; j <= i__1; ++j) {
11168 temp = x[jx];
11169 ix = jx;
11170 if (nounit) {
11171 temp *= a_ref(j, j);
11172 }
11173 i__2 = *n;
11174 for (i__ = j + 1; i__ <= i__2; ++i__) {
11175 ix += *incx;
11176 temp += a_ref(i__, j) * x[ix];
11177
11178 }
11179 x[jx] = temp;
11180 jx += *incx;
11181
11182 }
11183 }
11184 }
11185 }
11186 return 0;
11187
11188 }
11189 #undef a_ref
11190
11191
11192
11193
11194 int xerbla_(const char *srname, integer *info)
11195 {
11196
11197
11198
11199
11200
11201
11202
11203
11204
11205
11206
11207
11208
11209
11210
11211
11212
11213
11214
11215
11216
11217
11218
11219
11220
11221
11222
11223
11224
11225
11226 printf("** On entry to %6s, parameter number %2i had an illegal value\n",
11227 srname, *info);
11228
11229
11230
11231 return 0;
11232 }
11233
11234
11235 int sstedc_(const char *compz, integer *n, real *d__, real *e,
11236 real *z__, integer *ldz, real *work, integer *lwork, integer *iwork,
11237 integer *liwork, integer *info)
11238 {
11239
11240
11241
11242
11243
11244
11245
11246
11247
11248
11249
11250
11251
11252
11253
11254
11255
11256
11257
11258
11259
11260
11261
11262
11263
11264
11265
11266
11267
11268
11269
11270
11271
11272
11273
11274
11275
11276
11277
11278
11279
11280
11281
11282
11283
11284
11285
11286
11287
11288
11289
11290
11291
11292
11293
11294
11295
11296
11297
11298
11299
11300
11301
11302
11303
11304
11305
11306
11307
11308
11309
11310
11311
11312
11313
11314
11315
11316
11317
11318
11319
11320
11321
11322
11323
11324
11325
11326
11327
11328
11329
11330
11331
11332
11333
11334
11335
11336
11337
11338
11339
11340
11341
11342
11343
11344
11345
11346
11347
11348
11349
11350
11351
11352
11353 static integer c__2 = 2;
11354 static integer c__9 = 9;
11355 static integer c__0 = 0;
11356 static real c_b18 = 0.f;
11357 static real c_b19 = 1.f;
11358 static integer c__1 = 1;
11359
11360
11361 integer z_dim1, z_offset, i__1, i__2;
11362 real r__1, r__2;
11363
11364
11365 integer pow_ii(integer *, integer *);
11366
11367
11368 static real tiny;
11369 static integer i__, j, k, m;
11370 static real p;
11371 extern logical lsame_(const char *, const char *);
11372 extern int sgemm_(const char *, const char *, integer *, integer *,
11373 integer *, real *, real *, integer *, real *, integer *, real *,
11374 real *, integer *);
11375 static integer lwmin, start;
11376 extern int sswap_(integer *, real *, integer *, real *,
11377 integer *), slaed0_(integer *, integer *, integer *, real *, real
11378 *, real *, integer *, real *, integer *, real *, integer *,
11379 integer *);
11380 static integer ii;
11381 extern doublereal slamch_(const char *);
11382 extern int xerbla_(const char *, integer *);
11383 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
11384 integer *, integer *, ftnlen, ftnlen);
11385 extern int slascl_(const char *, integer *, integer *, real *,
11386 real *, integer *, integer *, real *, integer *, integer *), slacpy_(const char *, integer *, integer *, real *, integer *,
11387 real *, integer *), slaset_(const char *, integer *, integer *,
11388 real *, real *, real *, integer *);
11389 static integer liwmin, icompz;
11390 static real orgnrm;
11391 extern doublereal slanst_(const char *, integer *, real *, real *);
11392 extern int ssterf_(integer *, real *, real *, integer *),
11393 slasrt_(const char *, integer *, real *, integer *);
11394 static logical lquery;
11395 static integer smlsiz;
11396 extern int ssteqr_(const char *, integer *, real *, real *,
11397 real *, integer *, real *, integer *);
11398 static integer storez, strtrw, end, lgn;
11399 static real eps;
11400 #define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
11401
11402
11403 --d__;
11404 --e;
11405 z_dim1 = *ldz;
11406 z_offset = 1 + z_dim1 * 1;
11407 z__ -= z_offset;
11408 --work;
11409 --iwork;
11410
11411
11412 *info = 0;
11413 lquery = *lwork == -1 || *liwork == -1;
11414
11415 if (lsame_(compz, "N")) {
11416 icompz = 0;
11417 } else if (lsame_(compz, "V")) {
11418 icompz = 1;
11419 } else if (lsame_(compz, "I")) {
11420 icompz = 2;
11421 } else {
11422 icompz = -1;
11423 }
11424 if (*n <= 1 || icompz <= 0) {
11425 liwmin = 1;
11426 lwmin = 1;
11427 } else {
11428 lgn = (integer) (log((real) (*n)) / log(2.f));
11429 if (pow_ii(&c__2, &lgn) < *n) {
11430 ++lgn;
11431 }
11432 if (pow_ii(&c__2, &lgn) < *n) {
11433 ++lgn;
11434 }
11435 if (icompz == 1) {
11436
11437 i__1 = *n;
11438 lwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
11439 liwmin = *n * 6 + 6 + *n * 5 * lgn;
11440 } else if (icompz == 2) {
11441
11442 i__1 = *n;
11443 lwmin = (*n << 2) + 1 + i__1 * i__1;
11444 liwmin = *n * 5 + 3;
11445 }
11446 }
11447 if (icompz < 0) {
11448 *info = -1;
11449 } else if (*n < 0) {
11450 *info = -2;
11451 } else if (*ldz < 1 || icompz > 0 && *ldz < f2cmax(1,*n)) {
11452 *info = -6;
11453 } else if (*lwork < lwmin && ! lquery) {
11454 *info = -8;
11455 } else if (*liwork < liwmin && ! lquery) {
11456 *info = -10;
11457 }
11458
11459 if (*info == 0) {
11460 work[1] = (real) lwmin;
11461 iwork[1] = liwmin;
11462 }
11463
11464 if (*info != 0) {
11465 i__1 = -(*info);
11466 xerbla_("SSTEDC", &i__1);
11467 return 0;
11468 } else if (lquery) {
11469 return 0;
11470 }
11471
11472
11473
11474 if (*n == 0) {
11475 return 0;
11476 }
11477 if (*n == 1) {
11478 if (icompz != 0) {
11479 z___ref(1, 1) = 1.f;
11480 }
11481 return 0;
11482 }
11483
11484 smlsiz = ilaenv_(&c__9, "SSTEDC", " ", &c__0, &c__0, &c__0, &c__0, (
11485 ftnlen)6, (ftnlen)1);
11486
11487
11488
11489
11490
11491
11492
11493
11494
11495
11496
11497 if (icompz == 0) {
11498 ssterf_(n, &d__[1], &e[1], info);
11499 return 0;
11500 }
11501
11502
11503
11504
11505 if (*n <= smlsiz) {
11506 if (icompz == 0) {
11507 ssterf_(n, &d__[1], &e[1], info);
11508 return 0;
11509 } else if (icompz == 2) {
11510 ssteqr_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1],
11511 info);
11512 return 0;
11513 } else {
11514 ssteqr_("V", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1],
11515 info);
11516 return 0;
11517 }
11518 }
11519
11520
11521
11522
11523 if (icompz == 1) {
11524 storez = *n * *n + 1;
11525 } else {
11526 storez = 1;
11527 }
11528
11529 if (icompz == 2) {
11530 slaset_("Full", n, n, &c_b18, &c_b19, &z__[z_offset], ldz);
11531 }
11532
11533
11534
11535 orgnrm = slanst_("M", n, &d__[1], &e[1]);
11536 if (orgnrm == 0.f) {
11537 return 0;
11538 }
11539
11540 eps = slamch_("Epsilon");
11541
11542 start = 1;
11543
11544
11545
11546 L10:
11547 if (start <= *n) {
11548
11549
11550
11551
11552
11553
11554 end = start;
11555 L20:
11556 if (end < *n) {
11557 tiny = eps * sqrt((r__1 = d__[end], dabs(r__1))) * sqrt((r__2 =
11558 d__[end + 1], dabs(r__2)));
11559 if ((r__1 = e[end], dabs(r__1)) > tiny) {
11560 ++end;
11561 goto L20;
11562 }
11563 }
11564
11565
11566
11567 m = end - start + 1;
11568 if (m == 1) {
11569 start = end + 1;
11570 goto L10;
11571 }
11572 if (m > smlsiz) {
11573 *info = smlsiz;
11574
11575
11576
11577 orgnrm = slanst_("M", &m, &d__[start], &e[start]);
11578 slascl_("G", &c__0, &c__0, &orgnrm, &c_b19, &m, &c__1, &d__[start]
11579 , &m, info);
11580 i__1 = m - 1;
11581 i__2 = m - 1;
11582 slascl_("G", &c__0, &c__0, &orgnrm, &c_b19, &i__1, &c__1, &e[
11583 start], &i__2, info);
11584
11585 if (icompz == 1) {
11586 strtrw = 1;
11587 } else {
11588 strtrw = start;
11589 }
11590 slaed0_(&icompz, n, &m, &d__[start], &e[start], &z___ref(strtrw,
11591 start), ldz, &work[1], n, &work[storez], &iwork[1], info);
11592 if (*info != 0) {
11593 *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % (m
11594 + 1) + start - 1;
11595 return 0;
11596 }
11597
11598
11599
11600 slascl_("G", &c__0, &c__0, &c_b19, &orgnrm, &m, &c__1, &d__[start]
11601 , &m, info);
11602
11603 } else {
11604 if (icompz == 1) {
11605
11606
11607
11608
11609
11610 ssteqr_("I", &m, &d__[start], &e[start], &work[1], &m, &work[
11611 m * m + 1], info);
11612 slacpy_("A", n, &m, &z___ref(1, start), ldz, &work[storez], n);
11613 sgemm_("N", "N", n, &m, &m, &c_b19, &work[storez], ldz, &work[
11614 1], &m, &c_b18, &z___ref(1, start), ldz);
11615 } else if (icompz == 2) {
11616 ssteqr_("I", &m, &d__[start], &e[start], &z___ref(start,
11617 start), ldz, &work[1], info);
11618 } else {
11619 ssterf_(&m, &d__[start], &e[start], info);
11620 }
11621 if (*info != 0) {
11622 *info = start * (*n + 1) + end;
11623 return 0;
11624 }
11625 }
11626
11627 start = end + 1;
11628 goto L10;
11629 }
11630
11631
11632
11633
11634
11635
11636
11637 if (m != *n) {
11638 if (icompz == 0) {
11639
11640
11641
11642 slasrt_("I", n, &d__[1], info);
11643
11644 } else {
11645
11646
11647
11648 i__1 = *n;
11649 for (ii = 2; ii <= i__1; ++ii) {
11650 i__ = ii - 1;
11651 k = i__;
11652 p = d__[i__];
11653 i__2 = *n;
11654 for (j = ii; j <= i__2; ++j) {
11655 if (d__[j] < p) {
11656 k = j;
11657 p = d__[j];
11658 }
11659
11660 }
11661 if (k != i__) {
11662 d__[k] = d__[i__];
11663 d__[i__] = p;
11664 sswap_(n, &z___ref(1, i__), &c__1, &z___ref(1, k), &c__1);
11665 }
11666
11667 }
11668 }
11669 }
11670
11671 work[1] = (real) lwmin;
11672 iwork[1] = liwmin;
11673
11674 return 0;
11675
11676
11677
11678 }
11679
11680 #undef z___ref
11681
11682
11683 int sstevd_(char *jobz, integer *n, real *d__, real *e, real
11684 *z__, integer *ldz, real *work, integer *lwork, integer *iwork,
11685 integer *liwork, integer *info)
11686 {
11687
11688
11689
11690
11691
11692
11693
11694
11695
11696
11697
11698
11699
11700
11701
11702
11703
11704
11705
11706
11707
11708
11709
11710
11711
11712
11713
11714
11715
11716
11717
11718
11719
11720
11721
11722
11723
11724
11725
11726
11727
11728
11729
11730
11731
11732
11733
11734
11735
11736
11737
11738
11739
11740
11741
11742
11743
11744
11745
11746
11747
11748
11749
11750
11751
11752
11753
11754
11755
11756
11757
11758
11759
11760
11761
11762
11763
11764
11765
11766
11767
11768
11769
11770
11771
11772
11773
11774
11775
11776
11777
11778
11779 static integer c__1 = 1;
11780
11781
11782 integer z_dim1, z_offset, i__1;
11783 real r__1;
11784
11785
11786
11787 static real rmin, rmax, tnrm, sigma;
11788 extern logical lsame_(const char *, const char *);
11789 extern int sscal_(integer *, real *, real *, integer *);
11790 static integer lwmin;
11791 static logical wantz;
11792 static integer iscale;
11793 extern doublereal slamch_(const char *);
11794 static real safmin;
11795 extern int xerbla_(const char *, integer *);
11796 static real bignum;
11797 extern int sstedc_(const char *, integer *, real *, real *,
11798 real *, integer *, real *, integer *, integer *, integer *,
11799 integer *);
11800 static integer liwmin;
11801 extern doublereal slanst_(const char *, integer *, real *, real *);
11802 extern int ssterf_(integer *, real *, real *, integer *);
11803 static real smlnum;
11804 static logical lquery;
11805 static real eps;
11806 #define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
11807
11808
11809 --d__;
11810 --e;
11811 z_dim1 = *ldz;
11812 z_offset = 1 + z_dim1 * 1;
11813 z__ -= z_offset;
11814 --work;
11815 --iwork;
11816
11817
11818 wantz = lsame_(jobz, "V");
11819 lquery = *lwork == -1 || *liwork == -1;
11820
11821 *info = 0;
11822 liwmin = 1;
11823 lwmin = 1;
11824 if (*n > 1 && wantz) {
11825
11826 i__1 = *n;
11827 lwmin = (*n << 2) + 1 + i__1 * i__1;
11828 liwmin = *n * 5 + 3;
11829 }
11830
11831 if (! (wantz || lsame_(jobz, "N"))) {
11832 *info = -1;
11833 } else if (*n < 0) {
11834 *info = -2;
11835 } else if (*ldz < 1 || wantz && *ldz < *n) {
11836 *info = -6;
11837 } else if (*lwork < lwmin && ! lquery) {
11838 *info = -8;
11839 } else if (*liwork < liwmin && ! lquery) {
11840 *info = -10;
11841 }
11842
11843 if (*info == 0) {
11844 work[1] = (real) lwmin;
11845 iwork[1] = liwmin;
11846 }
11847
11848 if (*info != 0) {
11849 i__1 = -(*info);
11850 xerbla_("SSTEVD", &i__1);
11851 return 0;
11852 } else if (lquery) {
11853 return 0;
11854 }
11855
11856
11857
11858 if (*n == 0) {
11859 return 0;
11860 }
11861
11862 if (*n == 1) {
11863 if (wantz) {
11864 z___ref(1, 1) = 1.f;
11865 }
11866 return 0;
11867 }
11868
11869
11870
11871 safmin = slamch_("Safe minimum");
11872 eps = slamch_("Precision");
11873 smlnum = safmin / eps;
11874 bignum = 1.f / smlnum;
11875 rmin = sqrt(smlnum);
11876 rmax = sqrt(bignum);
11877
11878
11879
11880 iscale = 0;
11881 tnrm = slanst_("M", n, &d__[1], &e[1]);
11882 if (tnrm > 0.f && tnrm < rmin) {
11883 iscale = 1;
11884 sigma = rmin / tnrm;
11885 } else if (tnrm > rmax) {
11886 iscale = 1;
11887 sigma = rmax / tnrm;
11888 }
11889 if (iscale == 1) {
11890 sscal_(n, &sigma, &d__[1], &c__1);
11891 i__1 = *n - 1;
11892 sscal_(&i__1, &sigma, &e[1], &c__1);
11893 }
11894
11895
11896
11897
11898 if (! wantz) {
11899 ssterf_(n, &d__[1], &e[1], info);
11900 } else {
11901 sstedc_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], lwork,
11902 &iwork[1], liwork, info);
11903 }
11904
11905
11906
11907 if (iscale == 1) {
11908 r__1 = 1.f / sigma;
11909 sscal_(n, &r__1, &d__[1], &c__1);
11910 }
11911
11912 work[1] = (real) lwmin;
11913 iwork[1] = liwmin;
11914
11915 return 0;
11916
11917
11918
11919 }
11920
11921 #undef z___ref
11922
11923
11924 int slaed0_(integer *icompq, integer *qsiz, integer *n, real
11925 *d__, real *e, real *q, integer *ldq, real *qstore, integer *ldqs,
11926 real *work, integer *iwork, integer *info)
11927 {
11928
11929
11930
11931
11932
11933
11934
11935
11936
11937
11938
11939
11940
11941
11942
11943
11944
11945
11946
11947
11948
11949
11950
11951
11952
11953
11954
11955
11956
11957
11958
11959
11960
11961
11962
11963
11964
11965
11966
11967
11968
11969
11970
11971
11972
11973
11974
11975
11976
11977
11978
11979
11980
11981
11982
11983
11984
11985
11986
11987
11988
11989
11990
11991
11992
11993
11994
11995
11996
11997
11998
11999
12000
12001
12002
12003
12004
12005
12006
12007
12008
12009
12010
12011
12012
12013
12014
12015
12016
12017
12018
12019
12020
12021
12022
12023
12024
12025
12026
12027
12028 static integer c__9 = 9;
12029 static integer c__0 = 0;
12030 static integer c__2 = 2;
12031 static real c_b23 = 1.f;
12032 static real c_b24 = 0.f;
12033 static integer c__1 = 1;
12034
12035
12036 integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
12037 real r__1;
12038
12039
12040 integer pow_ii(integer *, integer *);
12041
12042 static real temp;
12043 static integer curr, i__, j, k;
12044 extern int sgemm_(const char *, const char *, integer *, integer *,
12045 integer *, real *, real *, integer *, real *, integer *, real *,
12046 real *, integer *);
12047 static integer iperm, indxq, iwrem;
12048 extern int scopy_(integer *, real *, integer *, real *,
12049 integer *);
12050 static integer iqptr, tlvls;
12051 extern int slaed1_(integer *, real *, real *, integer *,
12052 integer *, real *, integer *, real *, integer *, integer *),
12053 slaed7_(integer *, integer *, integer *, integer *, integer *,
12054 integer *, real *, real *, integer *, integer *, real *, integer *
12055 , real *, integer *, integer *, integer *, integer *, integer *,
12056 real *, real *, integer *, integer *);
12057 static integer iq, igivcl;
12058 extern int xerbla_(const char *, integer *);
12059 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
12060 integer *, integer *, ftnlen, ftnlen);
12061 static integer igivnm, submat;
12062 extern int slacpy_(const char *, integer *, integer *, real *,
12063 integer *, real *, integer *);
12064 static integer curprb, subpbs, igivpt, curlvl, matsiz, iprmpt, smlsiz;
12065 extern int ssteqr_(const char *, integer *, real *, real *,
12066 real *, integer *, real *, integer *);
12067 static integer lgn, msd2, smm1, spm1, spm2;
12068 #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
12069 #define qstore_ref(a_1,a_2) qstore[(a_2)*qstore_dim1 + a_1]
12070
12071
12072 --d__;
12073 --e;
12074 q_dim1 = *ldq;
12075 q_offset = 1 + q_dim1 * 1;
12076 q -= q_offset;
12077 qstore_dim1 = *ldqs;
12078 qstore_offset = 1 + qstore_dim1 * 1;
12079 qstore -= qstore_offset;
12080 --work;
12081 --iwork;
12082
12083
12084 *info = 0;
12085
12086 if (*icompq < 0 || *icompq > 2) {
12087 *info = -1;
12088 } else if (*icompq == 1 && *qsiz < f2cmax(0,*n)) {
12089 *info = -2;
12090 } else if (*n < 0) {
12091 *info = -3;
12092 } else if (*ldq < f2cmax(1,*n)) {
12093 *info = -7;
12094 } else if (*ldqs < f2cmax(1,*n)) {
12095 *info = -9;
12096 }
12097 if (*info != 0) {
12098 i__1 = -(*info);
12099 xerbla_("SLAED0", &i__1);
12100 return 0;
12101 }
12102
12103
12104
12105 if (*n == 0) {
12106 return 0;
12107 }
12108
12109 smlsiz = ilaenv_(&c__9, "SLAED0", " ", &c__0, &c__0, &c__0, &c__0, (
12110 ftnlen)6, (ftnlen)1);
12111
12112
12113
12114
12115 iwork[1] = *n;
12116 subpbs = 1;
12117 tlvls = 0;
12118 L10:
12119 if (iwork[subpbs] > smlsiz) {
12120 for (j = subpbs; j >= 1; --j) {
12121 iwork[j * 2] = (iwork[j] + 1) / 2;
12122 iwork[(j << 1) - 1] = iwork[j] / 2;
12123
12124 }
12125 ++tlvls;
12126 subpbs <<= 1;
12127 goto L10;
12128 }
12129 i__1 = subpbs;
12130 for (j = 2; j <= i__1; ++j) {
12131 iwork[j] += iwork[j - 1];
12132
12133 }
12134
12135
12136
12137
12138 spm1 = subpbs - 1;
12139 i__1 = spm1;
12140 for (i__ = 1; i__ <= i__1; ++i__) {
12141 submat = iwork[i__] + 1;
12142 smm1 = submat - 1;
12143 d__[smm1] -= (r__1 = e[smm1], dabs(r__1));
12144 d__[submat] -= (r__1 = e[smm1], dabs(r__1));
12145
12146 }
12147
12148 indxq = (*n << 2) + 3;
12149 if (*icompq != 2) {
12150
12151
12152
12153
12154 temp = log((real) (*n)) / log(2.f);
12155 lgn = (integer) temp;
12156 if (pow_ii(&c__2, &lgn) < *n) {
12157 ++lgn;
12158 }
12159 if (pow_ii(&c__2, &lgn) < *n) {
12160 ++lgn;
12161 }
12162 iprmpt = indxq + *n + 1;
12163 iperm = iprmpt + *n * lgn;
12164 iqptr = iperm + *n * lgn;
12165 igivpt = iqptr + *n + 2;
12166 igivcl = igivpt + *n * lgn;
12167
12168 igivnm = 1;
12169 iq = igivnm + (*n << 1) * lgn;
12170
12171 i__1 = *n;
12172 iwrem = iq + i__1 * i__1 + 1;
12173
12174
12175
12176 i__1 = subpbs;
12177 for (i__ = 0; i__ <= i__1; ++i__) {
12178 iwork[iprmpt + i__] = 1;
12179 iwork[igivpt + i__] = 1;
12180
12181 }
12182 iwork[iqptr] = 1;
12183 }
12184
12185
12186
12187
12188 curr = 0;
12189 i__1 = spm1;
12190 for (i__ = 0; i__ <= i__1; ++i__) {
12191 if (i__ == 0) {
12192 submat = 1;
12193 matsiz = iwork[1];
12194 } else {
12195 submat = iwork[i__] + 1;
12196 matsiz = iwork[i__ + 1] - iwork[i__];
12197 }
12198 if (*icompq == 2) {
12199 ssteqr_("I", &matsiz, &d__[submat], &e[submat], &q_ref(submat,
12200 submat), ldq, &work[1], info);
12201 if (*info != 0) {
12202 goto L130;
12203 }
12204 } else {
12205 ssteqr_("I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 +
12206 iwork[iqptr + curr]], &matsiz, &work[1], info);
12207 if (*info != 0) {
12208 goto L130;
12209 }
12210 if (*icompq == 1) {
12211 sgemm_("N", "N", qsiz, &matsiz, &matsiz, &c_b23, &q_ref(1,
12212 submat), ldq, &work[iq - 1 + iwork[iqptr + curr]], &
12213 matsiz, &c_b24, &qstore_ref(1, submat), ldqs);
12214 }
12215
12216 i__2 = matsiz;
12217 iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2;
12218 ++curr;
12219 }
12220 k = 1;
12221 i__2 = iwork[i__ + 1];
12222 for (j = submat; j <= i__2; ++j) {
12223 iwork[indxq + j] = k;
12224 ++k;
12225
12226 }
12227
12228 }
12229
12230
12231
12232
12233
12234
12235 curlvl = 1;
12236 L80:
12237 if (subpbs > 1) {
12238 spm2 = subpbs - 2;
12239 i__1 = spm2;
12240 for (i__ = 0; i__ <= i__1; i__ += 2) {
12241 if (i__ == 0) {
12242 submat = 1;
12243 matsiz = iwork[2];
12244 msd2 = iwork[1];
12245 curprb = 0;
12246 } else {
12247 submat = iwork[i__] + 1;
12248 matsiz = iwork[i__ + 2] - iwork[i__];
12249 msd2 = matsiz / 2;
12250 ++curprb;
12251 }
12252
12253
12254
12255
12256
12257
12258
12259
12260
12261 if (*icompq == 2) {
12262 slaed1_(&matsiz, &d__[submat], &q_ref(submat, submat), ldq, &
12263 iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, &
12264 work[1], &iwork[subpbs + 1], info);
12265 } else {
12266 slaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[
12267 submat], &qstore_ref(1, submat), ldqs, &iwork[indxq +
12268 submat], &e[submat + msd2 - 1], &msd2, &work[iq], &
12269 iwork[iqptr], &iwork[iprmpt], &iwork[iperm], &iwork[
12270 igivpt], &iwork[igivcl], &work[igivnm], &work[iwrem],
12271 &iwork[subpbs + 1], info);
12272 }
12273 if (*info != 0) {
12274 goto L130;
12275 }
12276 iwork[i__ / 2 + 1] = iwork[i__ + 2];
12277
12278 }
12279 subpbs /= 2;
12280 ++curlvl;
12281 goto L80;
12282 }
12283
12284
12285
12286
12287
12288
12289 if (*icompq == 1) {
12290 i__1 = *n;
12291 for (i__ = 1; i__ <= i__1; ++i__) {
12292 j = iwork[indxq + i__];
12293 work[i__] = d__[j];
12294 scopy_(qsiz, &qstore_ref(1, j), &c__1, &q_ref(1, i__), &c__1);
12295
12296 }
12297 scopy_(n, &work[1], &c__1, &d__[1], &c__1);
12298 } else if (*icompq == 2) {
12299 i__1 = *n;
12300 for (i__ = 1; i__ <= i__1; ++i__) {
12301 j = iwork[indxq + i__];
12302 work[i__] = d__[j];
12303 scopy_(n, &q_ref(1, j), &c__1, &work[*n * i__ + 1], &c__1);
12304
12305 }
12306 scopy_(n, &work[1], &c__1, &d__[1], &c__1);
12307 slacpy_("A", n, n, &work[*n + 1], n, &q[q_offset], ldq);
12308 } else {
12309 i__1 = *n;
12310 for (i__ = 1; i__ <= i__1; ++i__) {
12311 j = iwork[indxq + i__];
12312 work[i__] = d__[j];
12313
12314 }
12315 scopy_(n, &work[1], &c__1, &d__[1], &c__1);
12316 }
12317 goto L140;
12318
12319 L130:
12320 *info = submat * (*n + 1) + submat + matsiz - 1;
12321
12322 L140:
12323 return 0;
12324
12325
12326
12327 }
12328
12329 #undef qstore_ref
12330 #undef q_ref
12331
12332
12333
12334 int slaed7_(integer *icompq, integer *n, integer *qsiz,
12335 integer *tlvls, integer *curlvl, integer *curpbm, real *d__, real *q,
12336 integer *ldq, integer *indxq, real *rho, integer *cutpnt, real *
12337 qstore, integer *qptr, integer *prmptr, integer *perm, integer *
12338 givptr, integer *givcol, real *givnum, real *work, integer *iwork,
12339 integer *info)
12340 {
12341
12342
12343
12344
12345
12346
12347
12348
12349
12350
12351
12352
12353
12354
12355
12356
12357
12358
12359
12360
12361
12362
12363
12364
12365
12366
12367
12368
12369
12370
12371
12372
12373
12374
12375
12376
12377
12378
12379
12380
12381
12382
12383
12384
12385
12386
12387
12388
12389
12390
12391
12392
12393
12394
12395
12396
12397
12398
12399
12400
12401
12402
12403
12404
12405
12406
12407
12408
12409
12410
12411
12412
12413
12414
12415
12416
12417
12418
12419
12420
12421
12422
12423
12424
12425
12426
12427
12428
12429
12430
12431
12432
12433
12434
12435
12436
12437
12438
12439
12440
12441
12442
12443
12444
12445
12446
12447
12448
12449
12450
12451
12452
12453
12454
12455
12456
12457
12458
12459
12460
12461
12462
12463
12464
12465
12466
12467
12468
12469
12470
12471
12472
12473
12474
12475
12476
12477
12478
12479
12480
12481
12482
12483
12484
12485
12486
12487
12488
12489
12490
12491
12492 static integer c__2 = 2;
12493 static integer c__1 = 1;
12494 static real c_b10 = 1.f;
12495 static real c_b11 = 0.f;
12496 static integer c_n1 = -1;
12497
12498
12499 integer q_dim1, q_offset, i__1, i__2;
12500
12501 integer pow_ii(integer *, integer *);
12502
12503 static integer indx, curr, i__, k, indxc;
12504 extern int sgemm_(const char *, const char *, integer *, integer *,
12505 integer *, real *, real *, integer *, real *, integer *, real *,
12506 real *, integer *);
12507 static integer indxp, n1, n2;
12508 extern int slaed8_(integer *, integer *, integer *,
12509 integer *, real *, real *, integer *, integer *, real *, integer *
12510 , real *, real *, real *, integer *, real *, integer *, integer *,
12511 integer *, real *, integer *, integer *, integer *), slaed9_(
12512 integer *, integer *, integer *, integer *, real *, real *,
12513 integer *, real *, real *, real *, real *, integer *, integer *),
12514 slaeda_(integer *, integer *, integer *, integer *, integer *,
12515 integer *, integer *, integer *, real *, real *, integer *, real *
12516 , real *, integer *);
12517 static integer idlmda, is, iw, iz;
12518 extern int xerbla_(const char *, integer *), slamrg_(
12519 integer *, integer *, real *, integer *, integer *, integer *);
12520 static integer coltyp, iq2, ptr, ldq2;
12521 #define givcol_ref(a_1,a_2) givcol[(a_2)*2 + a_1]
12522 #define givnum_ref(a_1,a_2) givnum[(a_2)*2 + a_1]
12523
12524
12525 --d__;
12526 q_dim1 = *ldq;
12527 q_offset = 1 + q_dim1 * 1;
12528 q -= q_offset;
12529 --indxq;
12530 --qstore;
12531 --qptr;
12532 --prmptr;
12533 --perm;
12534 --givptr;
12535 givcol -= 3;
12536 givnum -= 3;
12537 --work;
12538 --iwork;
12539
12540
12541 *info = 0;
12542
12543 if (*icompq < 0 || *icompq > 1) {
12544 *info = -1;
12545 } else if (*n < 0) {
12546 *info = -2;
12547 } else if (*icompq == 1 && *qsiz < *n) {
12548 *info = -4;
12549 } else if (*ldq < f2cmax(1,*n)) {
12550 *info = -9;
12551 } else if (f2cmin(1,*n) > *cutpnt || *n < *cutpnt) {
12552 *info = -12;
12553 }
12554 if (*info != 0) {
12555 i__1 = -(*info);
12556 xerbla_("SLAED7", &i__1);
12557 return 0;
12558 }
12559
12560
12561
12562 if (*n == 0) {
12563 return 0;
12564 }
12565
12566
12567
12568
12569
12570 if (*icompq == 1) {
12571 ldq2 = *qsiz;
12572 } else {
12573 ldq2 = *n;
12574 }
12575
12576 iz = 1;
12577 idlmda = iz + *n;
12578 iw = idlmda + *n;
12579 iq2 = iw + *n;
12580 is = iq2 + *n * ldq2;
12581
12582 indx = 1;
12583 indxc = indx + *n;
12584 coltyp = indxc + *n;
12585 indxp = coltyp + *n;
12586
12587
12588
12589
12590 ptr = pow_ii(&c__2, tlvls) + 1;
12591 i__1 = *curlvl - 1;
12592 for (i__ = 1; i__ <= i__1; ++i__) {
12593 i__2 = *tlvls - i__;
12594 ptr += pow_ii(&c__2, &i__2);
12595
12596 }
12597 curr = ptr + *curpbm;
12598 slaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], &
12599 givcol[3], &givnum[3], &qstore[1], &qptr[1], &work[iz], &work[iz
12600 + *n], info);
12601
12602
12603
12604
12605
12606 if (*curlvl == *tlvls) {
12607 qptr[curr] = 1;
12608 prmptr[curr] = 1;
12609 givptr[curr] = 1;
12610 }
12611
12612
12613
12614 slaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho,
12615 cutpnt, &work[iz], &work[idlmda], &work[iq2], &ldq2, &work[iw], &
12616 perm[prmptr[curr]], &givptr[curr + 1], &givcol_ref(1, givptr[curr]
12617 ), &givnum_ref(1, givptr[curr]), &iwork[indxp], &iwork[indx],
12618 info);
12619 prmptr[curr + 1] = prmptr[curr] + *n;
12620 givptr[curr + 1] += givptr[curr];
12621
12622
12623
12624 if (k != 0) {
12625 slaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda],
12626 &work[iw], &qstore[qptr[curr]], &k, info);
12627 if (*info != 0) {
12628 goto L30;
12629 }
12630 if (*icompq == 1) {
12631 sgemm_("N", "N", qsiz, &k, &k, &c_b10, &work[iq2], &ldq2, &qstore[
12632 qptr[curr]], &k, &c_b11, &q[q_offset], ldq);
12633 }
12634
12635 i__1 = k;
12636 qptr[curr + 1] = qptr[curr] + i__1 * i__1;
12637
12638
12639
12640 n1 = k;
12641 n2 = *n - k;
12642 slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
12643 } else {
12644 qptr[curr + 1] = qptr[curr];
12645 i__1 = *n;
12646 for (i__ = 1; i__ <= i__1; ++i__) {
12647 indxq[i__] = i__;
12648
12649 }
12650 }
12651
12652 L30:
12653 return 0;
12654
12655
12656
12657 }
12658
12659 #undef givnum_ref
12660 #undef givcol_ref
12661
12662
12663 int slaed1_(integer *n, real *d__, real *q, integer *ldq,
12664 integer *indxq, real *rho, integer *cutpnt, real *work, integer *
12665 iwork, integer *info)
12666 {
12667
12668
12669
12670
12671
12672
12673
12674
12675
12676
12677
12678
12679
12680
12681
12682
12683
12684
12685
12686
12687
12688
12689
12690
12691
12692
12693
12694
12695
12696
12697
12698
12699
12700
12701
12702
12703
12704
12705
12706
12707
12708
12709
12710
12711
12712
12713
12714
12715
12716
12717
12718
12719
12720
12721
12722
12723
12724
12725
12726
12727
12728
12729
12730
12731
12732
12733
12734
12735
12736
12737
12738
12739
12740
12741
12742
12743
12744
12745
12746
12747
12748
12749
12750
12751
12752
12753
12754
12755
12756
12757
12758
12759
12760
12761
12762
12763
12764 static integer c__1 = 1;
12765 static integer c_n1 = -1;
12766
12767
12768 integer q_dim1, q_offset, i__1, i__2;
12769
12770 static integer indx, i__, k, indxc, indxp;
12771 extern int scopy_(integer *, real *, integer *, real *,
12772 integer *);
12773 static integer n1, n2;
12774 extern int slaed2_(integer *, integer *, integer *, real
12775 *, real *, integer *, integer *, real *, real *, real *, real *,
12776 real *, integer *, integer *, integer *, integer *, integer *),
12777 slaed3_(integer *, integer *, integer *, real *, real *, integer *
12778 , real *, real *, real *, integer *, integer *, real *, real *,
12779 integer *);
12780 static integer idlmda, is, iw, iz;
12781 extern int xerbla_(const char *, integer *), slamrg_(
12782 integer *, integer *, real *, integer *, integer *, integer *);
12783 static integer coltyp, iq2, cpp1;
12784 #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
12785
12786
12787 --d__;
12788 q_dim1 = *ldq;
12789 q_offset = 1 + q_dim1 * 1;
12790 q -= q_offset;
12791 --indxq;
12792 --work;
12793 --iwork;
12794
12795
12796 *info = 0;
12797
12798 if (*n < 0) {
12799 *info = -1;
12800 } else if (*ldq < f2cmax(1,*n)) {
12801 *info = -4;
12802 } else {
12803
12804 i__1 = 1, i__2 = *n / 2;
12805 if (f2cmin(i__1,i__2) > *cutpnt || *n / 2 < *cutpnt) {
12806 *info = -7;
12807 }
12808 }
12809 if (*info != 0) {
12810 i__1 = -(*info);
12811 xerbla_("SLAED1", &i__1);
12812 return 0;
12813 }
12814
12815
12816
12817 if (*n == 0) {
12818 return 0;
12819 }
12820
12821
12822
12823
12824
12825 iz = 1;
12826 idlmda = iz + *n;
12827 iw = idlmda + *n;
12828 iq2 = iw + *n;
12829
12830 indx = 1;
12831 indxc = indx + *n;
12832 coltyp = indxc + *n;
12833 indxp = coltyp + *n;
12834
12835
12836
12837
12838
12839 scopy_(cutpnt, &q_ref(*cutpnt, 1), ldq, &work[iz], &c__1);
12840 cpp1 = *cutpnt + 1;
12841 i__1 = *n - *cutpnt;
12842 scopy_(&i__1, &q_ref(cpp1, cpp1), ldq, &work[iz + *cutpnt], &c__1);
12843
12844
12845
12846 slaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[
12847 iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[
12848 indxc], &iwork[indxp], &iwork[coltyp], info);
12849
12850 if (*info != 0) {
12851 goto L20;
12852 }
12853
12854
12855
12856 if (k != 0) {
12857 is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp +
12858 1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2;
12859 slaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda],
12860 &work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[
12861 is], info);
12862 if (*info != 0) {
12863 goto L20;
12864 }
12865
12866
12867
12868 n1 = k;
12869 n2 = *n - k;
12870 slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
12871 } else {
12872 i__1 = *n;
12873 for (i__ = 1; i__ <= i__1; ++i__) {
12874 indxq[i__] = i__;
12875
12876 }
12877 }
12878
12879 L20:
12880 return 0;
12881
12882
12883
12884 }
12885
12886 #undef q_ref
12887
12888
12889 int slacpy_(const char *uplo, integer *m, integer *n, real *a,
12890 integer *lda, real *b, integer *ldb)
12891 {
12892
12893
12894
12895
12896
12897
12898
12899
12900
12901
12902
12903
12904
12905
12906
12907
12908
12909
12910
12911
12912
12913
12914
12915
12916
12917
12918
12919
12920
12921
12922
12923
12924
12925
12926
12927
12928
12929
12930
12931
12932
12933
12934
12935
12936
12937
12938 integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
12939
12940 static integer i__, j;
12941 extern logical lsame_(const char *, const char *);
12942 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
12943 #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
12944
12945 a_dim1 = *lda;
12946 a_offset = 1 + a_dim1 * 1;
12947 a -= a_offset;
12948 b_dim1 = *ldb;
12949 b_offset = 1 + b_dim1 * 1;
12950 b -= b_offset;
12951
12952
12953 if (lsame_(uplo, "U")) {
12954 i__1 = *n;
12955 for (j = 1; j <= i__1; ++j) {
12956 i__2 = f2cmin(j,*m);
12957 for (i__ = 1; i__ <= i__2; ++i__) {
12958 b_ref(i__, j) = a_ref(i__, j);
12959
12960 }
12961
12962 }
12963 } else if (lsame_(uplo, "L")) {
12964 i__1 = *n;
12965 for (j = 1; j <= i__1; ++j) {
12966 i__2 = *m;
12967 for (i__ = j; i__ <= i__2; ++i__) {
12968 b_ref(i__, j) = a_ref(i__, j);
12969
12970 }
12971
12972 }
12973 } else {
12974 i__1 = *n;
12975 for (j = 1; j <= i__1; ++j) {
12976 i__2 = *m;
12977 for (i__ = 1; i__ <= i__2; ++i__) {
12978 b_ref(i__, j) = a_ref(i__, j);
12979
12980 }
12981
12982 }
12983 }
12984 return 0;
12985
12986
12987
12988 }
12989
12990 #undef b_ref
12991 #undef a_ref
12992
12993
12994 int slamrg_(integer *n1, integer *n2, real *a, integer *
12995 strd1, integer *strd2, integer *index)
12996 {
12997
12998
12999
13000
13001
13002
13003
13004
13005
13006
13007
13008
13009
13010
13011
13012
13013
13014
13015
13016
13017
13018
13019
13020
13021
13022
13023
13024
13025
13026
13027
13028
13029
13030
13031
13032
13033
13034
13035
13036
13037
13038
13039
13040 integer i__1;
13041
13042 static integer i__, ind1, ind2, n1sv, n2sv;
13043
13044 --index;
13045 --a;
13046
13047
13048 n1sv = *n1;
13049 n2sv = *n2;
13050 if (*strd1 > 0) {
13051 ind1 = 1;
13052 } else {
13053 ind1 = *n1;
13054 }
13055 if (*strd2 > 0) {
13056 ind2 = *n1 + 1;
13057 } else {
13058 ind2 = *n1 + *n2;
13059 }
13060 i__ = 1;
13061
13062 L10:
13063 if (n1sv > 0 && n2sv > 0) {
13064 if (a[ind1] <= a[ind2]) {
13065 index[i__] = ind1;
13066 ++i__;
13067 ind1 += *strd1;
13068 --n1sv;
13069 } else {
13070 index[i__] = ind2;
13071 ++i__;
13072 ind2 += *strd2;
13073 --n2sv;
13074 }
13075 goto L10;
13076 }
13077
13078 if (n1sv == 0) {
13079 i__1 = n2sv;
13080 for (n1sv = 1; n1sv <= i__1; ++n1sv) {
13081 index[i__] = ind2;
13082 ++i__;
13083 ind2 += *strd2;
13084
13085 }
13086 } else {
13087
13088 i__1 = n1sv;
13089 for (n2sv = 1; n2sv <= i__1; ++n2sv) {
13090 index[i__] = ind1;
13091 ++i__;
13092 ind1 += *strd1;
13093
13094 }
13095 }
13096
13097 return 0;
13098
13099
13100
13101 }
13102
13103 int slaed8_(integer *icompq, integer *k, integer *n, integer
13104 *qsiz, real *d__, real *q, integer *ldq, integer *indxq, real *rho,
13105 integer *cutpnt, real *z__, real *dlamda, real *q2, integer *ldq2,
13106 real *w, integer *perm, integer *givptr, integer *givcol, real *
13107 givnum, integer *indxp, integer *indx, integer *info)
13108 {
13109
13110
13111
13112
13113
13114
13115
13116
13117
13118
13119
13120
13121
13122
13123
13124
13125
13126
13127
13128
13129
13130
13131
13132
13133
13134
13135
13136
13137
13138
13139
13140
13141
13142
13143
13144
13145
13146
13147
13148
13149
13150
13151
13152
13153
13154
13155
13156
13157
13158
13159
13160
13161
13162
13163
13164
13165
13166
13167
13168
13169
13170
13171
13172
13173
13174
13175
13176
13177
13178
13179
13180
13181
13182
13183
13184
13185
13186
13187
13188
13189
13190
13191
13192
13193
13194
13195
13196
13197
13198
13199
13200
13201
13202
13203
13204
13205
13206
13207
13208
13209
13210
13211
13212
13213
13214
13215
13216
13217
13218
13219
13220
13221
13222
13223
13224
13225
13226
13227
13228
13229
13230
13231
13232
13233
13234
13235
13236
13237
13238
13239
13240
13241
13242
13243
13244
13245
13246 static real c_b3 = -1.f;
13247 static integer c__1 = 1;
13248
13249
13250 integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;
13251 real r__1;
13252
13253
13254
13255 static integer jlam, imax, jmax;
13256 extern int srot_(integer *, real *, integer *, real *,
13257 integer *, real *, real *);
13258 static real c__;
13259 static integer i__, j;
13260 static real s, t;
13261 extern int sscal_(integer *, real *, real *, integer *);
13262 static integer k2;
13263 extern int scopy_(integer *, real *, integer *, real *,
13264 integer *);
13265 static integer n1, n2;
13266 extern doublereal slapy2_(real *, real *);
13267 static integer jp;
13268 extern doublereal slamch_(const char *);
13269 extern int xerbla_(const char *, integer *);
13270 extern integer isamax_(integer *, real *, integer *);
13271 extern int slamrg_(integer *, integer *, real *, integer
13272 *, integer *, integer *), slacpy_(const char *, integer *, integer *,
13273 real *, integer *, real *, integer *);
13274 static integer n1p1;
13275 static real eps, tau, tol;
13276 #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
13277 #define q2_ref(a_1,a_2) q2[(a_2)*q2_dim1 + a_1]
13278 #define givcol_ref(a_1,a_2) givcol[(a_2)*2 + a_1]
13279 #define givnum_ref(a_1,a_2) givnum[(a_2)*2 + a_1]
13280
13281
13282 --d__;
13283 q_dim1 = *ldq;
13284 q_offset = 1 + q_dim1 * 1;
13285 q -= q_offset;
13286 --indxq;
13287 --z__;
13288 --dlamda;
13289 q2_dim1 = *ldq2;
13290 q2_offset = 1 + q2_dim1 * 1;
13291 q2 -= q2_offset;
13292 --w;
13293 --perm;
13294 givcol -= 3;
13295 givnum -= 3;
13296 --indxp;
13297 --indx;
13298
13299
13300 *info = 0;
13301
13302 if (*icompq < 0 || *icompq > 1) {
13303 *info = -1;
13304 } else if (*n < 0) {
13305 *info = -3;
13306 } else if (*icompq == 1 && *qsiz < *n) {
13307 *info = -4;
13308 } else if (*ldq < f2cmax(1,*n)) {
13309 *info = -7;
13310 } else if (*cutpnt < f2cmin(1,*n) || *cutpnt > *n) {
13311 *info = -10;
13312 } else if (*ldq2 < f2cmax(1,*n)) {
13313 *info = -14;
13314 }
13315 if (*info != 0) {
13316 i__1 = -(*info);
13317 xerbla_("SLAED8", &i__1);
13318 return 0;
13319 }
13320
13321
13322
13323 if (*n == 0) {
13324 return 0;
13325 }
13326
13327 n1 = *cutpnt;
13328 n2 = *n - n1;
13329 n1p1 = n1 + 1;
13330
13331 if (*rho < 0.f) {
13332 sscal_(&n2, &c_b3, &z__[n1p1], &c__1);
13333 }
13334
13335
13336
13337 t = 1.f / sqrt(2.f);
13338 i__1 = *n;
13339 for (j = 1; j <= i__1; ++j) {
13340 indx[j] = j;
13341
13342 }
13343 sscal_(n, &t, &z__[1], &c__1);
13344 *rho = (r__1 = *rho * 2.f, dabs(r__1));
13345
13346
13347
13348 i__1 = *n;
13349 for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) {
13350 indxq[i__] += *cutpnt;
13351
13352 }
13353 i__1 = *n;
13354 for (i__ = 1; i__ <= i__1; ++i__) {
13355 dlamda[i__] = d__[indxq[i__]];
13356 w[i__] = z__[indxq[i__]];
13357
13358 }
13359 i__ = 1;
13360 j = *cutpnt + 1;
13361 slamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]);
13362 i__1 = *n;
13363 for (i__ = 1; i__ <= i__1; ++i__) {
13364 d__[i__] = dlamda[indx[i__]];
13365 z__[i__] = w[indx[i__]];
13366
13367 }
13368
13369
13370
13371 imax = isamax_(n, &z__[1], &c__1);
13372 jmax = isamax_(n, &d__[1], &c__1);
13373 eps = slamch_("Epsilon");
13374 tol = eps * 8.f * (r__1 = d__[jmax], dabs(r__1));
13375
13376
13377
13378
13379
13380 if (*rho * (r__1 = z__[imax], dabs(r__1)) <= tol) {
13381 *k = 0;
13382 if (*icompq == 0) {
13383 i__1 = *n;
13384 for (j = 1; j <= i__1; ++j) {
13385 perm[j] = indxq[indx[j]];
13386
13387 }
13388 } else {
13389 i__1 = *n;
13390 for (j = 1; j <= i__1; ++j) {
13391 perm[j] = indxq[indx[j]];
13392 scopy_(qsiz, &q_ref(1, perm[j]), &c__1, &q2_ref(1, j), &c__1);
13393
13394 }
13395 slacpy_("A", qsiz, n, &q2_ref(1, 1), ldq2, &q_ref(1, 1), ldq);
13396 }
13397 return 0;
13398 }
13399
13400
13401
13402
13403
13404
13405
13406 *k = 0;
13407 *givptr = 0;
13408 k2 = *n + 1;
13409 i__1 = *n;
13410 for (j = 1; j <= i__1; ++j) {
13411 if (*rho * (r__1 = z__[j], dabs(r__1)) <= tol) {
13412
13413
13414
13415 --k2;
13416 indxp[k2] = j;
13417 if (j == *n) {
13418 goto L110;
13419 }
13420 } else {
13421 jlam = j;
13422 goto L80;
13423 }
13424
13425 }
13426 L80:
13427 ++j;
13428 if (j > *n) {
13429 goto L100;
13430 }
13431 if (*rho * (r__1 = z__[j], dabs(r__1)) <= tol) {
13432
13433
13434
13435 --k2;
13436 indxp[k2] = j;
13437 } else {
13438
13439
13440
13441 s = z__[jlam];
13442 c__ = z__[j];
13443
13444
13445
13446
13447 tau = slapy2_(&c__, &s);
13448 t = d__[j] - d__[jlam];
13449 c__ /= tau;
13450 s = -s / tau;
13451 if ((r__1 = t * c__ * s, dabs(r__1)) <= tol) {
13452
13453
13454
13455 z__[j] = tau;
13456 z__[jlam] = 0.f;
13457
13458
13459
13460 ++(*givptr);
13461 givcol_ref(1, *givptr) = indxq[indx[jlam]];
13462 givcol_ref(2, *givptr) = indxq[indx[j]];
13463 givnum_ref(1, *givptr) = c__;
13464 givnum_ref(2, *givptr) = s;
13465 if (*icompq == 1) {
13466 srot_(qsiz, &q_ref(1, indxq[indx[jlam]]), &c__1, &q_ref(1,
13467 indxq[indx[j]]), &c__1, &c__, &s);
13468 }
13469 t = d__[jlam] * c__ * c__ + d__[j] * s * s;
13470 d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__;
13471 d__[jlam] = t;
13472 --k2;
13473 i__ = 1;
13474 L90:
13475 if (k2 + i__ <= *n) {
13476 if (d__[jlam] < d__[indxp[k2 + i__]]) {
13477 indxp[k2 + i__ - 1] = indxp[k2 + i__];
13478 indxp[k2 + i__] = jlam;
13479 ++i__;
13480 goto L90;
13481 } else {
13482 indxp[k2 + i__ - 1] = jlam;
13483 }
13484 } else {
13485 indxp[k2 + i__ - 1] = jlam;
13486 }
13487 jlam = j;
13488 } else {
13489 ++(*k);
13490 w[*k] = z__[jlam];
13491 dlamda[*k] = d__[jlam];
13492 indxp[*k] = jlam;
13493 jlam = j;
13494 }
13495 }
13496 goto L80;
13497 L100:
13498
13499
13500
13501 ++(*k);
13502 w[*k] = z__[jlam];
13503 dlamda[*k] = d__[jlam];
13504 indxp[*k] = jlam;
13505
13506 L110:
13507
13508
13509
13510
13511
13512
13513 if (*icompq == 0) {
13514 i__1 = *n;
13515 for (j = 1; j <= i__1; ++j) {
13516 jp = indxp[j];
13517 dlamda[j] = d__[jp];
13518 perm[j] = indxq[indx[jp]];
13519
13520 }
13521 } else {
13522 i__1 = *n;
13523 for (j = 1; j <= i__1; ++j) {
13524 jp = indxp[j];
13525 dlamda[j] = d__[jp];
13526 perm[j] = indxq[indx[jp]];
13527 scopy_(qsiz, &q_ref(1, perm[j]), &c__1, &q2_ref(1, j), &c__1);
13528
13529 }
13530 }
13531
13532
13533
13534
13535 if (*k < *n) {
13536 if (*icompq == 0) {
13537 i__1 = *n - *k;
13538 scopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
13539 } else {
13540 i__1 = *n - *k;
13541 scopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
13542 i__1 = *n - *k;
13543 slacpy_("A", qsiz, &i__1, &q2_ref(1, *k + 1), ldq2, &q_ref(1, *k
13544 + 1), ldq);
13545 }
13546 }
13547
13548 return 0;
13549
13550
13551
13552 }
13553
13554 #undef givnum_ref
13555 #undef givcol_ref
13556 #undef q2_ref
13557 #undef q_ref
13558
13559
13560
13561
13562
13563
13564
13565
13566 static real c_b3 = -1.f;
13567 static integer c__1 = 1;
13568
13569 int slaed2_(integer *k, integer *n, integer *n1, real *d__,
13570 real *q, integer *ldq, integer *indxq, real *rho, real *z__, real *
13571 dlamda, real *w, real *q2, integer *indx, integer *indxc, integer *
13572 indxp, integer *coltyp, integer *info)
13573 {
13574
13575 integer q_dim1, q_offset, i__1, i__2;
13576 real r__1, r__2, r__3, r__4;
13577
13578
13579
13580
13581
13582 static integer imax, jmax, ctot[4];
13583 extern int srot_(integer *, real *, integer *, real *,
13584 integer *, real *, real *);
13585 static real c__;
13586 static integer i__, j;
13587 static real s, t;
13588 extern int sscal_(integer *, real *, real *, integer *);
13589 static integer k2;
13590 extern int scopy_(integer *, real *, integer *, real *,
13591 integer *);
13592 static integer n2;
13593 extern doublereal slapy2_(real *, real *);
13594 static integer ct, nj, pj, js;
13595 extern doublereal slamch_(const char *);
13596 extern int xerbla_(const char *, integer *);
13597 extern integer isamax_(integer *, real *, integer *);
13598 extern int slamrg_(integer *, integer *, real *, integer
13599 *, integer *, integer *), slacpy_(const char *, integer *, integer *,
13600 real *, integer *, real *, integer *);
13601 static integer iq1, iq2, n1p1;
13602 static real eps, tau, tol;
13603 static integer psm[4];
13604
13605
13606 #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
13607
13608
13609
13610
13611
13612
13613
13614
13615
13616
13617
13618
13619
13620
13621
13622
13623
13624
13625
13626
13627
13628
13629
13630
13631
13632
13633
13634
13635
13636
13637
13638
13639
13640
13641
13642
13643
13644
13645
13646
13647
13648
13649
13650
13651
13652
13653
13654
13655
13656
13657
13658
13659
13660
13661
13662
13663
13664
13665
13666
13667
13668
13669
13670
13671
13672
13673
13674
13675
13676
13677
13678
13679
13680
13681
13682
13683
13684
13685
13686
13687
13688
13689
13690
13691
13692
13693
13694
13695
13696
13697
13698
13699
13700
13701
13702
13703
13704
13705
13706
13707
13708
13709
13710
13711
13712
13713
13714
13715
13716
13717
13718
13719
13720
13721
13722
13723
13724
13725
13726
13727
13728
13729
13730
13731 --d__;
13732 q_dim1 = *ldq;
13733 q_offset = 1 + q_dim1 * 1;
13734 q -= q_offset;
13735 --indxq;
13736 --z__;
13737 --dlamda;
13738 --w;
13739 --q2;
13740 --indx;
13741 --indxc;
13742 --indxp;
13743 --coltyp;
13744
13745
13746 *info = 0;
13747
13748 if (*n < 0) {
13749 *info = -2;
13750 } else if (*ldq < f2cmax(1,*n)) {
13751 *info = -6;
13752 } else {
13753
13754 i__1 = 1, i__2 = *n / 2;
13755 if (f2cmin(i__1,i__2) > *n1 || *n / 2 < *n1) {
13756 *info = -3;
13757 }
13758 }
13759 if (*info != 0) {
13760 i__1 = -(*info);
13761 xerbla_("SLAED2", &i__1);
13762 return 0;
13763 }
13764
13765
13766
13767 if (*n == 0) {
13768 return 0;
13769 }
13770
13771 n2 = *n - *n1;
13772 n1p1 = *n1 + 1;
13773
13774 if (*rho < 0.f) {
13775 sscal_(&n2, &c_b3, &z__[n1p1], &c__1);
13776 }
13777
13778
13779
13780
13781 t = 1.f / sqrt(2.f);
13782 sscal_(n, &t, &z__[1], &c__1);
13783
13784
13785
13786 *rho = (r__1 = *rho * 2.f, dabs(r__1));
13787
13788
13789
13790 i__1 = *n;
13791 for (i__ = n1p1; i__ <= i__1; ++i__) {
13792 indxq[i__] += *n1;
13793
13794 }
13795
13796
13797
13798 i__1 = *n;
13799 for (i__ = 1; i__ <= i__1; ++i__) {
13800 dlamda[i__] = d__[indxq[i__]];
13801
13802 }
13803 slamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]);
13804 i__1 = *n;
13805 for (i__ = 1; i__ <= i__1; ++i__) {
13806 indx[i__] = indxq[indxc[i__]];
13807
13808 }
13809
13810
13811
13812 imax = isamax_(n, &z__[1], &c__1);
13813 jmax = isamax_(n, &d__[1], &c__1);
13814 eps = slamch_("Epsilon");
13815
13816 r__3 = (r__1 = d__[jmax], dabs(r__1)), r__4 = (r__2 = z__[imax], dabs(
13817 r__2));
13818 tol = eps * 8.f * df2cmax(r__3,r__4);
13819
13820
13821
13822
13823
13824 if (*rho * (r__1 = z__[imax], dabs(r__1)) <= tol) {
13825 *k = 0;
13826 iq2 = 1;
13827 i__1 = *n;
13828 for (j = 1; j <= i__1; ++j) {
13829 i__ = indx[j];
13830 scopy_(n, &q_ref(1, i__), &c__1, &q2[iq2], &c__1);
13831 dlamda[j] = d__[i__];
13832 iq2 += *n;
13833
13834 }
13835 slacpy_("A", n, n, &q2[1], n, &q[q_offset], ldq);
13836 scopy_(n, &dlamda[1], &c__1, &d__[1], &c__1);
13837 goto L190;
13838 }
13839
13840
13841
13842
13843
13844
13845
13846 i__1 = *n1;
13847 for (i__ = 1; i__ <= i__1; ++i__) {
13848 coltyp[i__] = 1;
13849
13850 }
13851 i__1 = *n;
13852 for (i__ = n1p1; i__ <= i__1; ++i__) {
13853 coltyp[i__] = 3;
13854
13855 }
13856
13857
13858 *k = 0;
13859 k2 = *n + 1;
13860 i__1 = *n;
13861 for (j = 1; j <= i__1; ++j) {
13862 nj = indx[j];
13863 if (*rho * (r__1 = z__[nj], dabs(r__1)) <= tol) {
13864
13865
13866
13867 --k2;
13868 coltyp[nj] = 4;
13869 indxp[k2] = nj;
13870 if (j == *n) {
13871 goto L100;
13872 }
13873 } else {
13874 pj = nj;
13875 goto L80;
13876 }
13877
13878 }
13879 L80:
13880 ++j;
13881 nj = indx[j];
13882 if (j > *n) {
13883 goto L100;
13884 }
13885 if (*rho * (r__1 = z__[nj], dabs(r__1)) <= tol) {
13886
13887
13888
13889 --k2;
13890 coltyp[nj] = 4;
13891 indxp[k2] = nj;
13892 } else {
13893
13894
13895
13896 s = z__[pj];
13897 c__ = z__[nj];
13898
13899
13900
13901
13902 tau = slapy2_(&c__, &s);
13903 t = d__[nj] - d__[pj];
13904 c__ /= tau;
13905 s = -s / tau;
13906 if ((r__1 = t * c__ * s, dabs(r__1)) <= tol) {
13907
13908
13909
13910 z__[nj] = tau;
13911 z__[pj] = 0.f;
13912 if (coltyp[nj] != coltyp[pj]) {
13913 coltyp[nj] = 2;
13914 }
13915 coltyp[pj] = 4;
13916 srot_(n, &q_ref(1, pj), &c__1, &q_ref(1, nj), &c__1, &c__, &s);
13917
13918 r__1 = c__;
13919
13920 r__2 = s;
13921 t = d__[pj] * (r__1 * r__1) + d__[nj] * (r__2 * r__2);
13922
13923 r__1 = s;
13924
13925 r__2 = c__;
13926 d__[nj] = d__[pj] * (r__1 * r__1) + d__[nj] * (r__2 * r__2);
13927 d__[pj] = t;
13928 --k2;
13929 i__ = 1;
13930 L90:
13931 if (k2 + i__ <= *n) {
13932 if (d__[pj] < d__[indxp[k2 + i__]]) {
13933 indxp[k2 + i__ - 1] = indxp[k2 + i__];
13934 indxp[k2 + i__] = pj;
13935 ++i__;
13936 goto L90;
13937 } else {
13938 indxp[k2 + i__ - 1] = pj;
13939 }
13940 } else {
13941 indxp[k2 + i__ - 1] = pj;
13942 }
13943 pj = nj;
13944 } else {
13945 ++(*k);
13946 dlamda[*k] = d__[pj];
13947 w[*k] = z__[pj];
13948 indxp[*k] = pj;
13949 pj = nj;
13950 }
13951 }
13952 goto L80;
13953 L100:
13954
13955
13956
13957 ++(*k);
13958 dlamda[*k] = d__[pj];
13959 w[*k] = z__[pj];
13960 indxp[*k] = pj;
13961
13962
13963
13964
13965
13966
13967 for (j = 1; j <= 4; ++j) {
13968 ctot[j - 1] = 0;
13969
13970 }
13971 i__1 = *n;
13972 for (j = 1; j <= i__1; ++j) {
13973 ct = coltyp[j];
13974 ++ctot[ct - 1];
13975
13976 }
13977
13978
13979
13980 psm[0] = 1;
13981 psm[1] = ctot[0] + 1;
13982 psm[2] = psm[1] + ctot[1];
13983 psm[3] = psm[2] + ctot[2];
13984 *k = *n - ctot[3];
13985
13986
13987
13988
13989
13990 i__1 = *n;
13991 for (j = 1; j <= i__1; ++j) {
13992 js = indxp[j];
13993 ct = coltyp[js];
13994 indx[psm[ct - 1]] = js;
13995 indxc[psm[ct - 1]] = j;
13996 ++psm[ct - 1];
13997
13998 }
13999
14000
14001
14002
14003
14004
14005 i__ = 1;
14006 iq1 = 1;
14007 iq2 = (ctot[0] + ctot[1]) * *n1 + 1;
14008 i__1 = ctot[0];
14009 for (j = 1; j <= i__1; ++j) {
14010 js = indx[i__];
14011 scopy_(n1, &q_ref(1, js), &c__1, &q2[iq1], &c__1);
14012 z__[i__] = d__[js];
14013 ++i__;
14014 iq1 += *n1;
14015
14016 }
14017
14018 i__1 = ctot[1];
14019 for (j = 1; j <= i__1; ++j) {
14020 js = indx[i__];
14021 scopy_(n1, &q_ref(1, js), &c__1, &q2[iq1], &c__1);
14022 scopy_(&n2, &q_ref(*n1 + 1, js), &c__1, &q2[iq2], &c__1);
14023 z__[i__] = d__[js];
14024 ++i__;
14025 iq1 += *n1;
14026 iq2 += n2;
14027
14028 }
14029
14030 i__1 = ctot[2];
14031 for (j = 1; j <= i__1; ++j) {
14032 js = indx[i__];
14033 scopy_(&n2, &q_ref(*n1 + 1, js), &c__1, &q2[iq2], &c__1);
14034 z__[i__] = d__[js];
14035 ++i__;
14036 iq2 += n2;
14037
14038 }
14039
14040 iq1 = iq2;
14041 i__1 = ctot[3];
14042 for (j = 1; j <= i__1; ++j) {
14043 js = indx[i__];
14044 scopy_(n, &q_ref(1, js), &c__1, &q2[iq2], &c__1);
14045 iq2 += *n;
14046 z__[i__] = d__[js];
14047 ++i__;
14048
14049 }
14050
14051
14052
14053
14054 slacpy_("A", n, &ctot[3], &q2[iq1], n, &q_ref(1, *k + 1), ldq);
14055 i__1 = *n - *k;
14056 scopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1);
14057
14058
14059
14060 for (j = 1; j <= 4; ++j) {
14061 coltyp[j] = ctot[j - 1];
14062
14063 }
14064
14065 L190:
14066 return 0;
14067
14068
14069
14070 }
14071
14072 #undef q_ref
14073
14074
14075 int slaed9_(integer *k, integer *kstart, integer *kstop,
14076 integer *n, real *d__, real *q, integer *ldq, real *rho, real *dlamda,
14077 real *w, real *s, integer *lds, integer *info)
14078 {
14079
14080
14081
14082
14083
14084
14085
14086
14087
14088
14089
14090
14091
14092
14093
14094
14095
14096
14097
14098
14099
14100
14101
14102
14103
14104
14105
14106
14107
14108
14109
14110
14111
14112
14113
14114
14115
14116
14117
14118
14119
14120
14121
14122
14123
14124
14125
14126
14127
14128
14129
14130
14131
14132
14133
14134
14135
14136
14137
14138
14139
14140
14141
14142
14143
14144
14145
14146
14147
14148
14149
14150
14151
14152
14153
14154
14155
14156
14157
14158
14159 static integer c__1 = 1;
14160
14161
14162 integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2;
14163 real r__1;
14164
14165
14166
14167 static real temp;
14168 extern doublereal snrm2_(integer *, real *, integer *);
14169 static integer i__, j;
14170 extern int scopy_(integer *, real *, integer *, real *,
14171 integer *), slaed4_(integer *, integer *, real *, real *, real *,
14172 real *, real *, integer *);
14173 extern doublereal slamc3_(real *, real *);
14174 extern int xerbla_(const char *, integer *);
14175 #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
14176 #define s_ref(a_1,a_2) s[(a_2)*s_dim1 + a_1]
14177
14178
14179 --d__;
14180 q_dim1 = *ldq;
14181 q_offset = 1 + q_dim1 * 1;
14182 q -= q_offset;
14183 --dlamda;
14184 --w;
14185 s_dim1 = *lds;
14186 s_offset = 1 + s_dim1 * 1;
14187 s -= s_offset;
14188
14189
14190 *info = 0;
14191
14192 if (*k < 0) {
14193 *info = -1;
14194 } else if (*kstart < 1 || *kstart > f2cmax(1,*k)) {
14195 *info = -2;
14196 } else if (f2cmax(1,*kstop) < *kstart || *kstop > f2cmax(1,*k)) {
14197 *info = -3;
14198 } else if (*n < *k) {
14199 *info = -4;
14200 } else if (*ldq < f2cmax(1,*k)) {
14201 *info = -7;
14202 } else if (*lds < f2cmax(1,*k)) {
14203 *info = -12;
14204 }
14205 if (*info != 0) {
14206 i__1 = -(*info);
14207 xerbla_("SLAED9", &i__1);
14208 return 0;
14209 }
14210
14211
14212
14213 if (*k == 0) {
14214 return 0;
14215 }
14216
14217
14218
14219
14220
14221
14222
14223
14224
14225
14226
14227
14228
14229
14230
14231
14232
14233
14234 i__1 = *n;
14235 for (i__ = 1; i__ <= i__1; ++i__) {
14236 dlamda[i__] = slamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
14237
14238 }
14239
14240 i__1 = *kstop;
14241 for (j = *kstart; j <= i__1; ++j) {
14242 slaed4_(k, &j, &dlamda[1], &w[1], &q_ref(1, j), rho, &d__[j], info);
14243
14244
14245
14246 if (*info != 0) {
14247 goto L120;
14248 }
14249
14250 }
14251
14252 if (*k == 1 || *k == 2) {
14253 i__1 = *k;
14254 for (i__ = 1; i__ <= i__1; ++i__) {
14255 i__2 = *k;
14256 for (j = 1; j <= i__2; ++j) {
14257 s_ref(j, i__) = q_ref(j, i__);
14258
14259 }
14260
14261 }
14262 goto L120;
14263 }
14264
14265
14266
14267 scopy_(k, &w[1], &c__1, &s[s_offset], &c__1);
14268
14269
14270
14271 i__1 = *ldq + 1;
14272 scopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
14273 i__1 = *k;
14274 for (j = 1; j <= i__1; ++j) {
14275 i__2 = j - 1;
14276 for (i__ = 1; i__ <= i__2; ++i__) {
14277 w[i__] *= q_ref(i__, j) / (dlamda[i__] - dlamda[j]);
14278
14279 }
14280 i__2 = *k;
14281 for (i__ = j + 1; i__ <= i__2; ++i__) {
14282 w[i__] *= q_ref(i__, j) / (dlamda[i__] - dlamda[j]);
14283
14284 }
14285
14286 }
14287 i__1 = *k;
14288 for (i__ = 1; i__ <= i__1; ++i__) {
14289 r__1 = sqrt(-w[i__]);
14290 w[i__] = r_sign(&r__1, &s_ref(i__, 1));
14291
14292 }
14293
14294
14295
14296 i__1 = *k;
14297 for (j = 1; j <= i__1; ++j) {
14298 i__2 = *k;
14299 for (i__ = 1; i__ <= i__2; ++i__) {
14300 q_ref(i__, j) = w[i__] / q_ref(i__, j);
14301
14302 }
14303 temp = snrm2_(k, &q_ref(1, j), &c__1);
14304 i__2 = *k;
14305 for (i__ = 1; i__ <= i__2; ++i__) {
14306 s_ref(i__, j) = q_ref(i__, j) / temp;
14307
14308 }
14309
14310 }
14311
14312 L120:
14313 return 0;
14314
14315
14316
14317 }
14318
14319 #undef s_ref
14320 #undef q_ref
14321
14322
14323 integer isamax_(integer *n, real *sx, integer *incx)
14324 {
14325
14326 integer ret_val, i__1;
14327 real r__1;
14328
14329 static real smax;
14330 static integer i__, ix;
14331
14332
14333
14334
14335
14336 --sx;
14337
14338 ret_val = 0;
14339 if (*n < 1 || *incx <= 0) {
14340 return ret_val;
14341 }
14342 ret_val = 1;
14343 if (*n == 1) {
14344 return ret_val;
14345 }
14346 if (*incx == 1) {
14347 goto L20;
14348 }
14349
14350 ix = 1;
14351 smax = dabs(sx[1]);
14352 ix += *incx;
14353 i__1 = *n;
14354 for (i__ = 2; i__ <= i__1; ++i__) {
14355 if ((r__1 = sx[ix], dabs(r__1)) <= smax) {
14356 goto L5;
14357 }
14358 ret_val = i__;
14359 smax = (r__1 = sx[ix], dabs(r__1));
14360 L5:
14361 ix += *incx;
14362
14363 }
14364 return ret_val;
14365
14366 L20:
14367 smax = dabs(sx[1]);
14368 i__1 = *n;
14369 for (i__ = 2; i__ <= i__1; ++i__) {
14370 if ((r__1 = sx[i__], dabs(r__1)) <= smax) {
14371 goto L30;
14372 }
14373 ret_val = i__;
14374 smax = (r__1 = sx[i__], dabs(r__1));
14375 L30:
14376 ;
14377 }
14378 return ret_val;
14379 }
14380
14381 int srot_(integer *n, real *sx, integer *incx, real *sy,
14382 integer *incy, real *c__, real *s)
14383 {
14384
14385 integer i__1;
14386
14387 static integer i__;
14388 static real stemp;
14389 static integer ix, iy;
14390
14391
14392
14393
14394 --sy;
14395 --sx;
14396
14397 if (*n <= 0) {
14398 return 0;
14399 }
14400 if (*incx == 1 && *incy == 1) {
14401 goto L20;
14402 }
14403
14404
14405 ix = 1;
14406 iy = 1;
14407 if (*incx < 0) {
14408 ix = (-(*n) + 1) * *incx + 1;
14409 }
14410 if (*incy < 0) {
14411 iy = (-(*n) + 1) * *incy + 1;
14412 }
14413 i__1 = *n;
14414 for (i__ = 1; i__ <= i__1; ++i__) {
14415 stemp = *c__ * sx[ix] + *s * sy[iy];
14416 sy[iy] = *c__ * sy[iy] - *s * sx[ix];
14417 sx[ix] = stemp;
14418 ix += *incx;
14419 iy += *incy;
14420
14421 }
14422 return 0;
14423
14424 L20:
14425 i__1 = *n;
14426 for (i__ = 1; i__ <= i__1; ++i__) {
14427 stemp = *c__ * sx[i__] + *s * sy[i__];
14428 sy[i__] = *c__ * sy[i__] - *s * sx[i__];
14429 sx[i__] = stemp;
14430
14431 }
14432 return 0;
14433 }
14434
14435 int slaed4_(integer *n, integer *i__, real *d__, real *z__,
14436 real *delta, real *rho, real *dlam, integer *info)
14437 {
14438
14439
14440
14441
14442
14443
14444
14445
14446
14447
14448
14449
14450
14451
14452
14453
14454
14455
14456
14457
14458
14459
14460
14461
14462
14463
14464
14465
14466
14467
14468
14469
14470
14471
14472
14473
14474
14475
14476
14477
14478
14479
14480
14481
14482
14483
14484
14485
14486
14487
14488
14489
14490
14491
14492
14493
14494
14495
14496
14497
14498
14499
14500
14501
14502
14503
14504
14505
14506
14507
14508
14509
14510
14511
14512
14513
14514
14515
14516
14517
14518
14519
14520
14521
14522
14523
14524
14525
14526
14527 integer i__1;
14528 real r__1;
14529
14530
14531
14532 static real dphi, dpsi;
14533 static integer iter;
14534 static real temp, prew, temp1, a, b, c__;
14535 static integer j;
14536 static real w, dltlb, dltub, midpt;
14537 static integer niter;
14538 static logical swtch;
14539 extern int slaed5_(integer *, real *, real *, real *,
14540 real *, real *), slaed6_(integer *, logical *, real *, real *,
14541 real *, real *, real *, integer *);
14542 static logical swtch3;
14543 static integer ii;
14544 static real dw;
14545 extern doublereal slamch_(const char *);
14546 static real zz[3];
14547 static logical orgati;
14548 static real erretm, rhoinv;
14549 static integer ip1;
14550 static real del, eta, phi, eps, tau, psi;
14551 static integer iim1, iip1;
14552
14553 --delta;
14554 --z__;
14555 --d__;
14556
14557
14558 *info = 0;
14559 if (*n == 1) {
14560
14561
14562
14563 *dlam = d__[1] + *rho * z__[1] * z__[1];
14564 delta[1] = 1.f;
14565 return 0;
14566 }
14567 if (*n == 2) {
14568 slaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam);
14569 return 0;
14570 }
14571
14572
14573
14574 eps = slamch_("Epsilon");
14575 rhoinv = 1.f / *rho;
14576
14577
14578
14579 if (*i__ == *n) {
14580
14581
14582
14583 ii = *n - 1;
14584 niter = 1;
14585
14586
14587
14588 midpt = *rho / 2.f;
14589
14590
14591
14592
14593 i__1 = *n;
14594 for (j = 1; j <= i__1; ++j) {
14595 delta[j] = d__[j] - d__[*i__] - midpt;
14596
14597 }
14598
14599 psi = 0.f;
14600 i__1 = *n - 2;
14601 for (j = 1; j <= i__1; ++j) {
14602 psi += z__[j] * z__[j] / delta[j];
14603
14604 }
14605
14606 c__ = rhoinv + psi;
14607 w = c__ + z__[ii] * z__[ii] / delta[ii] + z__[*n] * z__[*n] / delta[*
14608 n];
14609
14610 if (w <= 0.f) {
14611 temp = z__[*n - 1] * z__[*n - 1] / (d__[*n] - d__[*n - 1] + *rho)
14612 + z__[*n] * z__[*n] / *rho;
14613 if (c__ <= temp) {
14614 tau = *rho;
14615 } else {
14616 del = d__[*n] - d__[*n - 1];
14617 a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]
14618 ;
14619 b = z__[*n] * z__[*n] * del;
14620 if (a < 0.f) {
14621 tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a);
14622 } else {
14623 tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f);
14624 }
14625 }
14626
14627
14628
14629
14630 dltlb = midpt;
14631 dltub = *rho;
14632 } else {
14633 del = d__[*n] - d__[*n - 1];
14634 a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n];
14635 b = z__[*n] * z__[*n] * del;
14636 if (a < 0.f) {
14637 tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a);
14638 } else {
14639 tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f);
14640 }
14641
14642
14643
14644
14645 dltlb = 0.f;
14646 dltub = midpt;
14647 }
14648
14649 i__1 = *n;
14650 for (j = 1; j <= i__1; ++j) {
14651 delta[j] = d__[j] - d__[*i__] - tau;
14652
14653 }
14654
14655
14656
14657 dpsi = 0.f;
14658 psi = 0.f;
14659 erretm = 0.f;
14660 i__1 = ii;
14661 for (j = 1; j <= i__1; ++j) {
14662 temp = z__[j] / delta[j];
14663 psi += z__[j] * temp;
14664 dpsi += temp * temp;
14665 erretm += psi;
14666
14667 }
14668 erretm = dabs(erretm);
14669
14670
14671
14672 temp = z__[*n] / delta[*n];
14673 phi = z__[*n] * temp;
14674 dphi = temp * temp;
14675 erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) * (
14676 dpsi + dphi);
14677
14678 w = rhoinv + phi + psi;
14679
14680
14681
14682 if (dabs(w) <= eps * erretm) {
14683 *dlam = d__[*i__] + tau;
14684 goto L250;
14685 }
14686
14687 if (w <= 0.f) {
14688 dltlb = df2cmax(dltlb,tau);
14689 } else {
14690 dltub = df2cmin(dltub,tau);
14691 }
14692
14693
14694
14695 ++niter;
14696 c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi;
14697 a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * (
14698 dpsi + dphi);
14699 b = delta[*n - 1] * delta[*n] * w;
14700 if (c__ < 0.f) {
14701 c__ = dabs(c__);
14702 }
14703 if (c__ == 0.f) {
14704
14705
14706 eta = dltub - tau;
14707 } else if (a >= 0.f) {
14708 eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / (
14709 c__ * 2.f);
14710 } else {
14711 eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(
14712 r__1))));
14713 }
14714
14715
14716
14717
14718
14719
14720
14721 if (w * eta > 0.f) {
14722 eta = -w / (dpsi + dphi);
14723 }
14724 temp = tau + eta;
14725 if (temp > dltub || temp < dltlb) {
14726 if (w < 0.f) {
14727 eta = (dltub - tau) / 2.f;
14728 } else {
14729 eta = (dltlb - tau) / 2.f;
14730 }
14731 }
14732 i__1 = *n;
14733 for (j = 1; j <= i__1; ++j) {
14734 delta[j] -= eta;
14735
14736 }
14737
14738 tau += eta;
14739
14740
14741
14742 dpsi = 0.f;
14743 psi = 0.f;
14744 erretm = 0.f;
14745 i__1 = ii;
14746 for (j = 1; j <= i__1; ++j) {
14747 temp = z__[j] / delta[j];
14748 psi += z__[j] * temp;
14749 dpsi += temp * temp;
14750 erretm += psi;
14751
14752 }
14753 erretm = dabs(erretm);
14754
14755
14756
14757 temp = z__[*n] / delta[*n];
14758 phi = z__[*n] * temp;
14759 dphi = temp * temp;
14760 erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) * (
14761 dpsi + dphi);
14762
14763 w = rhoinv + phi + psi;
14764
14765
14766
14767 iter = niter + 1;
14768
14769 for (niter = iter; niter <= 30; ++niter) {
14770
14771
14772
14773 if (dabs(w) <= eps * erretm) {
14774 *dlam = d__[*i__] + tau;
14775 goto L250;
14776 }
14777
14778 if (w <= 0.f) {
14779 dltlb = df2cmax(dltlb,tau);
14780 } else {
14781 dltub = df2cmin(dltub,tau);
14782 }
14783
14784
14785
14786 c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi;
14787 a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] *
14788 (dpsi + dphi);
14789 b = delta[*n - 1] * delta[*n] * w;
14790 if (a >= 0.f) {
14791 eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) /
14792 (c__ * 2.f);
14793 } else {
14794 eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(
14795 r__1))));
14796 }
14797
14798
14799
14800
14801
14802
14803
14804 if (w * eta > 0.f) {
14805 eta = -w / (dpsi + dphi);
14806 }
14807 temp = tau + eta;
14808 if (temp > dltub || temp < dltlb) {
14809 if (w < 0.f) {
14810 eta = (dltub - tau) / 2.f;
14811 } else {
14812 eta = (dltlb - tau) / 2.f;
14813 }
14814 }
14815 i__1 = *n;
14816 for (j = 1; j <= i__1; ++j) {
14817 delta[j] -= eta;
14818
14819 }
14820
14821 tau += eta;
14822
14823
14824
14825 dpsi = 0.f;
14826 psi = 0.f;
14827 erretm = 0.f;
14828 i__1 = ii;
14829 for (j = 1; j <= i__1; ++j) {
14830 temp = z__[j] / delta[j];
14831 psi += z__[j] * temp;
14832 dpsi += temp * temp;
14833 erretm += psi;
14834
14835 }
14836 erretm = dabs(erretm);
14837
14838
14839
14840 temp = z__[*n] / delta[*n];
14841 phi = z__[*n] * temp;
14842 dphi = temp * temp;
14843 erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) *
14844 (dpsi + dphi);
14845
14846 w = rhoinv + phi + psi;
14847
14848 }
14849
14850
14851
14852 *info = 1;
14853 *dlam = d__[*i__] + tau;
14854 goto L250;
14855
14856
14857
14858 } else {
14859
14860
14861
14862 niter = 1;
14863 ip1 = *i__ + 1;
14864
14865
14866
14867 del = d__[ip1] - d__[*i__];
14868 midpt = del / 2.f;
14869 i__1 = *n;
14870 for (j = 1; j <= i__1; ++j) {
14871 delta[j] = d__[j] - d__[*i__] - midpt;
14872
14873 }
14874
14875 psi = 0.f;
14876 i__1 = *i__ - 1;
14877 for (j = 1; j <= i__1; ++j) {
14878 psi += z__[j] * z__[j] / delta[j];
14879
14880 }
14881
14882 phi = 0.f;
14883 i__1 = *i__ + 2;
14884 for (j = *n; j >= i__1; --j) {
14885 phi += z__[j] * z__[j] / delta[j];
14886
14887 }
14888 c__ = rhoinv + psi + phi;
14889 w = c__ + z__[*i__] * z__[*i__] / delta[*i__] + z__[ip1] * z__[ip1] /
14890 delta[ip1];
14891
14892 if (w > 0.f) {
14893
14894
14895
14896
14897
14898 orgati = TRUE_;
14899 a = c__ * del + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1];
14900 b = z__[*i__] * z__[*i__] * del;
14901 if (a > 0.f) {
14902 tau = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
14903 r__1))));
14904 } else {
14905 tau = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) /
14906 (c__ * 2.f);
14907 }
14908 dltlb = 0.f;
14909 dltub = midpt;
14910 } else {
14911
14912
14913
14914
14915
14916 orgati = FALSE_;
14917 a = c__ * del - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1];
14918 b = z__[ip1] * z__[ip1] * del;
14919 if (a < 0.f) {
14920 tau = b * 2.f / (a - sqrt((r__1 = a * a + b * 4.f * c__, dabs(
14921 r__1))));
14922 } else {
14923 tau = -(a + sqrt((r__1 = a * a + b * 4.f * c__, dabs(r__1))))
14924 / (c__ * 2.f);
14925 }
14926 dltlb = -midpt;
14927 dltub = 0.f;
14928 }
14929
14930 if (orgati) {
14931 i__1 = *n;
14932 for (j = 1; j <= i__1; ++j) {
14933 delta[j] = d__[j] - d__[*i__] - tau;
14934
14935 }
14936 } else {
14937 i__1 = *n;
14938 for (j = 1; j <= i__1; ++j) {
14939 delta[j] = d__[j] - d__[ip1] - tau;
14940
14941 }
14942 }
14943 if (orgati) {
14944 ii = *i__;
14945 } else {
14946 ii = *i__ + 1;
14947 }
14948 iim1 = ii - 1;
14949 iip1 = ii + 1;
14950
14951
14952
14953 dpsi = 0.f;
14954 psi = 0.f;
14955 erretm = 0.f;
14956 i__1 = iim1;
14957 for (j = 1; j <= i__1; ++j) {
14958 temp = z__[j] / delta[j];
14959 psi += z__[j] * temp;
14960 dpsi += temp * temp;
14961 erretm += psi;
14962
14963 }
14964 erretm = dabs(erretm);
14965
14966
14967
14968 dphi = 0.f;
14969 phi = 0.f;
14970 i__1 = iip1;
14971 for (j = *n; j >= i__1; --j) {
14972 temp = z__[j] / delta[j];
14973 phi += z__[j] * temp;
14974 dphi += temp * temp;
14975 erretm += phi;
14976
14977 }
14978
14979 w = rhoinv + phi + psi;
14980
14981
14982
14983
14984 swtch3 = FALSE_;
14985 if (orgati) {
14986 if (w < 0.f) {
14987 swtch3 = TRUE_;
14988 }
14989 } else {
14990 if (w > 0.f) {
14991 swtch3 = TRUE_;
14992 }
14993 }
14994 if (ii == 1 || ii == *n) {
14995 swtch3 = FALSE_;
14996 }
14997
14998 temp = z__[ii] / delta[ii];
14999 dw = dpsi + dphi + temp * temp;
15000 temp = z__[ii] * temp;
15001 w += temp;
15002 erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) * 3.f
15003 + dabs(tau) * dw;
15004
15005
15006
15007 if (dabs(w) <= eps * erretm) {
15008 if (orgati) {
15009 *dlam = d__[*i__] + tau;
15010 } else {
15011 *dlam = d__[ip1] + tau;
15012 }
15013 goto L250;
15014 }
15015
15016 if (w <= 0.f) {
15017 dltlb = df2cmax(dltlb,tau);
15018 } else {
15019 dltub = df2cmin(dltub,tau);
15020 }
15021
15022
15023
15024 ++niter;
15025 if (! swtch3) {
15026 if (orgati) {
15027
15028 r__1 = z__[*i__] / delta[*i__];
15029 c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (r__1 *
15030 r__1);
15031 } else {
15032
15033 r__1 = z__[ip1] / delta[ip1];
15034 c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (r__1 *
15035 r__1);
15036 }
15037 a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] *
15038 dw;
15039 b = delta[*i__] * delta[ip1] * w;
15040 if (c__ == 0.f) {
15041 if (a == 0.f) {
15042 if (orgati) {
15043 a = z__[*i__] * z__[*i__] + delta[ip1] * delta[ip1] *
15044 (dpsi + dphi);
15045 } else {
15046 a = z__[ip1] * z__[ip1] + delta[*i__] * delta[*i__] *
15047 (dpsi + dphi);
15048 }
15049 }
15050 eta = b / a;
15051 } else if (a <= 0.f) {
15052 eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) /
15053 (c__ * 2.f);
15054 } else {
15055 eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
15056 r__1))));
15057 }
15058 } else {
15059
15060
15061
15062 temp = rhoinv + psi + phi;
15063 if (orgati) {
15064 temp1 = z__[iim1] / delta[iim1];
15065 temp1 *= temp1;
15066 c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - d__[
15067 iip1]) * temp1;
15068 zz[0] = z__[iim1] * z__[iim1];
15069 zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + dphi);
15070 } else {
15071 temp1 = z__[iip1] / delta[iip1];
15072 temp1 *= temp1;
15073 c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - d__[
15074 iim1]) * temp1;
15075 zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - temp1));
15076 zz[2] = z__[iip1] * z__[iip1];
15077 }
15078 zz[1] = z__[ii] * z__[ii];
15079 slaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, info);
15080 if (*info != 0) {
15081 goto L250;
15082 }
15083 }
15084
15085
15086
15087
15088
15089
15090
15091 if (w * eta >= 0.f) {
15092 eta = -w / dw;
15093 }
15094 temp = tau + eta;
15095 if (temp > dltub || temp < dltlb) {
15096 if (w < 0.f) {
15097 eta = (dltub - tau) / 2.f;
15098 } else {
15099 eta = (dltlb - tau) / 2.f;
15100 }
15101 }
15102
15103 prew = w;
15104
15105
15106 i__1 = *n;
15107 for (j = 1; j <= i__1; ++j) {
15108 delta[j] -= eta;
15109
15110 }
15111
15112
15113
15114 dpsi = 0.f;
15115 psi = 0.f;
15116 erretm = 0.f;
15117 i__1 = iim1;
15118 for (j = 1; j <= i__1; ++j) {
15119 temp = z__[j] / delta[j];
15120 psi += z__[j] * temp;
15121 dpsi += temp * temp;
15122 erretm += psi;
15123
15124 }
15125 erretm = dabs(erretm);
15126
15127
15128
15129 dphi = 0.f;
15130 phi = 0.f;
15131 i__1 = iip1;
15132 for (j = *n; j >= i__1; --j) {
15133 temp = z__[j] / delta[j];
15134 phi += z__[j] * temp;
15135 dphi += temp * temp;
15136 erretm += phi;
15137
15138 }
15139
15140 temp = z__[ii] / delta[ii];
15141 dw = dpsi + dphi + temp * temp;
15142 temp = z__[ii] * temp;
15143 w = rhoinv + phi + psi + temp;
15144 erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) * 3.f
15145 + (r__1 = tau + eta, dabs(r__1)) * dw;
15146
15147 swtch = FALSE_;
15148 if (orgati) {
15149 if (-w > dabs(prew) / 10.f) {
15150 swtch = TRUE_;
15151 }
15152 } else {
15153 if (w > dabs(prew) / 10.f) {
15154 swtch = TRUE_;
15155 }
15156 }
15157
15158 tau += eta;
15159
15160
15161
15162 iter = niter + 1;
15163
15164 for (niter = iter; niter <= 30; ++niter) {
15165
15166
15167
15168 if (dabs(w) <= eps * erretm) {
15169 if (orgati) {
15170 *dlam = d__[*i__] + tau;
15171 } else {
15172 *dlam = d__[ip1] + tau;
15173 }
15174 goto L250;
15175 }
15176
15177 if (w <= 0.f) {
15178 dltlb = df2cmax(dltlb,tau);
15179 } else {
15180 dltub = df2cmin(dltub,tau);
15181 }
15182
15183
15184
15185 if (! swtch3) {
15186 if (! swtch) {
15187 if (orgati) {
15188
15189 r__1 = z__[*i__] / delta[*i__];
15190 c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (
15191 r__1 * r__1);
15192 } else {
15193
15194 r__1 = z__[ip1] / delta[ip1];
15195 c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) *
15196 (r__1 * r__1);
15197 }
15198 } else {
15199 temp = z__[ii] / delta[ii];
15200 if (orgati) {
15201 dpsi += temp * temp;
15202 } else {
15203 dphi += temp * temp;
15204 }
15205 c__ = w - delta[*i__] * dpsi - delta[ip1] * dphi;
15206 }
15207 a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1]
15208 * dw;
15209 b = delta[*i__] * delta[ip1] * w;
15210 if (c__ == 0.f) {
15211 if (a == 0.f) {
15212 if (! swtch) {
15213 if (orgati) {
15214 a = z__[*i__] * z__[*i__] + delta[ip1] *
15215 delta[ip1] * (dpsi + dphi);
15216 } else {
15217 a = z__[ip1] * z__[ip1] + delta[*i__] * delta[
15218 *i__] * (dpsi + dphi);
15219 }
15220 } else {
15221 a = delta[*i__] * delta[*i__] * dpsi + delta[ip1]
15222 * delta[ip1] * dphi;
15223 }
15224 }
15225 eta = b / a;
15226 } else if (a <= 0.f) {
15227 eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1))
15228 )) / (c__ * 2.f);
15229 } else {
15230 eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__,
15231 dabs(r__1))));
15232 }
15233 } else {
15234
15235
15236
15237 temp = rhoinv + psi + phi;
15238 if (swtch) {
15239 c__ = temp - delta[iim1] * dpsi - delta[iip1] * dphi;
15240 zz[0] = delta[iim1] * delta[iim1] * dpsi;
15241 zz[2] = delta[iip1] * delta[iip1] * dphi;
15242 } else {
15243 if (orgati) {
15244 temp1 = z__[iim1] / delta[iim1];
15245 temp1 *= temp1;
15246 c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1]
15247 - d__[iip1]) * temp1;
15248 zz[0] = z__[iim1] * z__[iim1];
15249 zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 +
15250 dphi);
15251 } else {
15252 temp1 = z__[iip1] / delta[iip1];
15253 temp1 *= temp1;
15254 c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1]
15255 - d__[iim1]) * temp1;
15256 zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi -
15257 temp1));
15258 zz[2] = z__[iip1] * z__[iip1];
15259 }
15260 }
15261 slaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta,
15262 info);
15263 if (*info != 0) {
15264 goto L250;
15265 }
15266 }
15267
15268
15269
15270
15271
15272
15273
15274 if (w * eta >= 0.f) {
15275 eta = -w / dw;
15276 }
15277 temp = tau + eta;
15278 if (temp > dltub || temp < dltlb) {
15279 if (w < 0.f) {
15280 eta = (dltub - tau) / 2.f;
15281 } else {
15282 eta = (dltlb - tau) / 2.f;
15283 }
15284 }
15285
15286 i__1 = *n;
15287 for (j = 1; j <= i__1; ++j) {
15288 delta[j] -= eta;
15289
15290 }
15291
15292 tau += eta;
15293 prew = w;
15294
15295
15296
15297 dpsi = 0.f;
15298 psi = 0.f;
15299 erretm = 0.f;
15300 i__1 = iim1;
15301 for (j = 1; j <= i__1; ++j) {
15302 temp = z__[j] / delta[j];
15303 psi += z__[j] * temp;
15304 dpsi += temp * temp;
15305 erretm += psi;
15306
15307 }
15308 erretm = dabs(erretm);
15309
15310
15311
15312 dphi = 0.f;
15313 phi = 0.f;
15314 i__1 = iip1;
15315 for (j = *n; j >= i__1; --j) {
15316 temp = z__[j] / delta[j];
15317 phi += z__[j] * temp;
15318 dphi += temp * temp;
15319 erretm += phi;
15320
15321 }
15322
15323 temp = z__[ii] / delta[ii];
15324 dw = dpsi + dphi + temp * temp;
15325 temp = z__[ii] * temp;
15326 w = rhoinv + phi + psi + temp;
15327 erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) *
15328 3.f + dabs(tau) * dw;
15329 if (w * prew > 0.f && dabs(w) > dabs(prew) / 10.f) {
15330 swtch = ! swtch;
15331 }
15332
15333
15334 }
15335
15336
15337
15338 *info = 1;
15339 if (orgati) {
15340 *dlam = d__[*i__] + tau;
15341 } else {
15342 *dlam = d__[ip1] + tau;
15343 }
15344
15345 }
15346
15347 L250:
15348
15349 return 0;
15350
15351
15352
15353 }
15354
15355 int slaeda_(integer *n, integer *tlvls, integer *curlvl,
15356 integer *curpbm, integer *prmptr, integer *perm, integer *givptr,
15357 integer *givcol, real *givnum, real *q, integer *qptr, real *z__,
15358 real *ztemp, integer *info)
15359 {
15360
15361
15362
15363
15364
15365
15366
15367
15368
15369
15370
15371
15372
15373
15374
15375
15376
15377
15378
15379
15380
15381
15382
15383
15384
15385
15386
15387
15388
15389
15390
15391
15392
15393
15394
15395
15396
15397
15398
15399
15400
15401
15402
15403
15404
15405
15406
15407
15408
15409
15410
15411
15412
15413
15414
15415
15416
15417
15418
15419
15420
15421
15422
15423
15424
15425
15426
15427
15428
15429
15430
15431
15432
15433
15434
15435
15436
15437
15438
15439
15440
15441
15442
15443
15444
15445
15446
15447
15448 static integer c__2 = 2;
15449 static integer c__1 = 1;
15450 static real c_b24 = 1.f;
15451 static real c_b26 = 0.f;
15452
15453
15454 integer i__1, i__2, i__3;
15455
15456 integer pow_ii(integer *, integer *);
15457
15458
15459 static integer curr;
15460 extern int srot_(integer *, real *, integer *, real *,
15461 integer *, real *, real *);
15462 static integer bsiz1, bsiz2, psiz1, psiz2, i__, k, zptr1;
15463 extern int sgemv_(const char *, integer *, integer *, real *,
15464 real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *),
15465 xerbla_(const char *, integer *);
15466 static integer mid, ptr;
15467 #define givcol_ref(a_1,a_2) givcol[(a_2)*2 + a_1]
15468 #define givnum_ref(a_1,a_2) givnum[(a_2)*2 + a_1]
15469
15470
15471 --ztemp;
15472 --z__;
15473 --qptr;
15474 --q;
15475 givnum -= 3;
15476 givcol -= 3;
15477 --givptr;
15478 --perm;
15479 --prmptr;
15480
15481
15482 *info = 0;
15483
15484 if (*n < 0) {
15485 *info = -1;
15486 }
15487 if (*info != 0) {
15488 i__1 = -(*info);
15489 xerbla_("SLAEDA", &i__1);
15490 return 0;
15491 }
15492
15493
15494
15495 if (*n == 0) {
15496 return 0;
15497 }
15498
15499
15500
15501 mid = *n / 2 + 1;
15502
15503
15504
15505 ptr = 1;
15506
15507
15508
15509
15510 i__1 = *curlvl - 1;
15511 curr = ptr + *curpbm * pow_ii(&c__2, curlvl) + pow_ii(&c__2, &i__1) - 1;
15512
15513
15514
15515
15516
15517 bsiz1 = (integer) (sqrt((real) (qptr[curr + 1] - qptr[curr])) + .5f);
15518 bsiz2 = (integer) (sqrt((real) (qptr[curr + 2] - qptr[curr + 1])) + .5f);
15519 i__1 = mid - bsiz1 - 1;
15520 for (k = 1; k <= i__1; ++k) {
15521 z__[k] = 0.f;
15522
15523 }
15524 scopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], &
15525 c__1);
15526 scopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1);
15527 i__1 = *n;
15528 for (k = mid + bsiz2; k <= i__1; ++k) {
15529 z__[k] = 0.f;
15530
15531 }
15532
15533
15534
15535
15536
15537 ptr = pow_ii(&c__2, tlvls) + 1;
15538 i__1 = *curlvl - 1;
15539 for (k = 1; k <= i__1; ++k) {
15540 i__2 = *curlvl - k;
15541 i__3 = *curlvl - k - 1;
15542 curr = ptr + *curpbm * pow_ii(&c__2, &i__2) + pow_ii(&c__2, &i__3) -
15543 1;
15544 psiz1 = prmptr[curr + 1] - prmptr[curr];
15545 psiz2 = prmptr[curr + 2] - prmptr[curr + 1];
15546 zptr1 = mid - psiz1;
15547
15548
15549
15550 i__2 = givptr[curr + 1] - 1;
15551 for (i__ = givptr[curr]; i__ <= i__2; ++i__) {
15552 srot_(&c__1, &z__[zptr1 + givcol_ref(1, i__) - 1], &c__1, &z__[
15553 zptr1 + givcol_ref(2, i__) - 1], &c__1, &givnum_ref(1,
15554 i__), &givnum_ref(2, i__));
15555
15556 }
15557 i__2 = givptr[curr + 2] - 1;
15558 for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) {
15559 srot_(&c__1, &z__[mid - 1 + givcol_ref(1, i__)], &c__1, &z__[mid
15560 - 1 + givcol_ref(2, i__)], &c__1, &givnum_ref(1, i__), &
15561 givnum_ref(2, i__));
15562
15563 }
15564 psiz1 = prmptr[curr + 1] - prmptr[curr];
15565 psiz2 = prmptr[curr + 2] - prmptr[curr + 1];
15566 i__2 = psiz1 - 1;
15567 for (i__ = 0; i__ <= i__2; ++i__) {
15568 ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1];
15569
15570 }
15571 i__2 = psiz2 - 1;
15572 for (i__ = 0; i__ <= i__2; ++i__) {
15573 ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] -
15574 1];
15575
15576 }
15577
15578
15579
15580
15581
15582
15583
15584 bsiz1 = (integer) (sqrt((real) (qptr[curr + 1] - qptr[curr])) + .5f);
15585 bsiz2 = (integer) (sqrt((real) (qptr[curr + 2] - qptr[curr + 1])) +
15586 .5f);
15587 if (bsiz1 > 0) {
15588 sgemv_("T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, &
15589 ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1);
15590 }
15591 i__2 = psiz1 - bsiz1;
15592 scopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1);
15593 if (bsiz2 > 0) {
15594 sgemv_("T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, &
15595 ztemp[psiz1 + 1], &c__1, &c_b26, &z__[mid], &c__1);
15596 }
15597 i__2 = psiz2 - bsiz2;
15598 scopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], &
15599 c__1);
15600
15601 i__2 = *tlvls - k;
15602 ptr += pow_ii(&c__2, &i__2);
15603
15604 }
15605
15606 return 0;
15607
15608
15609
15610 }
15611
15612 #undef givnum_ref
15613 #undef givcol_ref
15614
15615
15616 int slaed3_(integer *k, integer *n, integer *n1, real *d__,
15617 real *q, integer *ldq, real *rho, real *dlamda, real *q2, integer *
15618 indx, integer *ctot, real *w, real *s, integer *info)
15619 {
15620
15621
15622
15623
15624
15625
15626
15627
15628
15629
15630
15631
15632
15633
15634
15635
15636
15637
15638
15639
15640
15641
15642
15643
15644
15645
15646
15647
15648
15649
15650
15651
15652
15653
15654
15655
15656
15657
15658
15659
15660
15661
15662
15663
15664
15665
15666
15667
15668
15669
15670
15671
15672
15673
15674
15675
15676
15677
15678
15679
15680
15681
15682
15683
15684
15685
15686
15687
15688
15689
15690
15691
15692
15693
15694
15695
15696
15697
15698
15699
15700
15701
15702
15703
15704
15705
15706
15707
15708
15709
15710
15711
15712
15713
15714
15715
15716
15717
15718
15719
15720
15721
15722
15723
15724
15725
15726
15727
15728
15729 static integer c__1 = 1;
15730 static real c_b22 = 1.f;
15731 static real c_b23 = 0.f;
15732
15733
15734 integer q_dim1, q_offset, i__1, i__2;
15735 real r__1;
15736
15737
15738
15739 static real temp;
15740 extern doublereal snrm2_(integer *, real *, integer *);
15741 static integer i__, j;
15742 extern int sgemm_(const char *, const char *, integer *, integer *,
15743 integer *, real *, real *, integer *, real *, integer *, real *,
15744 real *, integer *), scopy_(integer *, real *,
15745 integer *, real *, integer *);
15746 static integer n2;
15747 extern int slaed4_(integer *, integer *, real *, real *,
15748 real *, real *, real *, integer *);
15749 extern doublereal slamc3_(real *, real *);
15750 static integer n12, ii, n23;
15751 extern int xerbla_(const char *, integer *), slacpy_(
15752 const char *, integer *, integer *, real *, integer *, real *, integer *
15753 ), slaset_(const char *, integer *, integer *, real *, real *,
15754 real *, integer *);
15755 static integer iq2;
15756 #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
15757
15758
15759 --d__;
15760 q_dim1 = *ldq;
15761 q_offset = 1 + q_dim1 * 1;
15762 q -= q_offset;
15763 --dlamda;
15764 --q2;
15765 --indx;
15766 --ctot;
15767 --w;
15768 --s;
15769
15770
15771 *info = 0;
15772
15773 if (*k < 0) {
15774 *info = -1;
15775 } else if (*n < *k) {
15776 *info = -2;
15777 } else if (*ldq < f2cmax(1,*n)) {
15778 *info = -6;
15779 }
15780 if (*info != 0) {
15781 i__1 = -(*info);
15782 xerbla_("SLAED3", &i__1);
15783 return 0;
15784 }
15785
15786
15787
15788 if (*k == 0) {
15789 return 0;
15790 }
15791
15792
15793
15794
15795
15796
15797
15798
15799
15800
15801
15802
15803
15804
15805
15806
15807
15808
15809 i__1 = *k;
15810 for (i__ = 1; i__ <= i__1; ++i__) {
15811 dlamda[i__] = slamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
15812
15813 }
15814
15815 i__1 = *k;
15816 for (j = 1; j <= i__1; ++j) {
15817 slaed4_(k, &j, &dlamda[1], &w[1], &q_ref(1, j), rho, &d__[j], info);
15818
15819
15820
15821 if (*info != 0) {
15822 goto L120;
15823 }
15824
15825 }
15826
15827 if (*k == 1) {
15828 goto L110;
15829 }
15830 if (*k == 2) {
15831 i__1 = *k;
15832 for (j = 1; j <= i__1; ++j) {
15833 w[1] = q_ref(1, j);
15834 w[2] = q_ref(2, j);
15835 ii = indx[1];
15836 q_ref(1, j) = w[ii];
15837 ii = indx[2];
15838 q_ref(2, j) = w[ii];
15839
15840 }
15841 goto L110;
15842 }
15843
15844
15845
15846 scopy_(k, &w[1], &c__1, &s[1], &c__1);
15847
15848
15849
15850 i__1 = *ldq + 1;
15851 scopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
15852 i__1 = *k;
15853 for (j = 1; j <= i__1; ++j) {
15854 i__2 = j - 1;
15855 for (i__ = 1; i__ <= i__2; ++i__) {
15856 w[i__] *= q_ref(i__, j) / (dlamda[i__] - dlamda[j]);
15857
15858 }
15859 i__2 = *k;
15860 for (i__ = j + 1; i__ <= i__2; ++i__) {
15861 w[i__] *= q_ref(i__, j) / (dlamda[i__] - dlamda[j]);
15862
15863 }
15864
15865 }
15866 i__1 = *k;
15867 for (i__ = 1; i__ <= i__1; ++i__) {
15868 r__1 = sqrt(-w[i__]);
15869 w[i__] = r_sign(&r__1, &s[i__]);
15870
15871 }
15872
15873
15874
15875 i__1 = *k;
15876 for (j = 1; j <= i__1; ++j) {
15877 i__2 = *k;
15878 for (i__ = 1; i__ <= i__2; ++i__) {
15879 s[i__] = w[i__] / q_ref(i__, j);
15880
15881 }
15882 temp = snrm2_(k, &s[1], &c__1);
15883 i__2 = *k;
15884 for (i__ = 1; i__ <= i__2; ++i__) {
15885 ii = indx[i__];
15886 q_ref(i__, j) = s[ii] / temp;
15887
15888 }
15889
15890 }
15891
15892
15893
15894 L110:
15895
15896 n2 = *n - *n1;
15897 n12 = ctot[1] + ctot[2];
15898 n23 = ctot[2] + ctot[3];
15899
15900 slacpy_("A", &n23, k, &q_ref(ctot[1] + 1, 1), ldq, &s[1], &n23)
15901 ;
15902 iq2 = *n1 * n12 + 1;
15903 if (n23 != 0) {
15904 sgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, &
15905 c_b23, &q_ref(*n1 + 1, 1), ldq);
15906 } else {
15907 slaset_("A", &n2, k, &c_b23, &c_b23, &q_ref(*n1 + 1, 1), ldq);
15908 }
15909
15910 slacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12);
15911 if (n12 != 0) {
15912 sgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23,
15913 &q[q_offset], ldq);
15914 } else {
15915 slaset_("A", n1, k, &c_b23, &c_b23, &q_ref(1, 1), ldq);
15916 }
15917
15918
15919 L120:
15920 return 0;
15921
15922
15923
15924 }
15925
15926 #undef q_ref
15927
15928
15929 int slaed6_(integer *kniter, logical *orgati, real *rho,
15930 real *d__, real *z__, real *finit, real *tau, integer *info)
15931 {
15932
15933
15934
15935
15936
15937
15938
15939
15940
15941
15942
15943
15944
15945
15946
15947
15948
15949
15950
15951
15952
15953
15954
15955
15956
15957
15958
15959
15960
15961
15962
15963
15964
15965
15966
15967
15968
15969
15970
15971
15972
15973
15974
15975
15976
15977
15978
15979
15980
15981
15982
15983
15984
15985
15986
15987
15988
15989
15990
15991
15992
15993
15994
15995
15996
15997
15998
15999 static logical first = TRUE_;
16000
16001 integer i__1;
16002 real r__1, r__2, r__3, r__4;
16003
16004
16005
16006 static real base;
16007 static integer iter;
16008 static real temp, temp1, temp2, temp3, temp4, a, b, c__, f;
16009 static integer i__;
16010 static logical scale;
16011 static integer niter;
16012 static real small1, small2, fc, df, sminv1, sminv2, dscale[3], sclfac;
16013 extern doublereal slamch_(const char *);
16014 static real zscale[3], erretm, sclinv, ddf, eta, eps;
16015
16016 --z__;
16017 --d__;
16018
16019
16020
16021 *info = 0;
16022
16023 niter = 1;
16024 *tau = 0.f;
16025 if (*kniter == 2) {
16026 if (*orgati) {
16027 temp = (d__[3] - d__[2]) / 2.f;
16028 c__ = *rho + z__[1] / (d__[1] - d__[2] - temp);
16029 a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3];
16030 b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2];
16031 } else {
16032 temp = (d__[1] - d__[2]) / 2.f;
16033 c__ = *rho + z__[3] / (d__[3] - d__[2] - temp);
16034 a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2];
16035 b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1];
16036 }
16037
16038 r__1 = dabs(a), r__2 = dabs(b), r__1 = f2cmax(r__1,r__2), r__2 = dabs(
16039 c__);
16040 temp = df2cmax(r__1,r__2);
16041 a /= temp;
16042 b /= temp;
16043 c__ /= temp;
16044 if (c__ == 0.f) {
16045 *tau = b / a;
16046 } else if (a <= 0.f) {
16047 *tau = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / (
16048 c__ * 2.f);
16049 } else {
16050 *tau = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
16051 r__1))));
16052 }
16053 temp = *rho + z__[1] / (d__[1] - *tau) + z__[2] / (d__[2] - *tau) +
16054 z__[3] / (d__[3] - *tau);
16055 if (dabs(*finit) <= dabs(temp)) {
16056 *tau = 0.f;
16057 }
16058 }
16059
16060
16061
16062
16063 if (first) {
16064 eps = slamch_("Epsilon");
16065 base = slamch_("Base");
16066 i__1 = (integer) (log(slamch_("SafMin")) / log(base) / 3.f)
16067 ;
16068 small1 = pow_ri(&base, &i__1);
16069 sminv1 = 1.f / small1;
16070 small2 = small1 * small1;
16071 sminv2 = sminv1 * sminv1;
16072 first = FALSE_;
16073 }
16074
16075
16076
16077
16078 if (*orgati) {
16079
16080 r__3 = (r__1 = d__[2] - *tau, dabs(r__1)), r__4 = (r__2 = d__[3] - *
16081 tau, dabs(r__2));
16082 temp = df2cmin(r__3,r__4);
16083 } else {
16084
16085 r__3 = (r__1 = d__[1] - *tau, dabs(r__1)), r__4 = (r__2 = d__[2] - *
16086 tau, dabs(r__2));
16087 temp = df2cmin(r__3,r__4);
16088 }
16089 scale = FALSE_;
16090 if (temp <= small1) {
16091 scale = TRUE_;
16092 if (temp <= small2) {
16093
16094
16095
16096 sclfac = sminv2;
16097 sclinv = small2;
16098 } else {
16099
16100
16101
16102 sclfac = sminv1;
16103 sclinv = small1;
16104 }
16105
16106
16107
16108 for (i__ = 1; i__ <= 3; ++i__) {
16109 dscale[i__ - 1] = d__[i__] * sclfac;
16110 zscale[i__ - 1] = z__[i__] * sclfac;
16111
16112 }
16113 *tau *= sclfac;
16114 } else {
16115
16116
16117
16118 for (i__ = 1; i__ <= 3; ++i__) {
16119 dscale[i__ - 1] = d__[i__];
16120 zscale[i__ - 1] = z__[i__];
16121
16122 }
16123 }
16124
16125 fc = 0.f;
16126 df = 0.f;
16127 ddf = 0.f;
16128 for (i__ = 1; i__ <= 3; ++i__) {
16129 temp = 1.f / (dscale[i__ - 1] - *tau);
16130 temp1 = zscale[i__ - 1] * temp;
16131 temp2 = temp1 * temp;
16132 temp3 = temp2 * temp;
16133 fc += temp1 / dscale[i__ - 1];
16134 df += temp2;
16135 ddf += temp3;
16136
16137 }
16138 f = *finit + *tau * fc;
16139
16140 if (dabs(f) <= 0.f) {
16141 goto L60;
16142 }
16143
16144
16145
16146
16147
16148
16149
16150
16151
16152
16153
16154 iter = niter + 1;
16155
16156 for (niter = iter; niter <= 20; ++niter) {
16157
16158 if (*orgati) {
16159 temp1 = dscale[1] - *tau;
16160 temp2 = dscale[2] - *tau;
16161 } else {
16162 temp1 = dscale[0] - *tau;
16163 temp2 = dscale[1] - *tau;
16164 }
16165 a = (temp1 + temp2) * f - temp1 * temp2 * df;
16166 b = temp1 * temp2 * f;
16167 c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf;
16168
16169 r__1 = dabs(a), r__2 = dabs(b), r__1 = f2cmax(r__1,r__2), r__2 = dabs(
16170 c__);
16171 temp = df2cmax(r__1,r__2);
16172 a /= temp;
16173 b /= temp;
16174 c__ /= temp;
16175 if (c__ == 0.f) {
16176 eta = b / a;
16177 } else if (a <= 0.f) {
16178 eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / (
16179 c__ * 2.f);
16180 } else {
16181 eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
16182 r__1))));
16183 }
16184 if (f * eta >= 0.f) {
16185 eta = -f / df;
16186 }
16187
16188 temp = eta + *tau;
16189 if (*orgati) {
16190 if (eta > 0.f && temp >= dscale[2]) {
16191 eta = (dscale[2] - *tau) / 2.f;
16192 }
16193 if (eta < 0.f && temp <= dscale[1]) {
16194 eta = (dscale[1] - *tau) / 2.f;
16195 }
16196 } else {
16197 if (eta > 0.f && temp >= dscale[1]) {
16198 eta = (dscale[1] - *tau) / 2.f;
16199 }
16200 if (eta < 0.f && temp <= dscale[0]) {
16201 eta = (dscale[0] - *tau) / 2.f;
16202 }
16203 }
16204 *tau += eta;
16205
16206 fc = 0.f;
16207 erretm = 0.f;
16208 df = 0.f;
16209 ddf = 0.f;
16210 for (i__ = 1; i__ <= 3; ++i__) {
16211 temp = 1.f / (dscale[i__ - 1] - *tau);
16212 temp1 = zscale[i__ - 1] * temp;
16213 temp2 = temp1 * temp;
16214 temp3 = temp2 * temp;
16215 temp4 = temp1 / dscale[i__ - 1];
16216 fc += temp4;
16217 erretm += dabs(temp4);
16218 df += temp2;
16219 ddf += temp3;
16220
16221 }
16222 f = *finit + *tau * fc;
16223 erretm = (dabs(*finit) + dabs(*tau) * erretm) * 8.f + dabs(*tau) * df;
16224 if (dabs(f) <= eps * erretm) {
16225 goto L60;
16226 }
16227
16228 }
16229 *info = 1;
16230 L60:
16231
16232
16233
16234 if (scale) {
16235 *tau *= sclinv;
16236 }
16237 return 0;
16238
16239
16240
16241 }
16242
16243 int slaed5_(integer *i__, real *d__, real *z__, real *delta,
16244 real *rho, real *dlam)
16245 {
16246
16247
16248
16249
16250
16251
16252
16253
16254
16255
16256
16257
16258
16259
16260
16261
16262
16263
16264
16265
16266
16267
16268
16269
16270
16271
16272
16273
16274
16275
16276
16277
16278
16279
16280
16281
16282
16283
16284
16285
16286
16287
16288
16289
16290
16291
16292
16293
16294
16295
16296
16297
16298
16299
16300
16301 real r__1;
16302
16303
16304
16305 static real temp, b, c__, w, del, tau;
16306
16307 --delta;
16308 --z__;
16309 --d__;
16310
16311
16312 del = d__[2] - d__[1];
16313 if (*i__ == 1) {
16314 w = *rho * 2.f * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.f;
16315 if (w > 0.f) {
16316 b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
16317 c__ = *rho * z__[1] * z__[1] * del;
16318
16319
16320
16321 tau = c__ * 2.f / (b + sqrt((r__1 = b * b - c__ * 4.f, dabs(r__1))
16322 ));
16323 *dlam = d__[1] + tau;
16324 delta[1] = -z__[1] / tau;
16325 delta[2] = z__[2] / (del - tau);
16326 } else {
16327 b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
16328 c__ = *rho * z__[2] * z__[2] * del;
16329 if (b > 0.f) {
16330 tau = c__ * -2.f / (b + sqrt(b * b + c__ * 4.f));
16331 } else {
16332 tau = (b - sqrt(b * b + c__ * 4.f)) / 2.f;
16333 }
16334 *dlam = d__[2] + tau;
16335 delta[1] = -z__[1] / (del + tau);
16336 delta[2] = -z__[2] / tau;
16337 }
16338 temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]);
16339 delta[1] /= temp;
16340 delta[2] /= temp;
16341 } else {
16342
16343
16344
16345 b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
16346 c__ = *rho * z__[2] * z__[2] * del;
16347 if (b > 0.f) {
16348 tau = (b + sqrt(b * b + c__ * 4.f)) / 2.f;
16349 } else {
16350 tau = c__ * 2.f / (-b + sqrt(b * b + c__ * 4.f));
16351 }
16352 *dlam = d__[2] + tau;
16353 delta[1] = -z__[1] / (del + tau);
16354 delta[2] = -z__[2] / tau;
16355 temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]);
16356 delta[1] /= temp;
16357 delta[2] /= temp;
16358 }
16359 return 0;
16360
16361
16362
16363 }
16364
16365
16366
16367
16368
16369 static integer c__6 = 6;
16370 static integer c__0 = 0;
16371 static integer c__2 = 2;
16372
16373 static integer c_n1 = -1;
16374 static real c_b416 = 0.f;
16375 static real c_b438 = 1.f;
16376
16377
16378 int sgesvd_(char *jobu, char *jobvt, integer *m, integer *n,
16379 real *a, integer *lda, real *s, real *u, integer *ldu, real *vt,
16380 integer *ldvt, real *work, integer *lwork, integer *info)
16381 {
16382
16383 typedef const char *address;
16384
16385 address a__1[2];
16386 integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2],
16387 i__2, i__3, i__4;
16388 char ch__1[2];
16389
16390
16391 int s_cat(char *, const char **, integer *, integer *, ftnlen);
16392
16393
16394
16395 static integer iscl;
16396 static real anrm;
16397 static integer ierr, itau, ncvt, nrvt, i__;
16398 extern logical lsame_(const char *, const char *);
16399 static integer chunk;
16400 extern int sgemm_(const char *, const char *, integer *, integer *,
16401 integer *, real *, real *, integer *, real *, integer *, real *,
16402 real *, integer *);
16403 static integer minmn, wrkbl, itaup, itauq, mnthr, iwork;
16404 static logical wntua, wntva, wntun, wntuo, wntvn, wntvo, wntus, wntvs;
16405 static integer ie, ir, bdspac, iu;
16406 extern int sgebrd_(integer *, integer *, real *, integer
16407 *, real *, real *, real *, real *, real *, integer *, integer *);
16408 extern doublereal slamch_(const char *), slange_(const char *, integer *,
16409 integer *, real *, integer *, real *);
16410 extern int xerbla_(const char *, integer *);
16411 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
16412 integer *, integer *, ftnlen, ftnlen);
16413 static real bignum;
16414 extern int sgelqf_(integer *, integer *, real *, integer
16415 *, real *, real *, integer *, integer *), slascl_(const char *, integer
16416 *, integer *, real *, real *, integer *, integer *, real *,
16417 integer *, integer *), sgeqrf_(integer *, integer *, real
16418 *, integer *, real *, real *, integer *, integer *), slacpy_(const char
16419 *, integer *, integer *, real *, integer *, real *, integer *), slaset_(const char *, integer *, integer *, real *, real *,
16420 real *, integer *), sbdsqr_(const char *, integer *, integer *,
16421 integer *, integer *, real *, real *, real *, integer *, real *,
16422 integer *, real *, integer *, real *, integer *), sorgbr_(
16423 const char *, integer *, integer *, integer *, real *, integer *, real *
16424 , real *, integer *, integer *), sormbr_(const char *, const char *,
16425 const char *, integer *, integer *, integer *, real *, integer *, real *
16426 , real *, integer *, real *, integer *, integer *);
16427 static integer ldwrkr, minwrk, ldwrku, maxwrk;
16428 extern int sorglq_(integer *, integer *, integer *, real
16429 *, integer *, real *, real *, integer *, integer *);
16430 static real smlnum;
16431 extern int sorgqr_(integer *, integer *, integer *, real
16432 *, integer *, real *, real *, integer *, integer *);
16433 static logical lquery, wntuas, wntvas;
16434 static integer blk, ncu;
16435 static real dum[1], eps;
16436 static integer nru;
16437
16438
16439 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
16440 #define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
16441 #define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1]
16442
16443
16444
16445
16446
16447
16448
16449
16450
16451
16452
16453
16454
16455
16456
16457
16458
16459
16460
16461
16462
16463
16464
16465
16466
16467
16468
16469
16470
16471
16472
16473
16474
16475
16476
16477
16478
16479
16480
16481
16482
16483
16484
16485
16486
16487
16488
16489
16490
16491
16492
16493
16494
16495
16496
16497
16498
16499
16500
16501
16502
16503
16504
16505
16506
16507
16508
16509
16510
16511
16512
16513
16514
16515
16516
16517
16518
16519
16520
16521
16522
16523
16524
16525
16526
16527
16528
16529
16530
16531
16532
16533
16534
16535
16536
16537
16538
16539
16540
16541
16542
16543
16544
16545
16546
16547
16548
16549
16550
16551
16552
16553
16554
16555
16556
16557
16558
16559
16560
16561
16562
16563
16564
16565
16566
16567
16568
16569
16570
16571
16572 a_dim1 = *lda;
16573 a_offset = 1 + a_dim1 * 1;
16574 a -= a_offset;
16575 --s;
16576 u_dim1 = *ldu;
16577 u_offset = 1 + u_dim1 * 1;
16578 u -= u_offset;
16579 vt_dim1 = *ldvt;
16580 vt_offset = 1 + vt_dim1 * 1;
16581 vt -= vt_offset;
16582 --work;
16583
16584
16585 *info = 0;
16586 minmn = f2cmin(*m,*n);
16587
16588 i__1[0] = 1, a__1[0] = jobu;
16589 i__1[1] = 1, a__1[1] = jobvt;
16590 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
16591 mnthr = ilaenv_(&c__6, "SGESVD", ch__1, m, n, &c__0, &c__0, (ftnlen)6, (
16592 ftnlen)2);
16593 wntua = lsame_(jobu, "A");
16594 wntus = lsame_(jobu, "S");
16595 wntuas = wntua || wntus;
16596 wntuo = lsame_(jobu, "O");
16597 wntun = lsame_(jobu, "N");
16598 wntva = lsame_(jobvt, "A");
16599 wntvs = lsame_(jobvt, "S");
16600 wntvas = wntva || wntvs;
16601 wntvo = lsame_(jobvt, "O");
16602 wntvn = lsame_(jobvt, "N");
16603 minwrk = 1;
16604 lquery = *lwork == -1;
16605
16606 if (! (wntua || wntus || wntuo || wntun)) {
16607 *info = -1;
16608 } else if (! (wntva || wntvs || wntvo || wntvn) || wntvo && wntuo) {
16609 *info = -2;
16610 } else if (*m < 0) {
16611 *info = -3;
16612 } else if (*n < 0) {
16613 *info = -4;
16614 } else if (*lda < f2cmax(1,*m)) {
16615 *info = -6;
16616 } else if (*ldu < 1 || wntuas && *ldu < *m) {
16617 *info = -9;
16618 } else if (*ldvt < 1 || wntva && *ldvt < *n || wntvs && *ldvt < minmn) {
16619 *info = -11;
16620 }
16621
16622
16623
16624
16625
16626
16627
16628
16629 if (*info == 0 && (*lwork >= 1 || lquery) && *m > 0 && *n > 0) {
16630 if (*m >= *n) {
16631
16632
16633
16634 bdspac = *n * 5;
16635 if (*m >= mnthr) {
16636 if (wntun) {
16637
16638
16639
16640 maxwrk = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
16641 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16642
16643 i__2 = maxwrk, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
16644 "SGEBRD", " ", n, n, &c_n1, &c_n1, (ftnlen)6, (
16645 ftnlen)1);
16646 maxwrk = f2cmax(i__2,i__3);
16647 if (wntvo || wntvas) {
16648
16649 i__2 = maxwrk, i__3 = *n * 3 + (*n - 1) * ilaenv_(&
16650 c__1, "SORGBR", "P", n, n, n, &c_n1, (ftnlen)
16651 6, (ftnlen)1);
16652 maxwrk = f2cmax(i__2,i__3);
16653 }
16654 maxwrk = f2cmax(maxwrk,bdspac);
16655
16656 i__2 = *n << 2;
16657 minwrk = f2cmax(i__2,bdspac);
16658 maxwrk = f2cmax(maxwrk,minwrk);
16659 } else if (wntuo && wntvn) {
16660
16661
16662
16663 wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
16664 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16665
16666 i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "SORGQR",
16667 " ", m, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16668 wrkbl = f2cmax(i__2,i__3);
16669
16670 i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
16671 "SGEBRD", " ", n, n, &c_n1, &c_n1, (ftnlen)6, (
16672 ftnlen)1);
16673 wrkbl = f2cmax(i__2,i__3);
16674
16675 i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
16676 , "Q", n, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16677 wrkbl = f2cmax(i__2,i__3);
16678 wrkbl = f2cmax(wrkbl,bdspac);
16679
16680 i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n;
16681 maxwrk = f2cmax(i__2,i__3);
16682
16683 i__2 = *n * 3 + *m;
16684 minwrk = f2cmax(i__2,bdspac);
16685 maxwrk = f2cmax(maxwrk,minwrk);
16686 } else if (wntuo && wntvas) {
16687
16688
16689
16690
16691 wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
16692 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16693
16694 i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "SORGQR",
16695 " ", m, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16696 wrkbl = f2cmax(i__2,i__3);
16697
16698 i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
16699 "SGEBRD", " ", n, n, &c_n1, &c_n1, (ftnlen)6, (
16700 ftnlen)1);
16701 wrkbl = f2cmax(i__2,i__3);
16702
16703 i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
16704 , "Q", n, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16705 wrkbl = f2cmax(i__2,i__3);
16706
16707 i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
16708 "SORGBR", "P", n, n, n, &c_n1, (ftnlen)6, (ftnlen)
16709 1);
16710 wrkbl = f2cmax(i__2,i__3);
16711 wrkbl = f2cmax(wrkbl,bdspac);
16712
16713 i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n;
16714 maxwrk = f2cmax(i__2,i__3);
16715
16716 i__2 = *n * 3 + *m;
16717 minwrk = f2cmax(i__2,bdspac);
16718 maxwrk = f2cmax(maxwrk,minwrk);
16719 } else if (wntus && wntvn) {
16720
16721
16722
16723 wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
16724 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16725
16726 i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "SORGQR",
16727 " ", m, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16728 wrkbl = f2cmax(i__2,i__3);
16729
16730 i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
16731 "SGEBRD", " ", n, n, &c_n1, &c_n1, (ftnlen)6, (
16732 ftnlen)1);
16733 wrkbl = f2cmax(i__2,i__3);
16734
16735 i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
16736 , "Q", n, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16737 wrkbl = f2cmax(i__2,i__3);
16738 wrkbl = f2cmax(wrkbl,bdspac);
16739 maxwrk = *n * *n + wrkbl;
16740
16741 i__2 = *n * 3 + *m;
16742 minwrk = f2cmax(i__2,bdspac);
16743 maxwrk = f2cmax(maxwrk,minwrk);
16744 } else if (wntus && wntvo) {
16745
16746
16747
16748 wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
16749 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16750
16751 i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "SORGQR",
16752 " ", m, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16753 wrkbl = f2cmax(i__2,i__3);
16754
16755 i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
16756 "SGEBRD", " ", n, n, &c_n1, &c_n1, (ftnlen)6, (
16757 ftnlen)1);
16758 wrkbl = f2cmax(i__2,i__3);
16759
16760 i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
16761 , "Q", n, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16762 wrkbl = f2cmax(i__2,i__3);
16763
16764 i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
16765 "SORGBR", "P", n, n, n, &c_n1, (ftnlen)6, (ftnlen)
16766 1);
16767 wrkbl = f2cmax(i__2,i__3);
16768 wrkbl = f2cmax(wrkbl,bdspac);
16769 maxwrk = (*n << 1) * *n + wrkbl;
16770
16771 i__2 = *n * 3 + *m;
16772 minwrk = f2cmax(i__2,bdspac);
16773 maxwrk = f2cmax(maxwrk,minwrk);
16774 } else if (wntus && wntvas) {
16775
16776
16777
16778
16779 wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
16780 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16781
16782 i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "SORGQR",
16783 " ", m, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16784 wrkbl = f2cmax(i__2,i__3);
16785
16786 i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
16787 "SGEBRD", " ", n, n, &c_n1, &c_n1, (ftnlen)6, (
16788 ftnlen)1);
16789 wrkbl = f2cmax(i__2,i__3);
16790
16791 i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
16792 , "Q", n, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16793 wrkbl = f2cmax(i__2,i__3);
16794
16795 i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
16796 "SORGBR", "P", n, n, n, &c_n1, (ftnlen)6, (ftnlen)
16797 1);
16798 wrkbl = f2cmax(i__2,i__3);
16799 wrkbl = f2cmax(wrkbl,bdspac);
16800 maxwrk = *n * *n + wrkbl;
16801
16802 i__2 = *n * 3 + *m;
16803 minwrk = f2cmax(i__2,bdspac);
16804 maxwrk = f2cmax(maxwrk,minwrk);
16805 } else if (wntua && wntvn) {
16806
16807
16808
16809 wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
16810 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16811
16812 i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "SORGQR",
16813 " ", m, m, n, &c_n1, (ftnlen)6, (ftnlen)1);
16814 wrkbl = f2cmax(i__2,i__3);
16815
16816 i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
16817 "SGEBRD", " ", n, n, &c_n1, &c_n1, (ftnlen)6, (
16818 ftnlen)1);
16819 wrkbl = f2cmax(i__2,i__3);
16820
16821 i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
16822 , "Q", n, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16823 wrkbl = f2cmax(i__2,i__3);
16824 wrkbl = f2cmax(wrkbl,bdspac);
16825 maxwrk = *n * *n + wrkbl;
16826
16827 i__2 = *n * 3 + *m;
16828 minwrk = f2cmax(i__2,bdspac);
16829 maxwrk = f2cmax(maxwrk,minwrk);
16830 } else if (wntua && wntvo) {
16831
16832
16833
16834 wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
16835 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16836
16837 i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "SORGQR",
16838 " ", m, m, n, &c_n1, (ftnlen)6, (ftnlen)1);
16839 wrkbl = f2cmax(i__2,i__3);
16840
16841 i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
16842 "SGEBRD", " ", n, n, &c_n1, &c_n1, (ftnlen)6, (
16843 ftnlen)1);
16844 wrkbl = f2cmax(i__2,i__3);
16845
16846 i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
16847 , "Q", n, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16848 wrkbl = f2cmax(i__2,i__3);
16849
16850 i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
16851 "SORGBR", "P", n, n, n, &c_n1, (ftnlen)6, (ftnlen)
16852 1);
16853 wrkbl = f2cmax(i__2,i__3);
16854 wrkbl = f2cmax(wrkbl,bdspac);
16855 maxwrk = (*n << 1) * *n + wrkbl;
16856
16857 i__2 = *n * 3 + *m;
16858 minwrk = f2cmax(i__2,bdspac);
16859 maxwrk = f2cmax(maxwrk,minwrk);
16860 } else if (wntua && wntvas) {
16861
16862
16863
16864
16865 wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
16866 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16867
16868 i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "SORGQR",
16869 " ", m, m, n, &c_n1, (ftnlen)6, (ftnlen)1);
16870 wrkbl = f2cmax(i__2,i__3);
16871
16872 i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
16873 "SGEBRD", " ", n, n, &c_n1, &c_n1, (ftnlen)6, (
16874 ftnlen)1);
16875 wrkbl = f2cmax(i__2,i__3);
16876
16877 i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
16878 , "Q", n, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16879 wrkbl = f2cmax(i__2,i__3);
16880
16881 i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
16882 "SORGBR", "P", n, n, n, &c_n1, (ftnlen)6, (ftnlen)
16883 1);
16884 wrkbl = f2cmax(i__2,i__3);
16885 wrkbl = f2cmax(wrkbl,bdspac);
16886 maxwrk = *n * *n + wrkbl;
16887
16888 i__2 = *n * 3 + *m;
16889 minwrk = f2cmax(i__2,bdspac);
16890 maxwrk = f2cmax(maxwrk,minwrk);
16891 }
16892 } else {
16893
16894
16895
16896 maxwrk = *n * 3 + (*m + *n) * ilaenv_(&c__1, "SGEBRD", " ", m,
16897 n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16898 if (wntus || wntuo) {
16899
16900 i__2 = maxwrk, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORG"
16901 "BR", "Q", m, n, n, &c_n1, (ftnlen)6, (ftnlen)1);
16902 maxwrk = f2cmax(i__2,i__3);
16903 }
16904 if (wntua) {
16905
16906 i__2 = maxwrk, i__3 = *n * 3 + *m * ilaenv_(&c__1, "SORG"
16907 "BR", "Q", m, m, n, &c_n1, (ftnlen)6, (ftnlen)1);
16908 maxwrk = f2cmax(i__2,i__3);
16909 }
16910 if (! wntvn) {
16911
16912 i__2 = maxwrk, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
16913 "SORGBR", "P", n, n, n, &c_n1, (ftnlen)6, (ftnlen)
16914 1);
16915 maxwrk = f2cmax(i__2,i__3);
16916 }
16917 maxwrk = f2cmax(maxwrk,bdspac);
16918
16919 i__2 = *n * 3 + *m;
16920 minwrk = f2cmax(i__2,bdspac);
16921 maxwrk = f2cmax(maxwrk,minwrk);
16922 }
16923 } else {
16924
16925
16926
16927 bdspac = *m * 5;
16928 if (*n >= mnthr) {
16929 if (wntvn) {
16930
16931
16932
16933 maxwrk = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
16934 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16935
16936 i__2 = maxwrk, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
16937 "SGEBRD", " ", m, m, &c_n1, &c_n1, (ftnlen)6, (
16938 ftnlen)1);
16939 maxwrk = f2cmax(i__2,i__3);
16940 if (wntuo || wntuas) {
16941
16942 i__2 = maxwrk, i__3 = *m * 3 + *m * ilaenv_(&c__1,
16943 "SORGBR", "Q", m, m, m, &c_n1, (ftnlen)6, (
16944 ftnlen)1);
16945 maxwrk = f2cmax(i__2,i__3);
16946 }
16947 maxwrk = f2cmax(maxwrk,bdspac);
16948
16949 i__2 = *m << 2;
16950 minwrk = f2cmax(i__2,bdspac);
16951 maxwrk = f2cmax(maxwrk,minwrk);
16952 } else if (wntvo && wntun) {
16953
16954
16955
16956 wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
16957 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16958
16959 i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "SORGLQ",
16960 " ", m, n, m, &c_n1, (ftnlen)6, (ftnlen)1);
16961 wrkbl = f2cmax(i__2,i__3);
16962
16963 i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
16964 "SGEBRD", " ", m, m, &c_n1, &c_n1, (ftnlen)6, (
16965 ftnlen)1);
16966 wrkbl = f2cmax(i__2,i__3);
16967
16968 i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
16969 "SORGBR", "P", m, m, m, &c_n1, (ftnlen)6, (ftnlen)
16970 1);
16971 wrkbl = f2cmax(i__2,i__3);
16972 wrkbl = f2cmax(wrkbl,bdspac);
16973
16974 i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m;
16975 maxwrk = f2cmax(i__2,i__3);
16976
16977 i__2 = *m * 3 + *n;
16978 minwrk = f2cmax(i__2,bdspac);
16979 maxwrk = f2cmax(maxwrk,minwrk);
16980 } else if (wntvo && wntuas) {
16981
16982
16983
16984
16985 wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
16986 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
16987
16988 i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "SORGLQ",
16989 " ", m, n, m, &c_n1, (ftnlen)6, (ftnlen)1);
16990 wrkbl = f2cmax(i__2,i__3);
16991
16992 i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
16993 "SGEBRD", " ", m, m, &c_n1, &c_n1, (ftnlen)6, (
16994 ftnlen)1);
16995 wrkbl = f2cmax(i__2,i__3);
16996
16997 i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
16998 "SORGBR", "P", m, m, m, &c_n1, (ftnlen)6, (ftnlen)
16999 1);
17000 wrkbl = f2cmax(i__2,i__3);
17001
17002 i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "SORGBR"
17003 , "Q", m, m, m, &c_n1, (ftnlen)6, (ftnlen)1);
17004 wrkbl = f2cmax(i__2,i__3);
17005 wrkbl = f2cmax(wrkbl,bdspac);
17006
17007 i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m;
17008 maxwrk = f2cmax(i__2,i__3);
17009
17010 i__2 = *m * 3 + *n;
17011 minwrk = f2cmax(i__2,bdspac);
17012 maxwrk = f2cmax(maxwrk,minwrk);
17013 } else if (wntvs && wntun) {
17014
17015
17016
17017 wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
17018 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
17019
17020 i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "SORGLQ",
17021 " ", m, n, m, &c_n1, (ftnlen)6, (ftnlen)1);
17022 wrkbl = f2cmax(i__2,i__3);
17023
17024 i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
17025 "SGEBRD", " ", m, m, &c_n1, &c_n1, (ftnlen)6, (
17026 ftnlen)1);
17027 wrkbl = f2cmax(i__2,i__3);
17028
17029 i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
17030 "SORGBR", "P", m, m, m, &c_n1, (ftnlen)6, (ftnlen)
17031 1);
17032 wrkbl = f2cmax(i__2,i__3);
17033 wrkbl = f2cmax(wrkbl,bdspac);
17034 maxwrk = *m * *m + wrkbl;
17035
17036 i__2 = *m * 3 + *n;
17037 minwrk = f2cmax(i__2,bdspac);
17038 maxwrk = f2cmax(maxwrk,minwrk);
17039 } else if (wntvs && wntuo) {
17040
17041
17042
17043 wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
17044 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
17045
17046 i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "SORGLQ",
17047 " ", m, n, m, &c_n1, (ftnlen)6, (ftnlen)1);
17048 wrkbl = f2cmax(i__2,i__3);
17049
17050 i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
17051 "SGEBRD", " ", m, m, &c_n1, &c_n1, (ftnlen)6, (
17052 ftnlen)1);
17053 wrkbl = f2cmax(i__2,i__3);
17054
17055 i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
17056 "SORGBR", "P", m, m, m, &c_n1, (ftnlen)6, (ftnlen)
17057 1);
17058 wrkbl = f2cmax(i__2,i__3);
17059
17060 i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "SORGBR"
17061 , "Q", m, m, m, &c_n1, (ftnlen)6, (ftnlen)1);
17062 wrkbl = f2cmax(i__2,i__3);
17063 wrkbl = f2cmax(wrkbl,bdspac);
17064 maxwrk = (*m << 1) * *m + wrkbl;
17065
17066 i__2 = *m * 3 + *n;
17067 minwrk = f2cmax(i__2,bdspac);
17068 maxwrk = f2cmax(maxwrk,minwrk);
17069 } else if (wntvs && wntuas) {
17070
17071
17072
17073
17074 wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
17075 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
17076
17077 i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "SORGLQ",
17078 " ", m, n, m, &c_n1, (ftnlen)6, (ftnlen)1);
17079 wrkbl = f2cmax(i__2,i__3);
17080
17081 i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
17082 "SGEBRD", " ", m, m, &c_n1, &c_n1, (ftnlen)6, (
17083 ftnlen)1);
17084 wrkbl = f2cmax(i__2,i__3);
17085
17086 i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
17087 "SORGBR", "P", m, m, m, &c_n1, (ftnlen)6, (ftnlen)
17088 1);
17089 wrkbl = f2cmax(i__2,i__3);
17090
17091 i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "SORGBR"
17092 , "Q", m, m, m, &c_n1, (ftnlen)6, (ftnlen)1);
17093 wrkbl = f2cmax(i__2,i__3);
17094 wrkbl = f2cmax(wrkbl,bdspac);
17095 maxwrk = *m * *m + wrkbl;
17096
17097 i__2 = *m * 3 + *n;
17098 minwrk = f2cmax(i__2,bdspac);
17099 maxwrk = f2cmax(maxwrk,minwrk);
17100 } else if (wntva && wntun) {
17101
17102
17103
17104 wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
17105 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
17106
17107 i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "SORGLQ",
17108 " ", n, n, m, &c_n1, (ftnlen)6, (ftnlen)1);
17109 wrkbl = f2cmax(i__2,i__3);
17110
17111 i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
17112 "SGEBRD", " ", m, m, &c_n1, &c_n1, (ftnlen)6, (
17113 ftnlen)1);
17114 wrkbl = f2cmax(i__2,i__3);
17115
17116 i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
17117 "SORGBR", "P", m, m, m, &c_n1, (ftnlen)6, (ftnlen)
17118 1);
17119 wrkbl = f2cmax(i__2,i__3);
17120 wrkbl = f2cmax(wrkbl,bdspac);
17121 maxwrk = *m * *m + wrkbl;
17122
17123 i__2 = *m * 3 + *n;
17124 minwrk = f2cmax(i__2,bdspac);
17125 maxwrk = f2cmax(maxwrk,minwrk);
17126 } else if (wntva && wntuo) {
17127
17128
17129
17130 wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
17131 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
17132
17133 i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "SORGLQ",
17134 " ", n, n, m, &c_n1, (ftnlen)6, (ftnlen)1);
17135 wrkbl = f2cmax(i__2,i__3);
17136
17137 i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
17138 "SGEBRD", " ", m, m, &c_n1, &c_n1, (ftnlen)6, (
17139 ftnlen)1);
17140 wrkbl = f2cmax(i__2,i__3);
17141
17142 i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
17143 "SORGBR", "P", m, m, m, &c_n1, (ftnlen)6, (ftnlen)
17144 1);
17145 wrkbl = f2cmax(i__2,i__3);
17146
17147 i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "SORGBR"
17148 , "Q", m, m, m, &c_n1, (ftnlen)6, (ftnlen)1);
17149 wrkbl = f2cmax(i__2,i__3);
17150 wrkbl = f2cmax(wrkbl,bdspac);
17151 maxwrk = (*m << 1) * *m + wrkbl;
17152
17153 i__2 = *m * 3 + *n;
17154 minwrk = f2cmax(i__2,bdspac);
17155 maxwrk = f2cmax(maxwrk,minwrk);
17156 } else if (wntva && wntuas) {
17157
17158
17159
17160
17161 wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
17162 c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
17163
17164 i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "SORGLQ",
17165 " ", n, n, m, &c_n1, (ftnlen)6, (ftnlen)1);
17166 wrkbl = f2cmax(i__2,i__3);
17167
17168 i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
17169 "SGEBRD", " ", m, m, &c_n1, &c_n1, (ftnlen)6, (
17170 ftnlen)1);
17171 wrkbl = f2cmax(i__2,i__3);
17172
17173 i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
17174 "SORGBR", "P", m, m, m, &c_n1, (ftnlen)6, (ftnlen)
17175 1);
17176 wrkbl = f2cmax(i__2,i__3);
17177
17178 i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "SORGBR"
17179 , "Q", m, m, m, &c_n1, (ftnlen)6, (ftnlen)1);
17180 wrkbl = f2cmax(i__2,i__3);
17181 wrkbl = f2cmax(wrkbl,bdspac);
17182 maxwrk = *m * *m + wrkbl;
17183
17184 i__2 = *m * 3 + *n;
17185 minwrk = f2cmax(i__2,bdspac);
17186 maxwrk = f2cmax(maxwrk,minwrk);
17187 }
17188 } else {
17189
17190
17191
17192 maxwrk = *m * 3 + (*m + *n) * ilaenv_(&c__1, "SGEBRD", " ", m,
17193 n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
17194 if (wntvs || wntvo) {
17195
17196 i__2 = maxwrk, i__3 = *m * 3 + *m * ilaenv_(&c__1, "SORG"
17197 "BR", "P", m, n, m, &c_n1, (ftnlen)6, (ftnlen)1);
17198 maxwrk = f2cmax(i__2,i__3);
17199 }
17200 if (wntva) {
17201
17202 i__2 = maxwrk, i__3 = *m * 3 + *n * ilaenv_(&c__1, "SORG"
17203 "BR", "P", n, n, m, &c_n1, (ftnlen)6, (ftnlen)1);
17204 maxwrk = f2cmax(i__2,i__3);
17205 }
17206 if (! wntun) {
17207
17208 i__2 = maxwrk, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
17209 "SORGBR", "Q", m, m, m, &c_n1, (ftnlen)6, (ftnlen)
17210 1);
17211 maxwrk = f2cmax(i__2,i__3);
17212 }
17213 maxwrk = f2cmax(maxwrk,bdspac);
17214
17215 i__2 = *m * 3 + *n;
17216 minwrk = f2cmax(i__2,bdspac);
17217 maxwrk = f2cmax(maxwrk,minwrk);
17218 }
17219 }
17220 work[1] = (real) maxwrk;
17221 }
17222
17223 if (*lwork < minwrk && ! lquery) {
17224 *info = -13;
17225 }
17226 if (*info != 0) {
17227 i__2 = -(*info);
17228 xerbla_("SGESVD", &i__2);
17229 return 0;
17230 } else if (lquery) {
17231 return 0;
17232 }
17233
17234
17235
17236 if (*m == 0 || *n == 0) {
17237 if (*lwork >= 1) {
17238 work[1] = 1.f;
17239 }
17240 return 0;
17241 }
17242
17243
17244
17245 eps = slamch_("P");
17246 smlnum = sqrt(slamch_("S")) / eps;
17247 bignum = 1.f / smlnum;
17248
17249
17250
17251 anrm = slange_("M", m, n, &a[a_offset], lda, dum);
17252 iscl = 0;
17253 if (anrm > 0.f && anrm < smlnum) {
17254 iscl = 1;
17255 slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, &
17256 ierr);
17257 } else if (anrm > bignum) {
17258 iscl = 1;
17259 slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, &
17260 ierr);
17261 }
17262
17263 if (*m >= *n) {
17264
17265
17266
17267
17268
17269 if (*m >= mnthr) {
17270
17271 if (wntun) {
17272
17273
17274
17275
17276 itau = 1;
17277 iwork = itau + *n;
17278
17279
17280
17281
17282 i__2 = *lwork - iwork + 1;
17283 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
17284 i__2, &ierr);
17285
17286
17287
17288 i__2 = *n - 1;
17289 i__3 = *n - 1;
17290 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &a_ref(2, 1),
17291 lda);
17292 ie = 1;
17293 itauq = ie + *n;
17294 itaup = itauq + *n;
17295 iwork = itaup + *n;
17296
17297
17298
17299
17300 i__2 = *lwork - iwork + 1;
17301 sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[
17302 itauq], &work[itaup], &work[iwork], &i__2, &ierr);
17303 ncvt = 0;
17304 if (wntvo || wntvas) {
17305
17306
17307
17308
17309 i__2 = *lwork - iwork + 1;
17310 sorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &
17311 work[iwork], &i__2, &ierr);
17312 ncvt = *n;
17313 }
17314 iwork = ie + *n;
17315
17316
17317
17318
17319
17320 sbdsqr_("U", n, &ncvt, &c__0, &c__0, &s[1], &work[ie], &a[
17321 a_offset], lda, dum, &c__1, dum, &c__1, &work[iwork],
17322 info);
17323
17324
17325
17326 if (wntvas) {
17327 slacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset],
17328 ldvt);
17329 }
17330
17331 } else if (wntuo && wntvn) {
17332
17333
17334
17335
17336
17337
17338 i__2 = *n << 2;
17339 if (*lwork >= *n * *n + f2cmax(i__2,bdspac)) {
17340
17341
17342
17343 ir = 1;
17344
17345 i__2 = wrkbl, i__3 = *lda * *n + *n;
17346 if (*lwork >= f2cmax(i__2,i__3) + *lda * *n) {
17347
17348
17349
17350 ldwrku = *lda;
17351 ldwrkr = *lda;
17352 } else {
17353
17354 i__2 = wrkbl, i__3 = *lda * *n + *n;
17355 if (*lwork >= f2cmax(i__2,i__3) + *n * *n) {
17356
17357
17358
17359 ldwrku = *lda;
17360 ldwrkr = *n;
17361 } else {
17362
17363
17364
17365 ldwrku = (*lwork - *n * *n - *n) / *n;
17366 ldwrkr = *n;
17367 }
17368 }
17369 itau = ir + ldwrkr * *n;
17370 iwork = itau + *n;
17371
17372
17373
17374
17375 i__2 = *lwork - iwork + 1;
17376 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
17377 , &i__2, &ierr);
17378
17379
17380
17381 slacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
17382 i__2 = *n - 1;
17383 i__3 = *n - 1;
17384 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[ir + 1]
17385 , &ldwrkr);
17386
17387
17388
17389
17390 i__2 = *lwork - iwork + 1;
17391 sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
17392 iwork], &i__2, &ierr);
17393 ie = itau;
17394 itauq = ie + *n;
17395 itaup = itauq + *n;
17396 iwork = itaup + *n;
17397
17398
17399
17400
17401 i__2 = *lwork - iwork + 1;
17402 sgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[
17403 itauq], &work[itaup], &work[iwork], &i__2, &ierr);
17404
17405
17406
17407
17408 i__2 = *lwork - iwork + 1;
17409 sorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
17410 work[iwork], &i__2, &ierr);
17411 iwork = ie + *n;
17412
17413
17414
17415
17416
17417 sbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie], dum, &
17418 c__1, &work[ir], &ldwrkr, dum, &c__1, &work[iwork]
17419 , info);
17420 iu = ie + *n;
17421
17422
17423
17424
17425
17426 i__2 = *m;
17427 i__3 = ldwrku;
17428 for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
17429 i__3) {
17430
17431 i__4 = *m - i__ + 1;
17432 chunk = f2cmin(i__4,ldwrku);
17433 sgemm_("N", "N", &chunk, n, n, &c_b438, &a_ref(i__, 1)
17434 , lda, &work[ir], &ldwrkr, &c_b416, &work[iu],
17435 &ldwrku);
17436 slacpy_("F", &chunk, n, &work[iu], &ldwrku, &a_ref(
17437 i__, 1), lda);
17438
17439 }
17440
17441 } else {
17442
17443
17444
17445 ie = 1;
17446 itauq = ie + *n;
17447 itaup = itauq + *n;
17448 iwork = itaup + *n;
17449
17450
17451
17452
17453 i__3 = *lwork - iwork + 1;
17454 sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[
17455 itauq], &work[itaup], &work[iwork], &i__3, &ierr);
17456
17457
17458
17459
17460 i__3 = *lwork - iwork + 1;
17461 sorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &
17462 work[iwork], &i__3, &ierr);
17463 iwork = ie + *n;
17464
17465
17466
17467
17468
17469 sbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie], dum, &
17470 c__1, &a[a_offset], lda, dum, &c__1, &work[iwork],
17471 info);
17472
17473 }
17474
17475 } else if (wntuo && wntvas) {
17476
17477
17478
17479
17480
17481
17482 i__3 = *n << 2;
17483 if (*lwork >= *n * *n + f2cmax(i__3,bdspac)) {
17484
17485
17486
17487 ir = 1;
17488
17489 i__3 = wrkbl, i__2 = *lda * *n + *n;
17490 if (*lwork >= f2cmax(i__3,i__2) + *lda * *n) {
17491
17492
17493
17494 ldwrku = *lda;
17495 ldwrkr = *lda;
17496 } else {
17497
17498 i__3 = wrkbl, i__2 = *lda * *n + *n;
17499 if (*lwork >= f2cmax(i__3,i__2) + *n * *n) {
17500
17501
17502
17503 ldwrku = *lda;
17504 ldwrkr = *n;
17505 } else {
17506
17507
17508
17509 ldwrku = (*lwork - *n * *n - *n) / *n;
17510 ldwrkr = *n;
17511 }
17512 }
17513 itau = ir + ldwrkr * *n;
17514 iwork = itau + *n;
17515
17516
17517
17518
17519 i__3 = *lwork - iwork + 1;
17520 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
17521 , &i__3, &ierr);
17522
17523
17524
17525 slacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
17526 ldvt);
17527 i__3 = *n - 1;
17528 i__2 = *n - 1;
17529 slaset_("L", &i__3, &i__2, &c_b416, &c_b416, &vt_ref(2, 1)
17530 , ldvt);
17531
17532
17533
17534
17535 i__3 = *lwork - iwork + 1;
17536 sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
17537 iwork], &i__3, &ierr);
17538 ie = itau;
17539 itauq = ie + *n;
17540 itaup = itauq + *n;
17541 iwork = itaup + *n;
17542
17543
17544
17545
17546 i__3 = *lwork - iwork + 1;
17547 sgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], &
17548 work[itauq], &work[itaup], &work[iwork], &i__3, &
17549 ierr);
17550 slacpy_("L", n, n, &vt[vt_offset], ldvt, &work[ir], &
17551 ldwrkr);
17552
17553
17554
17555
17556 i__3 = *lwork - iwork + 1;
17557 sorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
17558 work[iwork], &i__3, &ierr);
17559
17560
17561
17562
17563 i__3 = *lwork - iwork + 1;
17564 sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
17565 &work[iwork], &i__3, &ierr);
17566 iwork = ie + *n;
17567
17568
17569
17570
17571
17572
17573 sbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[
17574 vt_offset], ldvt, &work[ir], &ldwrkr, dum, &c__1,
17575 &work[iwork], info);
17576 iu = ie + *n;
17577
17578
17579
17580
17581
17582 i__3 = *m;
17583 i__2 = ldwrku;
17584 for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
17585 i__2) {
17586
17587 i__4 = *m - i__ + 1;
17588 chunk = f2cmin(i__4,ldwrku);
17589 sgemm_("N", "N", &chunk, n, n, &c_b438, &a_ref(i__, 1)
17590 , lda, &work[ir], &ldwrkr, &c_b416, &work[iu],
17591 &ldwrku);
17592 slacpy_("F", &chunk, n, &work[iu], &ldwrku, &a_ref(
17593 i__, 1), lda);
17594
17595 }
17596
17597 } else {
17598
17599
17600
17601 itau = 1;
17602 iwork = itau + *n;
17603
17604
17605
17606
17607 i__2 = *lwork - iwork + 1;
17608 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
17609 , &i__2, &ierr);
17610
17611
17612
17613 slacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
17614 ldvt);
17615 i__2 = *n - 1;
17616 i__3 = *n - 1;
17617 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &vt_ref(2, 1)
17618 , ldvt);
17619
17620
17621
17622
17623 i__2 = *lwork - iwork + 1;
17624 sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
17625 iwork], &i__2, &ierr);
17626 ie = itau;
17627 itauq = ie + *n;
17628 itaup = itauq + *n;
17629 iwork = itaup + *n;
17630
17631
17632
17633
17634 i__2 = *lwork - iwork + 1;
17635 sgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], &
17636 work[itauq], &work[itaup], &work[iwork], &i__2, &
17637 ierr);
17638
17639
17640
17641
17642 i__2 = *lwork - iwork + 1;
17643 sormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, &
17644 work[itauq], &a[a_offset], lda, &work[iwork], &
17645 i__2, &ierr);
17646
17647
17648
17649
17650 i__2 = *lwork - iwork + 1;
17651 sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
17652 &work[iwork], &i__2, &ierr);
17653 iwork = ie + *n;
17654
17655
17656
17657
17658
17659
17660 sbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[
17661 vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, &
17662 work[iwork], info);
17663
17664 }
17665
17666 } else if (wntus) {
17667
17668 if (wntvn) {
17669
17670
17671
17672
17673
17674
17675 i__2 = *n << 2;
17676 if (*lwork >= *n * *n + f2cmax(i__2,bdspac)) {
17677
17678
17679
17680 ir = 1;
17681 if (*lwork >= wrkbl + *lda * *n) {
17682
17683
17684
17685 ldwrkr = *lda;
17686 } else {
17687
17688
17689
17690 ldwrkr = *n;
17691 }
17692 itau = ir + ldwrkr * *n;
17693 iwork = itau + *n;
17694
17695
17696
17697
17698 i__2 = *lwork - iwork + 1;
17699 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
17700 iwork], &i__2, &ierr);
17701
17702
17703
17704 slacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
17705 ldwrkr);
17706 i__2 = *n - 1;
17707 i__3 = *n - 1;
17708 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[ir
17709 + 1], &ldwrkr);
17710
17711
17712
17713
17714 i__2 = *lwork - iwork + 1;
17715 sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &
17716 work[iwork], &i__2, &ierr);
17717 ie = itau;
17718 itauq = ie + *n;
17719 itaup = itauq + *n;
17720 iwork = itaup + *n;
17721
17722
17723
17724
17725 i__2 = *lwork - iwork + 1;
17726 sgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &
17727 work[itauq], &work[itaup], &work[iwork], &
17728 i__2, &ierr);
17729
17730
17731
17732
17733 i__2 = *lwork - iwork + 1;
17734 sorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
17735 , &work[iwork], &i__2, &ierr);
17736 iwork = ie + *n;
17737
17738
17739
17740
17741
17742 sbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie],
17743 dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, &
17744 work[iwork], info);
17745
17746
17747
17748
17749
17750 sgemm_("N", "N", m, n, n, &c_b438, &a[a_offset], lda,
17751 &work[ir], &ldwrkr, &c_b416, &u[u_offset],
17752 ldu);
17753
17754 } else {
17755
17756
17757
17758 itau = 1;
17759 iwork = itau + *n;
17760
17761
17762
17763
17764 i__2 = *lwork - iwork + 1;
17765 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
17766 iwork], &i__2, &ierr);
17767 slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
17768 ldu);
17769
17770
17771
17772
17773 i__2 = *lwork - iwork + 1;
17774 sorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
17775 work[iwork], &i__2, &ierr);
17776 ie = itau;
17777 itauq = ie + *n;
17778 itaup = itauq + *n;
17779 iwork = itaup + *n;
17780
17781
17782
17783 i__2 = *n - 1;
17784 i__3 = *n - 1;
17785 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &a_ref(2,
17786 1), lda);
17787
17788
17789
17790
17791 i__2 = *lwork - iwork + 1;
17792 sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
17793 work[itauq], &work[itaup], &work[iwork], &
17794 i__2, &ierr);
17795
17796
17797
17798
17799 i__2 = *lwork - iwork + 1;
17800 sormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
17801 work[itauq], &u[u_offset], ldu, &work[iwork],
17802 &i__2, &ierr)
17803 ;
17804 iwork = ie + *n;
17805
17806
17807
17808
17809
17810 sbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie],
17811 dum, &c__1, &u[u_offset], ldu, dum, &c__1, &
17812 work[iwork], info);
17813
17814 }
17815
17816 } else if (wntvo) {
17817
17818
17819
17820
17821
17822
17823 i__2 = *n << 2;
17824 if (*lwork >= (*n << 1) * *n + f2cmax(i__2,bdspac)) {
17825
17826
17827
17828 iu = 1;
17829 if (*lwork >= wrkbl + (*lda << 1) * *n) {
17830
17831
17832
17833 ldwrku = *lda;
17834 ir = iu + ldwrku * *n;
17835 ldwrkr = *lda;
17836 } else if (*lwork >= wrkbl + (*lda + *n) * *n) {
17837
17838
17839
17840 ldwrku = *lda;
17841 ir = iu + ldwrku * *n;
17842 ldwrkr = *n;
17843 } else {
17844
17845
17846
17847 ldwrku = *n;
17848 ir = iu + ldwrku * *n;
17849 ldwrkr = *n;
17850 }
17851 itau = ir + ldwrkr * *n;
17852 iwork = itau + *n;
17853
17854
17855
17856
17857 i__2 = *lwork - iwork + 1;
17858 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
17859 iwork], &i__2, &ierr);
17860
17861
17862
17863 slacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
17864 ldwrku);
17865 i__2 = *n - 1;
17866 i__3 = *n - 1;
17867 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[iu
17868 + 1], &ldwrku);
17869
17870
17871
17872
17873 i__2 = *lwork - iwork + 1;
17874 sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &
17875 work[iwork], &i__2, &ierr);
17876 ie = itau;
17877 itauq = ie + *n;
17878 itaup = itauq + *n;
17879 iwork = itaup + *n;
17880
17881
17882
17883
17884
17885
17886 i__2 = *lwork - iwork + 1;
17887 sgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
17888 work[itauq], &work[itaup], &work[iwork], &
17889 i__2, &ierr);
17890 slacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
17891 ldwrkr);
17892
17893
17894
17895
17896 i__2 = *lwork - iwork + 1;
17897 sorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
17898 , &work[iwork], &i__2, &ierr);
17899
17900
17901
17902
17903
17904 i__2 = *lwork - iwork + 1;
17905 sorgbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
17906 , &work[iwork], &i__2, &ierr);
17907 iwork = ie + *n;
17908
17909
17910
17911
17912
17913
17914 sbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &work[
17915 ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1,
17916 &work[iwork], info);
17917
17918
17919
17920
17921
17922 sgemm_("N", "N", m, n, n, &c_b438, &a[a_offset], lda,
17923 &work[iu], &ldwrku, &c_b416, &u[u_offset],
17924 ldu);
17925
17926
17927
17928
17929 slacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
17930 lda);
17931
17932 } else {
17933
17934
17935
17936 itau = 1;
17937 iwork = itau + *n;
17938
17939
17940
17941
17942 i__2 = *lwork - iwork + 1;
17943 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
17944 iwork], &i__2, &ierr);
17945 slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
17946 ldu);
17947
17948
17949
17950
17951 i__2 = *lwork - iwork + 1;
17952 sorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
17953 work[iwork], &i__2, &ierr);
17954 ie = itau;
17955 itauq = ie + *n;
17956 itaup = itauq + *n;
17957 iwork = itaup + *n;
17958
17959
17960
17961 i__2 = *n - 1;
17962 i__3 = *n - 1;
17963 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &a_ref(2,
17964 1), lda);
17965
17966
17967
17968
17969 i__2 = *lwork - iwork + 1;
17970 sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
17971 work[itauq], &work[itaup], &work[iwork], &
17972 i__2, &ierr);
17973
17974
17975
17976
17977 i__2 = *lwork - iwork + 1;
17978 sormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
17979 work[itauq], &u[u_offset], ldu, &work[iwork],
17980 &i__2, &ierr)
17981 ;
17982
17983
17984
17985
17986 i__2 = *lwork - iwork + 1;
17987 sorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
17988 &work[iwork], &i__2, &ierr);
17989 iwork = ie + *n;
17990
17991
17992
17993
17994
17995
17996 sbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &a[
17997 a_offset], lda, &u[u_offset], ldu, dum, &c__1,
17998 &work[iwork], info);
17999
18000 }
18001
18002 } else if (wntvas) {
18003
18004
18005
18006
18007
18008
18009
18010 i__2 = *n << 2;
18011 if (*lwork >= *n * *n + f2cmax(i__2,bdspac)) {
18012
18013
18014
18015 iu = 1;
18016 if (*lwork >= wrkbl + *lda * *n) {
18017
18018
18019
18020 ldwrku = *lda;
18021 } else {
18022
18023
18024
18025 ldwrku = *n;
18026 }
18027 itau = iu + ldwrku * *n;
18028 iwork = itau + *n;
18029
18030
18031
18032
18033 i__2 = *lwork - iwork + 1;
18034 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
18035 iwork], &i__2, &ierr);
18036
18037
18038
18039 slacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
18040 ldwrku);
18041 i__2 = *n - 1;
18042 i__3 = *n - 1;
18043 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[iu
18044 + 1], &ldwrku);
18045
18046
18047
18048
18049 i__2 = *lwork - iwork + 1;
18050 sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &
18051 work[iwork], &i__2, &ierr);
18052 ie = itau;
18053 itauq = ie + *n;
18054 itaup = itauq + *n;
18055 iwork = itaup + *n;
18056
18057
18058
18059
18060 i__2 = *lwork - iwork + 1;
18061 sgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
18062 work[itauq], &work[itaup], &work[iwork], &
18063 i__2, &ierr);
18064 slacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
18065 ldvt);
18066
18067
18068
18069
18070 i__2 = *lwork - iwork + 1;
18071 sorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
18072 , &work[iwork], &i__2, &ierr);
18073
18074
18075
18076
18077
18078 i__2 = *lwork - iwork + 1;
18079 sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
18080 itaup], &work[iwork], &i__2, &ierr)
18081 ;
18082 iwork = ie + *n;
18083
18084
18085
18086
18087
18088
18089 sbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[
18090 vt_offset], ldvt, &work[iu], &ldwrku, dum, &
18091 c__1, &work[iwork], info);
18092
18093
18094
18095
18096
18097 sgemm_("N", "N", m, n, n, &c_b438, &a[a_offset], lda,
18098 &work[iu], &ldwrku, &c_b416, &u[u_offset],
18099 ldu);
18100
18101 } else {
18102
18103
18104
18105 itau = 1;
18106 iwork = itau + *n;
18107
18108
18109
18110
18111 i__2 = *lwork - iwork + 1;
18112 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
18113 iwork], &i__2, &ierr);
18114 slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
18115 ldu);
18116
18117
18118
18119
18120 i__2 = *lwork - iwork + 1;
18121 sorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
18122 work[iwork], &i__2, &ierr);
18123
18124
18125
18126 slacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
18127 ldvt);
18128 i__2 = *n - 1;
18129 i__3 = *n - 1;
18130 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &vt_ref(
18131 2, 1), ldvt);
18132 ie = itau;
18133 itauq = ie + *n;
18134 itaup = itauq + *n;
18135 iwork = itaup + *n;
18136
18137
18138
18139
18140 i__2 = *lwork - iwork + 1;
18141 sgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie],
18142 &work[itauq], &work[itaup], &work[iwork], &
18143 i__2, &ierr);
18144
18145
18146
18147
18148
18149 i__2 = *lwork - iwork + 1;
18150 sormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
18151 &work[itauq], &u[u_offset], ldu, &work[iwork],
18152 &i__2, &ierr);
18153
18154
18155
18156
18157 i__2 = *lwork - iwork + 1;
18158 sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
18159 itaup], &work[iwork], &i__2, &ierr)
18160 ;
18161 iwork = ie + *n;
18162
18163
18164
18165
18166
18167
18168 sbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[
18169 vt_offset], ldvt, &u[u_offset], ldu, dum, &
18170 c__1, &work[iwork], info);
18171
18172 }
18173
18174 }
18175
18176 } else if (wntua) {
18177
18178 if (wntvn) {
18179
18180
18181
18182
18183
18184
18185 i__2 = *n + *m, i__3 = *n << 2, i__2 = f2cmax(i__2,i__3);
18186 if (*lwork >= *n * *n + f2cmax(i__2,bdspac)) {
18187
18188
18189
18190 ir = 1;
18191 if (*lwork >= wrkbl + *lda * *n) {
18192
18193
18194
18195 ldwrkr = *lda;
18196 } else {
18197
18198
18199
18200 ldwrkr = *n;
18201 }
18202 itau = ir + ldwrkr * *n;
18203 iwork = itau + *n;
18204
18205
18206
18207
18208 i__2 = *lwork - iwork + 1;
18209 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
18210 iwork], &i__2, &ierr);
18211 slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
18212 ldu);
18213
18214
18215
18216 slacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
18217 ldwrkr);
18218 i__2 = *n - 1;
18219 i__3 = *n - 1;
18220 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[ir
18221 + 1], &ldwrkr);
18222
18223
18224
18225
18226 i__2 = *lwork - iwork + 1;
18227 sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
18228 work[iwork], &i__2, &ierr);
18229 ie = itau;
18230 itauq = ie + *n;
18231 itaup = itauq + *n;
18232 iwork = itaup + *n;
18233
18234
18235
18236
18237 i__2 = *lwork - iwork + 1;
18238 sgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &
18239 work[itauq], &work[itaup], &work[iwork], &
18240 i__2, &ierr);
18241
18242
18243
18244
18245 i__2 = *lwork - iwork + 1;
18246 sorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
18247 , &work[iwork], &i__2, &ierr);
18248 iwork = ie + *n;
18249
18250
18251
18252
18253
18254 sbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie],
18255 dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, &
18256 work[iwork], info);
18257
18258
18259
18260
18261
18262 sgemm_("N", "N", m, n, n, &c_b438, &u[u_offset], ldu,
18263 &work[ir], &ldwrkr, &c_b416, &a[a_offset],
18264 lda);
18265
18266
18267
18268 slacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
18269 ldu);
18270
18271 } else {
18272
18273
18274
18275 itau = 1;
18276 iwork = itau + *n;
18277
18278
18279
18280
18281 i__2 = *lwork - iwork + 1;
18282 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
18283 iwork], &i__2, &ierr);
18284 slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
18285 ldu);
18286
18287
18288
18289
18290 i__2 = *lwork - iwork + 1;
18291 sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
18292 work[iwork], &i__2, &ierr);
18293 ie = itau;
18294 itauq = ie + *n;
18295 itaup = itauq + *n;
18296 iwork = itaup + *n;
18297
18298
18299
18300 i__2 = *n - 1;
18301 i__3 = *n - 1;
18302 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &a_ref(2,
18303 1), lda);
18304
18305
18306
18307
18308 i__2 = *lwork - iwork + 1;
18309 sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
18310 work[itauq], &work[itaup], &work[iwork], &
18311 i__2, &ierr);
18312
18313
18314
18315
18316
18317 i__2 = *lwork - iwork + 1;
18318 sormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
18319 work[itauq], &u[u_offset], ldu, &work[iwork],
18320 &i__2, &ierr)
18321 ;
18322 iwork = ie + *n;
18323
18324
18325
18326
18327
18328 sbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie],
18329 dum, &c__1, &u[u_offset], ldu, dum, &c__1, &
18330 work[iwork], info);
18331
18332 }
18333
18334 } else if (wntvo) {
18335
18336
18337
18338
18339
18340
18341 i__2 = *n + *m, i__3 = *n << 2, i__2 = f2cmax(i__2,i__3);
18342 if (*lwork >= (*n << 1) * *n + f2cmax(i__2,bdspac)) {
18343
18344
18345
18346 iu = 1;
18347 if (*lwork >= wrkbl + (*lda << 1) * *n) {
18348
18349
18350
18351 ldwrku = *lda;
18352 ir = iu + ldwrku * *n;
18353 ldwrkr = *lda;
18354 } else if (*lwork >= wrkbl + (*lda + *n) * *n) {
18355
18356
18357
18358 ldwrku = *lda;
18359 ir = iu + ldwrku * *n;
18360 ldwrkr = *n;
18361 } else {
18362
18363
18364
18365 ldwrku = *n;
18366 ir = iu + ldwrku * *n;
18367 ldwrkr = *n;
18368 }
18369 itau = ir + ldwrkr * *n;
18370 iwork = itau + *n;
18371
18372
18373
18374
18375 i__2 = *lwork - iwork + 1;
18376 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
18377 iwork], &i__2, &ierr);
18378 slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
18379 ldu);
18380
18381
18382
18383
18384 i__2 = *lwork - iwork + 1;
18385 sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
18386 work[iwork], &i__2, &ierr);
18387
18388
18389
18390 slacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
18391 ldwrku);
18392 i__2 = *n - 1;
18393 i__3 = *n - 1;
18394 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[iu
18395 + 1], &ldwrku);
18396 ie = itau;
18397 itauq = ie + *n;
18398 itaup = itauq + *n;
18399 iwork = itaup + *n;
18400
18401
18402
18403
18404
18405
18406 i__2 = *lwork - iwork + 1;
18407 sgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
18408 work[itauq], &work[itaup], &work[iwork], &
18409 i__2, &ierr);
18410 slacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
18411 ldwrkr);
18412
18413
18414
18415
18416 i__2 = *lwork - iwork + 1;
18417 sorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
18418 , &work[iwork], &i__2, &ierr);
18419
18420
18421
18422
18423
18424 i__2 = *lwork - iwork + 1;
18425 sorgbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
18426 , &work[iwork], &i__2, &ierr);
18427 iwork = ie + *n;
18428
18429
18430
18431
18432
18433
18434 sbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &work[
18435 ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1,
18436 &work[iwork], info);
18437
18438
18439
18440
18441
18442 sgemm_("N", "N", m, n, n, &c_b438, &u[u_offset], ldu,
18443 &work[iu], &ldwrku, &c_b416, &a[a_offset],
18444 lda);
18445
18446
18447
18448 slacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
18449 ldu);
18450
18451
18452
18453 slacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
18454 lda);
18455
18456 } else {
18457
18458
18459
18460 itau = 1;
18461 iwork = itau + *n;
18462
18463
18464
18465
18466 i__2 = *lwork - iwork + 1;
18467 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
18468 iwork], &i__2, &ierr);
18469 slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
18470 ldu);
18471
18472
18473
18474
18475 i__2 = *lwork - iwork + 1;
18476 sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
18477 work[iwork], &i__2, &ierr);
18478 ie = itau;
18479 itauq = ie + *n;
18480 itaup = itauq + *n;
18481 iwork = itaup + *n;
18482
18483
18484
18485 i__2 = *n - 1;
18486 i__3 = *n - 1;
18487 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &a_ref(2,
18488 1), lda);
18489
18490
18491
18492
18493 i__2 = *lwork - iwork + 1;
18494 sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
18495 work[itauq], &work[itaup], &work[iwork], &
18496 i__2, &ierr);
18497
18498
18499
18500
18501
18502 i__2 = *lwork - iwork + 1;
18503 sormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
18504 work[itauq], &u[u_offset], ldu, &work[iwork],
18505 &i__2, &ierr)
18506 ;
18507
18508
18509
18510
18511 i__2 = *lwork - iwork + 1;
18512 sorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
18513 &work[iwork], &i__2, &ierr);
18514 iwork = ie + *n;
18515
18516
18517
18518
18519
18520
18521 sbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &a[
18522 a_offset], lda, &u[u_offset], ldu, dum, &c__1,
18523 &work[iwork], info);
18524
18525 }
18526
18527 } else if (wntvas) {
18528
18529
18530
18531
18532
18533
18534
18535 i__2 = *n + *m, i__3 = *n << 2, i__2 = f2cmax(i__2,i__3);
18536 if (*lwork >= *n * *n + f2cmax(i__2,bdspac)) {
18537
18538
18539
18540 iu = 1;
18541 if (*lwork >= wrkbl + *lda * *n) {
18542
18543
18544
18545 ldwrku = *lda;
18546 } else {
18547
18548
18549
18550 ldwrku = *n;
18551 }
18552 itau = iu + ldwrku * *n;
18553 iwork = itau + *n;
18554
18555
18556
18557
18558 i__2 = *lwork - iwork + 1;
18559 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
18560 iwork], &i__2, &ierr);
18561 slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
18562 ldu);
18563
18564
18565
18566
18567 i__2 = *lwork - iwork + 1;
18568 sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
18569 work[iwork], &i__2, &ierr);
18570
18571
18572
18573 slacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
18574 ldwrku);
18575 i__2 = *n - 1;
18576 i__3 = *n - 1;
18577 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[iu
18578 + 1], &ldwrku);
18579 ie = itau;
18580 itauq = ie + *n;
18581 itaup = itauq + *n;
18582 iwork = itaup + *n;
18583
18584
18585
18586
18587 i__2 = *lwork - iwork + 1;
18588 sgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
18589 work[itauq], &work[itaup], &work[iwork], &
18590 i__2, &ierr);
18591 slacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
18592 ldvt);
18593
18594
18595
18596
18597 i__2 = *lwork - iwork + 1;
18598 sorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
18599 , &work[iwork], &i__2, &ierr);
18600
18601
18602
18603
18604
18605 i__2 = *lwork - iwork + 1;
18606 sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
18607 itaup], &work[iwork], &i__2, &ierr)
18608 ;
18609 iwork = ie + *n;
18610
18611
18612
18613
18614
18615
18616 sbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[
18617 vt_offset], ldvt, &work[iu], &ldwrku, dum, &
18618 c__1, &work[iwork], info);
18619
18620
18621
18622
18623
18624 sgemm_("N", "N", m, n, n, &c_b438, &u[u_offset], ldu,
18625 &work[iu], &ldwrku, &c_b416, &a[a_offset],
18626 lda);
18627
18628
18629
18630 slacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
18631 ldu);
18632
18633 } else {
18634
18635
18636
18637 itau = 1;
18638 iwork = itau + *n;
18639
18640
18641
18642
18643 i__2 = *lwork - iwork + 1;
18644 sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
18645 iwork], &i__2, &ierr);
18646 slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
18647 ldu);
18648
18649
18650
18651
18652 i__2 = *lwork - iwork + 1;
18653 sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
18654 work[iwork], &i__2, &ierr);
18655
18656
18657
18658 slacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
18659 ldvt);
18660 i__2 = *n - 1;
18661 i__3 = *n - 1;
18662 slaset_("L", &i__2, &i__3, &c_b416, &c_b416, &vt_ref(
18663 2, 1), ldvt);
18664 ie = itau;
18665 itauq = ie + *n;
18666 itaup = itauq + *n;
18667 iwork = itaup + *n;
18668
18669
18670
18671
18672 i__2 = *lwork - iwork + 1;
18673 sgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie],
18674 &work[itauq], &work[itaup], &work[iwork], &
18675 i__2, &ierr);
18676
18677
18678
18679
18680
18681 i__2 = *lwork - iwork + 1;
18682 sormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
18683 &work[itauq], &u[u_offset], ldu, &work[iwork],
18684 &i__2, &ierr);
18685
18686
18687
18688
18689 i__2 = *lwork - iwork + 1;
18690 sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
18691 itaup], &work[iwork], &i__2, &ierr)
18692 ;
18693 iwork = ie + *n;
18694
18695
18696
18697
18698
18699
18700 sbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[
18701 vt_offset], ldvt, &u[u_offset], ldu, dum, &
18702 c__1, &work[iwork], info);
18703
18704 }
18705
18706 }
18707
18708 }
18709
18710 } else {
18711
18712
18713
18714
18715
18716
18717 ie = 1;
18718 itauq = ie + *n;
18719 itaup = itauq + *n;
18720 iwork = itaup + *n;
18721
18722
18723
18724
18725 i__2 = *lwork - iwork + 1;
18726 sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
18727 work[itaup], &work[iwork], &i__2, &ierr);
18728 if (wntuas) {
18729
18730
18731
18732
18733
18734 slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
18735 if (wntus) {
18736 ncu = *n;
18737 }
18738 if (wntua) {
18739 ncu = *m;
18740 }
18741 i__2 = *lwork - iwork + 1;
18742 sorgbr_("Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], &
18743 work[iwork], &i__2, &ierr);
18744 }
18745 if (wntvas) {
18746
18747
18748
18749
18750
18751 slacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
18752 i__2 = *lwork - iwork + 1;
18753 sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
18754 work[iwork], &i__2, &ierr);
18755 }
18756 if (wntuo) {
18757
18758
18759
18760
18761
18762 i__2 = *lwork - iwork + 1;
18763 sorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[
18764 iwork], &i__2, &ierr);
18765 }
18766 if (wntvo) {
18767
18768
18769
18770
18771
18772 i__2 = *lwork - iwork + 1;
18773 sorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[
18774 iwork], &i__2, &ierr);
18775 }
18776 iwork = ie + *n;
18777 if (wntuas || wntuo) {
18778 nru = *m;
18779 }
18780 if (wntun) {
18781 nru = 0;
18782 }
18783 if (wntvas || wntvo) {
18784 ncvt = *n;
18785 }
18786 if (wntvn) {
18787 ncvt = 0;
18788 }
18789 if (! wntuo && ! wntvo) {
18790
18791
18792
18793
18794
18795
18796 sbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
18797 vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, &
18798 work[iwork], info);
18799 } else if (! wntuo && wntvo) {
18800
18801
18802
18803
18804
18805
18806 sbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[
18807 a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[
18808 iwork], info);
18809 } else {
18810
18811
18812
18813
18814
18815
18816 sbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
18817 vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, &
18818 work[iwork], info);
18819 }
18820
18821 }
18822
18823 } else {
18824
18825
18826
18827
18828
18829 if (*n >= mnthr) {
18830
18831 if (wntvn) {
18832
18833
18834
18835
18836 itau = 1;
18837 iwork = itau + *m;
18838
18839
18840
18841
18842 i__2 = *lwork - iwork + 1;
18843 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
18844 i__2, &ierr);
18845
18846
18847
18848 i__2 = *m - 1;
18849 i__3 = *m - 1;
18850 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &a_ref(1, 2),
18851 lda);
18852 ie = 1;
18853 itauq = ie + *m;
18854 itaup = itauq + *m;
18855 iwork = itaup + *m;
18856
18857
18858
18859
18860 i__2 = *lwork - iwork + 1;
18861 sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[
18862 itauq], &work[itaup], &work[iwork], &i__2, &ierr);
18863 if (wntuo || wntuas) {
18864
18865
18866
18867
18868 i__2 = *lwork - iwork + 1;
18869 sorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], &
18870 work[iwork], &i__2, &ierr);
18871 }
18872 iwork = ie + *m;
18873 nru = 0;
18874 if (wntuo || wntuas) {
18875 nru = *m;
18876 }
18877
18878
18879
18880
18881
18882 sbdsqr_("U", m, &c__0, &nru, &c__0, &s[1], &work[ie], dum, &
18883 c__1, &a[a_offset], lda, dum, &c__1, &work[iwork],
18884 info);
18885
18886
18887
18888 if (wntuas) {
18889 slacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu);
18890 }
18891
18892 } else if (wntvo && wntun) {
18893
18894
18895
18896
18897
18898
18899 i__2 = *m << 2;
18900 if (*lwork >= *m * *m + f2cmax(i__2,bdspac)) {
18901
18902
18903
18904 ir = 1;
18905
18906 i__2 = wrkbl, i__3 = *lda * *n + *m;
18907 if (*lwork >= f2cmax(i__2,i__3) + *lda * *m) {
18908
18909
18910
18911 ldwrku = *lda;
18912 chunk = *n;
18913 ldwrkr = *lda;
18914 } else {
18915
18916 i__2 = wrkbl, i__3 = *lda * *n + *m;
18917 if (*lwork >= f2cmax(i__2,i__3) + *m * *m) {
18918
18919
18920
18921 ldwrku = *lda;
18922 chunk = *n;
18923 ldwrkr = *m;
18924 } else {
18925
18926
18927
18928 ldwrku = *m;
18929 chunk = (*lwork - *m * *m - *m) / *m;
18930 ldwrkr = *m;
18931 }
18932 }
18933 itau = ir + ldwrkr * *m;
18934 iwork = itau + *m;
18935
18936
18937
18938
18939 i__2 = *lwork - iwork + 1;
18940 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
18941 , &i__2, &ierr);
18942
18943
18944
18945 slacpy_("L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr);
18946 i__2 = *m - 1;
18947 i__3 = *m - 1;
18948 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[ir +
18949 ldwrkr], &ldwrkr);
18950
18951
18952
18953
18954 i__2 = *lwork - iwork + 1;
18955 sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
18956 iwork], &i__2, &ierr);
18957 ie = itau;
18958 itauq = ie + *m;
18959 itaup = itauq + *m;
18960 iwork = itaup + *m;
18961
18962
18963
18964
18965 i__2 = *lwork - iwork + 1;
18966 sgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &work[
18967 itauq], &work[itaup], &work[iwork], &i__2, &ierr);
18968
18969
18970
18971
18972 i__2 = *lwork - iwork + 1;
18973 sorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
18974 work[iwork], &i__2, &ierr);
18975 iwork = ie + *m;
18976
18977
18978
18979
18980
18981 sbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &work[
18982 ir], &ldwrkr, dum, &c__1, dum, &c__1, &work[iwork]
18983 , info);
18984 iu = ie + *m;
18985
18986
18987
18988
18989
18990 i__2 = *n;
18991 i__3 = chunk;
18992 for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
18993 i__3) {
18994
18995 i__4 = *n - i__ + 1;
18996 blk = f2cmin(i__4,chunk);
18997 sgemm_("N", "N", m, &blk, m, &c_b438, &work[ir], &
18998 ldwrkr, &a_ref(1, i__), lda, &c_b416, &work[
18999 iu], &ldwrku);
19000 slacpy_("F", m, &blk, &work[iu], &ldwrku, &a_ref(1,
19001 i__), lda);
19002
19003 }
19004
19005 } else {
19006
19007
19008
19009 ie = 1;
19010 itauq = ie + *m;
19011 itaup = itauq + *m;
19012 iwork = itaup + *m;
19013
19014
19015
19016
19017 i__3 = *lwork - iwork + 1;
19018 sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[
19019 itauq], &work[itaup], &work[iwork], &i__3, &ierr);
19020
19021
19022
19023
19024 i__3 = *lwork - iwork + 1;
19025 sorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &
19026 work[iwork], &i__3, &ierr);
19027 iwork = ie + *m;
19028
19029
19030
19031
19032
19033 sbdsqr_("L", m, n, &c__0, &c__0, &s[1], &work[ie], &a[
19034 a_offset], lda, dum, &c__1, dum, &c__1, &work[
19035 iwork], info);
19036
19037 }
19038
19039 } else if (wntvo && wntuas) {
19040
19041
19042
19043
19044
19045
19046 i__3 = *m << 2;
19047 if (*lwork >= *m * *m + f2cmax(i__3,bdspac)) {
19048
19049
19050
19051 ir = 1;
19052
19053 i__3 = wrkbl, i__2 = *lda * *n + *m;
19054 if (*lwork >= f2cmax(i__3,i__2) + *lda * *m) {
19055
19056
19057
19058 ldwrku = *lda;
19059 chunk = *n;
19060 ldwrkr = *lda;
19061 } else {
19062
19063 i__3 = wrkbl, i__2 = *lda * *n + *m;
19064 if (*lwork >= f2cmax(i__3,i__2) + *m * *m) {
19065
19066
19067
19068 ldwrku = *lda;
19069 chunk = *n;
19070 ldwrkr = *m;
19071 } else {
19072
19073
19074
19075 ldwrku = *m;
19076 chunk = (*lwork - *m * *m - *m) / *m;
19077 ldwrkr = *m;
19078 }
19079 }
19080 itau = ir + ldwrkr * *m;
19081 iwork = itau + *m;
19082
19083
19084
19085
19086 i__3 = *lwork - iwork + 1;
19087 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
19088 , &i__3, &ierr);
19089
19090
19091
19092 slacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
19093 i__3 = *m - 1;
19094 i__2 = *m - 1;
19095 slaset_("U", &i__3, &i__2, &c_b416, &c_b416, &u_ref(1, 2),
19096 ldu);
19097
19098
19099
19100
19101 i__3 = *lwork - iwork + 1;
19102 sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
19103 iwork], &i__3, &ierr);
19104 ie = itau;
19105 itauq = ie + *m;
19106 itaup = itauq + *m;
19107 iwork = itaup + *m;
19108
19109
19110
19111
19112 i__3 = *lwork - iwork + 1;
19113 sgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[
19114 itauq], &work[itaup], &work[iwork], &i__3, &ierr);
19115 slacpy_("U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr);
19116
19117
19118
19119
19120 i__3 = *lwork - iwork + 1;
19121 sorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
19122 work[iwork], &i__3, &ierr);
19123
19124
19125
19126
19127 i__3 = *lwork - iwork + 1;
19128 sorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
19129 work[iwork], &i__3, &ierr);
19130 iwork = ie + *m;
19131
19132
19133
19134
19135
19136
19137 sbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ir],
19138 &ldwrkr, &u[u_offset], ldu, dum, &c__1, &work[
19139 iwork], info);
19140 iu = ie + *m;
19141
19142
19143
19144
19145
19146 i__3 = *n;
19147 i__2 = chunk;
19148 for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
19149 i__2) {
19150
19151 i__4 = *n - i__ + 1;
19152 blk = f2cmin(i__4,chunk);
19153 sgemm_("N", "N", m, &blk, m, &c_b438, &work[ir], &
19154 ldwrkr, &a_ref(1, i__), lda, &c_b416, &work[
19155 iu], &ldwrku);
19156 slacpy_("F", m, &blk, &work[iu], &ldwrku, &a_ref(1,
19157 i__), lda);
19158
19159 }
19160
19161 } else {
19162
19163
19164
19165 itau = 1;
19166 iwork = itau + *m;
19167
19168
19169
19170
19171 i__2 = *lwork - iwork + 1;
19172 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
19173 , &i__2, &ierr);
19174
19175
19176
19177 slacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
19178 i__2 = *m - 1;
19179 i__3 = *m - 1;
19180 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &u_ref(1, 2),
19181 ldu);
19182
19183
19184
19185
19186 i__2 = *lwork - iwork + 1;
19187 sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
19188 iwork], &i__2, &ierr);
19189 ie = itau;
19190 itauq = ie + *m;
19191 itaup = itauq + *m;
19192 iwork = itaup + *m;
19193
19194
19195
19196
19197 i__2 = *lwork - iwork + 1;
19198 sgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[
19199 itauq], &work[itaup], &work[iwork], &i__2, &ierr);
19200
19201
19202
19203
19204 i__2 = *lwork - iwork + 1;
19205 sormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &work[
19206 itaup], &a[a_offset], lda, &work[iwork], &i__2, &
19207 ierr);
19208
19209
19210
19211
19212 i__2 = *lwork - iwork + 1;
19213 sorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
19214 work[iwork], &i__2, &ierr);
19215 iwork = ie + *m;
19216
19217
19218
19219
19220
19221
19222 sbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &a[
19223 a_offset], lda, &u[u_offset], ldu, dum, &c__1, &
19224 work[iwork], info);
19225
19226 }
19227
19228 } else if (wntvs) {
19229
19230 if (wntun) {
19231
19232
19233
19234
19235
19236
19237 i__2 = *m << 2;
19238 if (*lwork >= *m * *m + f2cmax(i__2,bdspac)) {
19239
19240
19241
19242 ir = 1;
19243 if (*lwork >= wrkbl + *lda * *m) {
19244
19245
19246
19247 ldwrkr = *lda;
19248 } else {
19249
19250
19251
19252 ldwrkr = *m;
19253 }
19254 itau = ir + ldwrkr * *m;
19255 iwork = itau + *m;
19256
19257
19258
19259
19260 i__2 = *lwork - iwork + 1;
19261 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
19262 iwork], &i__2, &ierr);
19263
19264
19265
19266 slacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
19267 ldwrkr);
19268 i__2 = *m - 1;
19269 i__3 = *m - 1;
19270 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[ir
19271 + ldwrkr], &ldwrkr);
19272
19273
19274
19275
19276 i__2 = *lwork - iwork + 1;
19277 sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &
19278 work[iwork], &i__2, &ierr);
19279 ie = itau;
19280 itauq = ie + *m;
19281 itaup = itauq + *m;
19282 iwork = itaup + *m;
19283
19284
19285
19286
19287 i__2 = *lwork - iwork + 1;
19288 sgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &
19289 work[itauq], &work[itaup], &work[iwork], &
19290 i__2, &ierr);
19291
19292
19293
19294
19295
19296 i__2 = *lwork - iwork + 1;
19297 sorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
19298 , &work[iwork], &i__2, &ierr);
19299 iwork = ie + *m;
19300
19301
19302
19303
19304
19305 sbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &
19306 work[ir], &ldwrkr, dum, &c__1, dum, &c__1, &
19307 work[iwork], info);
19308
19309
19310
19311
19312
19313 sgemm_("N", "N", m, n, m, &c_b438, &work[ir], &ldwrkr,
19314 &a[a_offset], lda, &c_b416, &vt[vt_offset],
19315 ldvt);
19316
19317 } else {
19318
19319
19320
19321 itau = 1;
19322 iwork = itau + *m;
19323
19324
19325
19326
19327 i__2 = *lwork - iwork + 1;
19328 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
19329 iwork], &i__2, &ierr);
19330
19331
19332
19333 slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
19334 ldvt);
19335
19336
19337
19338
19339 i__2 = *lwork - iwork + 1;
19340 sorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
19341 work[iwork], &i__2, &ierr);
19342 ie = itau;
19343 itauq = ie + *m;
19344 itaup = itauq + *m;
19345 iwork = itaup + *m;
19346
19347
19348
19349 i__2 = *m - 1;
19350 i__3 = *m - 1;
19351 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &a_ref(1,
19352 2), lda);
19353
19354
19355
19356
19357 i__2 = *lwork - iwork + 1;
19358 sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
19359 work[itauq], &work[itaup], &work[iwork], &
19360 i__2, &ierr);
19361
19362
19363
19364
19365 i__2 = *lwork - iwork + 1;
19366 sormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
19367 work[itaup], &vt[vt_offset], ldvt, &work[
19368 iwork], &i__2, &ierr);
19369 iwork = ie + *m;
19370
19371
19372
19373
19374
19375 sbdsqr_("U", m, n, &c__0, &c__0, &s[1], &work[ie], &
19376 vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, &
19377 work[iwork], info);
19378
19379 }
19380
19381 } else if (wntuo) {
19382
19383
19384
19385
19386
19387
19388 i__2 = *m << 2;
19389 if (*lwork >= (*m << 1) * *m + f2cmax(i__2,bdspac)) {
19390
19391
19392
19393 iu = 1;
19394 if (*lwork >= wrkbl + (*lda << 1) * *m) {
19395
19396
19397
19398 ldwrku = *lda;
19399 ir = iu + ldwrku * *m;
19400 ldwrkr = *lda;
19401 } else if (*lwork >= wrkbl + (*lda + *m) * *m) {
19402
19403
19404
19405 ldwrku = *lda;
19406 ir = iu + ldwrku * *m;
19407 ldwrkr = *m;
19408 } else {
19409
19410
19411
19412 ldwrku = *m;
19413 ir = iu + ldwrku * *m;
19414 ldwrkr = *m;
19415 }
19416 itau = ir + ldwrkr * *m;
19417 iwork = itau + *m;
19418
19419
19420
19421
19422 i__2 = *lwork - iwork + 1;
19423 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
19424 iwork], &i__2, &ierr);
19425
19426
19427
19428 slacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
19429 ldwrku);
19430 i__2 = *m - 1;
19431 i__3 = *m - 1;
19432 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[iu
19433 + ldwrku], &ldwrku);
19434
19435
19436
19437
19438 i__2 = *lwork - iwork + 1;
19439 sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &
19440 work[iwork], &i__2, &ierr);
19441 ie = itau;
19442 itauq = ie + *m;
19443 itaup = itauq + *m;
19444 iwork = itaup + *m;
19445
19446
19447
19448
19449
19450
19451 i__2 = *lwork - iwork + 1;
19452 sgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
19453 work[itauq], &work[itaup], &work[iwork], &
19454 i__2, &ierr);
19455 slacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
19456 ldwrkr);
19457
19458
19459
19460
19461
19462 i__2 = *lwork - iwork + 1;
19463 sorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
19464 , &work[iwork], &i__2, &ierr);
19465
19466
19467
19468
19469 i__2 = *lwork - iwork + 1;
19470 sorgbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
19471 , &work[iwork], &i__2, &ierr);
19472 iwork = ie + *m;
19473
19474
19475
19476
19477
19478
19479 sbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
19480 iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1,
19481 &work[iwork], info);
19482
19483
19484
19485
19486
19487 sgemm_("N", "N", m, n, m, &c_b438, &work[iu], &ldwrku,
19488 &a[a_offset], lda, &c_b416, &vt[vt_offset],
19489 ldvt);
19490
19491
19492
19493
19494 slacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
19495 lda);
19496
19497 } else {
19498
19499
19500
19501 itau = 1;
19502 iwork = itau + *m;
19503
19504
19505
19506
19507 i__2 = *lwork - iwork + 1;
19508 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
19509 iwork], &i__2, &ierr);
19510 slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
19511 ldvt);
19512
19513
19514
19515
19516 i__2 = *lwork - iwork + 1;
19517 sorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
19518 work[iwork], &i__2, &ierr);
19519 ie = itau;
19520 itauq = ie + *m;
19521 itaup = itauq + *m;
19522 iwork = itaup + *m;
19523
19524
19525
19526 i__2 = *m - 1;
19527 i__3 = *m - 1;
19528 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &a_ref(1,
19529 2), lda);
19530
19531
19532
19533
19534 i__2 = *lwork - iwork + 1;
19535 sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
19536 work[itauq], &work[itaup], &work[iwork], &
19537 i__2, &ierr);
19538
19539
19540
19541
19542 i__2 = *lwork - iwork + 1;
19543 sormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
19544 work[itaup], &vt[vt_offset], ldvt, &work[
19545 iwork], &i__2, &ierr);
19546
19547
19548
19549
19550 i__2 = *lwork - iwork + 1;
19551 sorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
19552 &work[iwork], &i__2, &ierr);
19553 iwork = ie + *m;
19554
19555
19556
19557
19558
19559
19560 sbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
19561 vt_offset], ldvt, &a[a_offset], lda, dum, &
19562 c__1, &work[iwork], info);
19563
19564 }
19565
19566 } else if (wntuas) {
19567
19568
19569
19570
19571
19572
19573
19574 i__2 = *m << 2;
19575 if (*lwork >= *m * *m + f2cmax(i__2,bdspac)) {
19576
19577
19578
19579 iu = 1;
19580 if (*lwork >= wrkbl + *lda * *m) {
19581
19582
19583
19584 ldwrku = *lda;
19585 } else {
19586
19587
19588
19589 ldwrku = *m;
19590 }
19591 itau = iu + ldwrku * *m;
19592 iwork = itau + *m;
19593
19594
19595
19596
19597 i__2 = *lwork - iwork + 1;
19598 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
19599 iwork], &i__2, &ierr);
19600
19601
19602
19603 slacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
19604 ldwrku);
19605 i__2 = *m - 1;
19606 i__3 = *m - 1;
19607 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[iu
19608 + ldwrku], &ldwrku);
19609
19610
19611
19612
19613 i__2 = *lwork - iwork + 1;
19614 sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &
19615 work[iwork], &i__2, &ierr);
19616 ie = itau;
19617 itauq = ie + *m;
19618 itaup = itauq + *m;
19619 iwork = itaup + *m;
19620
19621
19622
19623
19624 i__2 = *lwork - iwork + 1;
19625 sgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
19626 work[itauq], &work[itaup], &work[iwork], &
19627 i__2, &ierr);
19628 slacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
19629 ldu);
19630
19631
19632
19633
19634
19635 i__2 = *lwork - iwork + 1;
19636 sorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
19637 , &work[iwork], &i__2, &ierr);
19638
19639
19640
19641
19642 i__2 = *lwork - iwork + 1;
19643 sorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
19644 &work[iwork], &i__2, &ierr);
19645 iwork = ie + *m;
19646
19647
19648
19649
19650
19651
19652 sbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
19653 iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, &
19654 work[iwork], info);
19655
19656
19657
19658
19659
19660 sgemm_("N", "N", m, n, m, &c_b438, &work[iu], &ldwrku,
19661 &a[a_offset], lda, &c_b416, &vt[vt_offset],
19662 ldvt);
19663
19664 } else {
19665
19666
19667
19668 itau = 1;
19669 iwork = itau + *m;
19670
19671
19672
19673
19674 i__2 = *lwork - iwork + 1;
19675 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
19676 iwork], &i__2, &ierr);
19677 slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
19678 ldvt);
19679
19680
19681
19682
19683 i__2 = *lwork - iwork + 1;
19684 sorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
19685 work[iwork], &i__2, &ierr);
19686
19687
19688
19689 slacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
19690 ldu);
19691 i__2 = *m - 1;
19692 i__3 = *m - 1;
19693 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &u_ref(1,
19694 2), ldu);
19695 ie = itau;
19696 itauq = ie + *m;
19697 itaup = itauq + *m;
19698 iwork = itaup + *m;
19699
19700
19701
19702
19703 i__2 = *lwork - iwork + 1;
19704 sgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &
19705 work[itauq], &work[itaup], &work[iwork], &
19706 i__2, &ierr);
19707
19708
19709
19710
19711
19712 i__2 = *lwork - iwork + 1;
19713 sormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &
19714 work[itaup], &vt[vt_offset], ldvt, &work[
19715 iwork], &i__2, &ierr);
19716
19717
19718
19719
19720 i__2 = *lwork - iwork + 1;
19721 sorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
19722 &work[iwork], &i__2, &ierr);
19723 iwork = ie + *m;
19724
19725
19726
19727
19728
19729
19730 sbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
19731 vt_offset], ldvt, &u[u_offset], ldu, dum, &
19732 c__1, &work[iwork], info);
19733
19734 }
19735
19736 }
19737
19738 } else if (wntva) {
19739
19740 if (wntun) {
19741
19742
19743
19744
19745
19746
19747 i__2 = *n + *m, i__3 = *m << 2, i__2 = f2cmax(i__2,i__3);
19748 if (*lwork >= *m * *m + f2cmax(i__2,bdspac)) {
19749
19750
19751
19752 ir = 1;
19753 if (*lwork >= wrkbl + *lda * *m) {
19754
19755
19756
19757 ldwrkr = *lda;
19758 } else {
19759
19760
19761
19762 ldwrkr = *m;
19763 }
19764 itau = ir + ldwrkr * *m;
19765 iwork = itau + *m;
19766
19767
19768
19769
19770 i__2 = *lwork - iwork + 1;
19771 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
19772 iwork], &i__2, &ierr);
19773 slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
19774 ldvt);
19775
19776
19777
19778 slacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
19779 ldwrkr);
19780 i__2 = *m - 1;
19781 i__3 = *m - 1;
19782 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[ir
19783 + ldwrkr], &ldwrkr);
19784
19785
19786
19787
19788 i__2 = *lwork - iwork + 1;
19789 sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
19790 work[iwork], &i__2, &ierr);
19791 ie = itau;
19792 itauq = ie + *m;
19793 itaup = itauq + *m;
19794 iwork = itaup + *m;
19795
19796
19797
19798
19799 i__2 = *lwork - iwork + 1;
19800 sgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &
19801 work[itauq], &work[itaup], &work[iwork], &
19802 i__2, &ierr);
19803
19804
19805
19806
19807
19808 i__2 = *lwork - iwork + 1;
19809 sorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
19810 , &work[iwork], &i__2, &ierr);
19811 iwork = ie + *m;
19812
19813
19814
19815
19816
19817 sbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &
19818 work[ir], &ldwrkr, dum, &c__1, dum, &c__1, &
19819 work[iwork], info);
19820
19821
19822
19823
19824
19825 sgemm_("N", "N", m, n, m, &c_b438, &work[ir], &ldwrkr,
19826 &vt[vt_offset], ldvt, &c_b416, &a[a_offset],
19827 lda);
19828
19829
19830
19831 slacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
19832 ldvt);
19833
19834 } else {
19835
19836
19837
19838 itau = 1;
19839 iwork = itau + *m;
19840
19841
19842
19843
19844 i__2 = *lwork - iwork + 1;
19845 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
19846 iwork], &i__2, &ierr);
19847 slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
19848 ldvt);
19849
19850
19851
19852
19853 i__2 = *lwork - iwork + 1;
19854 sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
19855 work[iwork], &i__2, &ierr);
19856 ie = itau;
19857 itauq = ie + *m;
19858 itaup = itauq + *m;
19859 iwork = itaup + *m;
19860
19861
19862
19863 i__2 = *m - 1;
19864 i__3 = *m - 1;
19865 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &a_ref(1,
19866 2), lda);
19867
19868
19869
19870
19871 i__2 = *lwork - iwork + 1;
19872 sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
19873 work[itauq], &work[itaup], &work[iwork], &
19874 i__2, &ierr);
19875
19876
19877
19878
19879
19880 i__2 = *lwork - iwork + 1;
19881 sormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
19882 work[itaup], &vt[vt_offset], ldvt, &work[
19883 iwork], &i__2, &ierr);
19884 iwork = ie + *m;
19885
19886
19887
19888
19889
19890 sbdsqr_("U", m, n, &c__0, &c__0, &s[1], &work[ie], &
19891 vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, &
19892 work[iwork], info);
19893
19894 }
19895
19896 } else if (wntuo) {
19897
19898
19899
19900
19901
19902
19903 i__2 = *n + *m, i__3 = *m << 2, i__2 = f2cmax(i__2,i__3);
19904 if (*lwork >= (*m << 1) * *m + f2cmax(i__2,bdspac)) {
19905
19906
19907
19908 iu = 1;
19909 if (*lwork >= wrkbl + (*lda << 1) * *m) {
19910
19911
19912
19913 ldwrku = *lda;
19914 ir = iu + ldwrku * *m;
19915 ldwrkr = *lda;
19916 } else if (*lwork >= wrkbl + (*lda + *m) * *m) {
19917
19918
19919
19920 ldwrku = *lda;
19921 ir = iu + ldwrku * *m;
19922 ldwrkr = *m;
19923 } else {
19924
19925
19926
19927 ldwrku = *m;
19928 ir = iu + ldwrku * *m;
19929 ldwrkr = *m;
19930 }
19931 itau = ir + ldwrkr * *m;
19932 iwork = itau + *m;
19933
19934
19935
19936
19937 i__2 = *lwork - iwork + 1;
19938 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
19939 iwork], &i__2, &ierr);
19940 slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
19941 ldvt);
19942
19943
19944
19945
19946 i__2 = *lwork - iwork + 1;
19947 sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
19948 work[iwork], &i__2, &ierr);
19949
19950
19951
19952 slacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
19953 ldwrku);
19954 i__2 = *m - 1;
19955 i__3 = *m - 1;
19956 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[iu
19957 + ldwrku], &ldwrku);
19958 ie = itau;
19959 itauq = ie + *m;
19960 itaup = itauq + *m;
19961 iwork = itaup + *m;
19962
19963
19964
19965
19966
19967
19968 i__2 = *lwork - iwork + 1;
19969 sgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
19970 work[itauq], &work[itaup], &work[iwork], &
19971 i__2, &ierr);
19972 slacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
19973 ldwrkr);
19974
19975
19976
19977
19978
19979 i__2 = *lwork - iwork + 1;
19980 sorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
19981 , &work[iwork], &i__2, &ierr);
19982
19983
19984
19985
19986 i__2 = *lwork - iwork + 1;
19987 sorgbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
19988 , &work[iwork], &i__2, &ierr);
19989 iwork = ie + *m;
19990
19991
19992
19993
19994
19995
19996 sbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
19997 iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1,
19998 &work[iwork], info);
19999
20000
20001
20002
20003
20004 sgemm_("N", "N", m, n, m, &c_b438, &work[iu], &ldwrku,
20005 &vt[vt_offset], ldvt, &c_b416, &a[a_offset],
20006 lda);
20007
20008
20009
20010 slacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
20011 ldvt);
20012
20013
20014
20015 slacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
20016 lda);
20017
20018 } else {
20019
20020
20021
20022 itau = 1;
20023 iwork = itau + *m;
20024
20025
20026
20027
20028 i__2 = *lwork - iwork + 1;
20029 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
20030 iwork], &i__2, &ierr);
20031 slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
20032 ldvt);
20033
20034
20035
20036
20037 i__2 = *lwork - iwork + 1;
20038 sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
20039 work[iwork], &i__2, &ierr);
20040 ie = itau;
20041 itauq = ie + *m;
20042 itaup = itauq + *m;
20043 iwork = itaup + *m;
20044
20045
20046
20047 i__2 = *m - 1;
20048 i__3 = *m - 1;
20049 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &a_ref(1,
20050 2), lda);
20051
20052
20053
20054
20055 i__2 = *lwork - iwork + 1;
20056 sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
20057 work[itauq], &work[itaup], &work[iwork], &
20058 i__2, &ierr);
20059
20060
20061
20062
20063
20064 i__2 = *lwork - iwork + 1;
20065 sormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
20066 work[itaup], &vt[vt_offset], ldvt, &work[
20067 iwork], &i__2, &ierr);
20068
20069
20070
20071
20072 i__2 = *lwork - iwork + 1;
20073 sorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
20074 &work[iwork], &i__2, &ierr);
20075 iwork = ie + *m;
20076
20077
20078
20079
20080
20081
20082 sbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
20083 vt_offset], ldvt, &a[a_offset], lda, dum, &
20084 c__1, &work[iwork], info);
20085
20086 }
20087
20088 } else if (wntuas) {
20089
20090
20091
20092
20093
20094
20095
20096 i__2 = *n + *m, i__3 = *m << 2, i__2 = f2cmax(i__2,i__3);
20097 if (*lwork >= *m * *m + f2cmax(i__2,bdspac)) {
20098
20099
20100
20101 iu = 1;
20102 if (*lwork >= wrkbl + *lda * *m) {
20103
20104
20105
20106 ldwrku = *lda;
20107 } else {
20108
20109
20110
20111 ldwrku = *m;
20112 }
20113 itau = iu + ldwrku * *m;
20114 iwork = itau + *m;
20115
20116
20117
20118
20119 i__2 = *lwork - iwork + 1;
20120 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
20121 iwork], &i__2, &ierr);
20122 slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
20123 ldvt);
20124
20125
20126
20127
20128 i__2 = *lwork - iwork + 1;
20129 sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
20130 work[iwork], &i__2, &ierr);
20131
20132
20133
20134 slacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
20135 ldwrku);
20136 i__2 = *m - 1;
20137 i__3 = *m - 1;
20138 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[iu
20139 + ldwrku], &ldwrku);
20140 ie = itau;
20141 itauq = ie + *m;
20142 itaup = itauq + *m;
20143 iwork = itaup + *m;
20144
20145
20146
20147
20148 i__2 = *lwork - iwork + 1;
20149 sgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
20150 work[itauq], &work[itaup], &work[iwork], &
20151 i__2, &ierr);
20152 slacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
20153 ldu);
20154
20155
20156
20157
20158 i__2 = *lwork - iwork + 1;
20159 sorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
20160 , &work[iwork], &i__2, &ierr);
20161
20162
20163
20164
20165 i__2 = *lwork - iwork + 1;
20166 sorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
20167 &work[iwork], &i__2, &ierr);
20168 iwork = ie + *m;
20169
20170
20171
20172
20173
20174
20175 sbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
20176 iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, &
20177 work[iwork], info);
20178
20179
20180
20181
20182
20183 sgemm_("N", "N", m, n, m, &c_b438, &work[iu], &ldwrku,
20184 &vt[vt_offset], ldvt, &c_b416, &a[a_offset],
20185 lda);
20186
20187
20188
20189 slacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
20190 ldvt);
20191
20192 } else {
20193
20194
20195
20196 itau = 1;
20197 iwork = itau + *m;
20198
20199
20200
20201
20202 i__2 = *lwork - iwork + 1;
20203 sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
20204 iwork], &i__2, &ierr);
20205 slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
20206 ldvt);
20207
20208
20209
20210
20211 i__2 = *lwork - iwork + 1;
20212 sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
20213 work[iwork], &i__2, &ierr);
20214
20215
20216
20217 slacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
20218 ldu);
20219 i__2 = *m - 1;
20220 i__3 = *m - 1;
20221 slaset_("U", &i__2, &i__3, &c_b416, &c_b416, &u_ref(1,
20222 2), ldu);
20223 ie = itau;
20224 itauq = ie + *m;
20225 itaup = itauq + *m;
20226 iwork = itaup + *m;
20227
20228
20229
20230
20231 i__2 = *lwork - iwork + 1;
20232 sgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &
20233 work[itauq], &work[itaup], &work[iwork], &
20234 i__2, &ierr);
20235
20236
20237
20238
20239
20240 i__2 = *lwork - iwork + 1;
20241 sormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &
20242 work[itaup], &vt[vt_offset], ldvt, &work[
20243 iwork], &i__2, &ierr);
20244
20245
20246
20247
20248 i__2 = *lwork - iwork + 1;
20249 sorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
20250 &work[iwork], &i__2, &ierr);
20251 iwork = ie + *m;
20252
20253
20254
20255
20256
20257
20258 sbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
20259 vt_offset], ldvt, &u[u_offset], ldu, dum, &
20260 c__1, &work[iwork], info);
20261
20262 }
20263
20264 }
20265
20266 }
20267
20268 } else {
20269
20270
20271
20272
20273
20274
20275 ie = 1;
20276 itauq = ie + *m;
20277 itaup = itauq + *m;
20278 iwork = itaup + *m;
20279
20280
20281
20282
20283 i__2 = *lwork - iwork + 1;
20284 sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
20285 work[itaup], &work[iwork], &i__2, &ierr);
20286 if (wntuas) {
20287
20288
20289
20290
20291
20292 slacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
20293 i__2 = *lwork - iwork + 1;
20294 sorgbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
20295 iwork], &i__2, &ierr);
20296 }
20297 if (wntvas) {
20298
20299
20300
20301
20302
20303 slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
20304 if (wntva) {
20305 nrvt = *n;
20306 }
20307 if (wntvs) {
20308 nrvt = *m;
20309 }
20310 i__2 = *lwork - iwork + 1;
20311 sorgbr_("P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup],
20312 &work[iwork], &i__2, &ierr);
20313 }
20314 if (wntuo) {
20315
20316
20317
20318
20319
20320 i__2 = *lwork - iwork + 1;
20321 sorgbr_("Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[
20322 iwork], &i__2, &ierr);
20323 }
20324 if (wntvo) {
20325
20326
20327
20328
20329
20330 i__2 = *lwork - iwork + 1;
20331 sorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
20332 iwork], &i__2, &ierr);
20333 }
20334 iwork = ie + *m;
20335 if (wntuas || wntuo) {
20336 nru = *m;
20337 }
20338 if (wntun) {
20339 nru = 0;
20340 }
20341 if (wntvas || wntvo) {
20342 ncvt = *n;
20343 }
20344 if (wntvn) {
20345 ncvt = 0;
20346 }
20347 if (! wntuo && ! wntvo) {
20348
20349
20350
20351
20352
20353
20354 sbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
20355 vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, &
20356 work[iwork], info);
20357 } else if (! wntuo && wntvo) {
20358
20359
20360
20361
20362
20363
20364 sbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[
20365 a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[
20366 iwork], info);
20367 } else {
20368
20369
20370
20371
20372
20373
20374 sbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
20375 vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, &
20376 work[iwork], info);
20377 }
20378
20379 }
20380
20381 }
20382
20383
20384
20385
20386 if (*info != 0) {
20387 if (ie > 2) {
20388 i__2 = minmn - 1;
20389 for (i__ = 1; i__ <= i__2; ++i__) {
20390 work[i__ + 1] = work[i__ + ie - 1];
20391
20392 }
20393 }
20394 if (ie < 2) {
20395 for (i__ = minmn - 1; i__ >= 1; --i__) {
20396 work[i__ + 1] = work[i__ + ie - 1];
20397
20398 }
20399 }
20400 }
20401
20402
20403
20404 if (iscl == 1) {
20405 if (anrm > bignum) {
20406 slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
20407 minmn, &ierr);
20408 }
20409 if (*info != 0 && anrm > bignum) {
20410 i__2 = minmn - 1;
20411 slascl_("G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &work[2],
20412 &minmn, &ierr);
20413 }
20414 if (anrm < smlnum) {
20415 slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
20416 minmn, &ierr);
20417 }
20418 if (*info != 0 && anrm < smlnum) {
20419 i__2 = minmn - 1;
20420 slascl_("G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &work[2],
20421 &minmn, &ierr);
20422 }
20423 }
20424
20425
20426
20427 work[1] = (real) maxwrk;
20428
20429 return 0;
20430
20431
20432
20433 }
20434
20435 #undef vt_ref
20436 #undef u_ref
20437 #undef a_ref
20438
20439
20440
20441
20442 int sorgl2_(integer *m, integer *n, integer *k, real *a,
20443 integer *lda, real *tau, real *work, integer *info)
20444
20445 {
20446
20447
20448
20449
20450
20451
20452
20453
20454
20455
20456
20457
20458
20459
20460
20461
20462
20463
20464
20465
20466
20467
20468
20469
20470
20471
20472
20473
20474
20475
20476
20477
20478
20479
20480
20481
20482
20483
20484
20485
20486
20487
20488
20489
20490
20491
20492
20493
20494
20495
20496
20497
20498
20499
20500
20501
20502 integer a_dim1, a_offset, i__1, i__2;
20503 real r__1;
20504
20505 static integer i__, j, l;
20506 extern int sscal_(integer *, real *, real *, integer *),
20507 slarf_(const char *, integer *, integer *, real *, integer *, real *,
20508 real *, integer *, real *), xerbla_(const char *, integer *);
20509 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
20510
20511 a_dim1 = *lda;
20512 a_offset = 1 + a_dim1 * 1;
20513 a -= a_offset;
20514 --tau;
20515 --work;
20516
20517
20518 *info = 0;
20519 if (*m < 0) {
20520 *info = -1;
20521 } else if (*n < *m) {
20522 *info = -2;
20523 } else if (*k < 0 || *k > *m) {
20524 *info = -3;
20525 } else if (*lda < f2cmax(1,*m)) {
20526 *info = -5;
20527 }
20528 if (*info != 0) {
20529 i__1 = -(*info);
20530 xerbla_("SORGL2", &i__1);
20531 return 0;
20532 }
20533
20534
20535
20536 if (*m <= 0) {
20537 return 0;
20538 }
20539
20540 if (*k < *m) {
20541
20542
20543
20544 i__1 = *n;
20545 for (j = 1; j <= i__1; ++j) {
20546 i__2 = *m;
20547 for (l = *k + 1; l <= i__2; ++l) {
20548 a_ref(l, j) = 0.f;
20549
20550 }
20551 if (j > *k && j <= *m) {
20552 a_ref(j, j) = 1.f;
20553 }
20554
20555 }
20556 }
20557
20558 for (i__ = *k; i__ >= 1; --i__) {
20559
20560
20561
20562 if (i__ < *n) {
20563 if (i__ < *m) {
20564 a_ref(i__, i__) = 1.f;
20565 i__1 = *m - i__;
20566 i__2 = *n - i__ + 1;
20567 slarf_("Right", &i__1, &i__2, &a_ref(i__, i__), lda, &tau[i__]
20568 , &a_ref(i__ + 1, i__), lda, &work[1]);
20569 }
20570 i__1 = *n - i__;
20571 r__1 = -tau[i__];
20572 sscal_(&i__1, &r__1, &a_ref(i__, i__ + 1), lda);
20573 }
20574 a_ref(i__, i__) = 1.f - tau[i__];
20575
20576
20577
20578 i__1 = i__ - 1;
20579 for (l = 1; l <= i__1; ++l) {
20580 a_ref(i__, l) = 0.f;
20581
20582 }
20583
20584 }
20585 return 0;
20586
20587
20588
20589 }
20590
20591 #undef a_ref
20592
20593
20594
20595 int sorglq_(integer *m, integer *n, integer *k, real *a,
20596 integer *lda, real *tau, real *work, integer *lwork, integer *info)
20597 {
20598
20599
20600
20601
20602
20603
20604
20605
20606
20607
20608
20609
20610
20611
20612
20613
20614
20615
20616
20617
20618
20619
20620
20621
20622
20623
20624
20625
20626
20627
20628
20629
20630
20631
20632
20633
20634
20635
20636
20637
20638
20639
20640
20641
20642
20643
20644
20645
20646
20647
20648
20649
20650
20651
20652
20653
20654
20655
20656
20657
20658
20659
20660
20661
20662
20663
20664
20665 static integer c__1 = 1;
20666 static integer c_n1 = -1;
20667 static integer c__3 = 3;
20668 static integer c__2 = 2;
20669
20670
20671 integer a_dim1, a_offset, i__1, i__2, i__3;
20672
20673 static integer i__, j, l, nbmin, iinfo;
20674 extern int sorgl2_(integer *, integer *, integer *, real
20675 *, integer *, real *, real *, integer *);
20676 static integer ib, nb, ki, kk, nx;
20677 extern int slarfb_(const char *, const char *, const char *, const char *,
20678 integer *, integer *, integer *, real *, integer *, real *,
20679 integer *, real *, integer *, real *, integer *), xerbla_(const char *, integer *);
20680 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
20681 integer *, integer *, ftnlen, ftnlen);
20682 extern int slarft_(const char *, const char *, integer *, integer *,
20683 real *, integer *, real *, real *, integer *);
20684 static integer ldwork, lwkopt;
20685 static logical lquery;
20686 static integer iws;
20687 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
20688
20689
20690 a_dim1 = *lda;
20691 a_offset = 1 + a_dim1 * 1;
20692 a -= a_offset;
20693 --tau;
20694 --work;
20695
20696
20697 *info = 0;
20698 nb = ilaenv_(&c__1, "SORGLQ", " ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
20699 lwkopt = f2cmax(1,*m) * nb;
20700 work[1] = (real) lwkopt;
20701 lquery = *lwork == -1;
20702 if (*m < 0) {
20703 *info = -1;
20704 } else if (*n < *m) {
20705 *info = -2;
20706 } else if (*k < 0 || *k > *m) {
20707 *info = -3;
20708 } else if (*lda < f2cmax(1,*m)) {
20709 *info = -5;
20710 } else if (*lwork < f2cmax(1,*m) && ! lquery) {
20711 *info = -8;
20712 }
20713 if (*info != 0) {
20714 i__1 = -(*info);
20715 xerbla_("SORGLQ", &i__1);
20716 return 0;
20717 } else if (lquery) {
20718 return 0;
20719 }
20720
20721
20722
20723 if (*m <= 0) {
20724 work[1] = 1.f;
20725 return 0;
20726 }
20727
20728 nbmin = 2;
20729 nx = 0;
20730 iws = *m;
20731 if (nb > 1 && nb < *k) {
20732
20733
20734
20735
20736 i__1 = 0, i__2 = ilaenv_(&c__3, "SORGLQ", " ", m, n, k, &c_n1, (
20737 ftnlen)6, (ftnlen)1);
20738 nx = f2cmax(i__1,i__2);
20739 if (nx < *k) {
20740
20741
20742
20743 ldwork = *m;
20744 iws = ldwork * nb;
20745 if (*lwork < iws) {
20746
20747
20748
20749
20750 nb = *lwork / ldwork;
20751
20752 i__1 = 2, i__2 = ilaenv_(&c__2, "SORGLQ", " ", m, n, k, &c_n1,
20753 (ftnlen)6, (ftnlen)1);
20754 nbmin = f2cmax(i__1,i__2);
20755 }
20756 }
20757 }
20758
20759 if (nb >= nbmin && nb < *k && nx < *k) {
20760
20761
20762
20763
20764 ki = (*k - nx - 1) / nb * nb;
20765
20766 i__1 = *k, i__2 = ki + nb;
20767 kk = f2cmin(i__1,i__2);
20768
20769
20770
20771 i__1 = kk;
20772 for (j = 1; j <= i__1; ++j) {
20773 i__2 = *m;
20774 for (i__ = kk + 1; i__ <= i__2; ++i__) {
20775 a_ref(i__, j) = 0.f;
20776
20777 }
20778
20779 }
20780 } else {
20781 kk = 0;
20782 }
20783
20784
20785
20786 if (kk < *m) {
20787 i__1 = *m - kk;
20788 i__2 = *n - kk;
20789 i__3 = *k - kk;
20790 sorgl2_(&i__1, &i__2, &i__3, &a_ref(kk + 1, kk + 1), lda, &tau[kk + 1]
20791 , &work[1], &iinfo);
20792 }
20793
20794 if (kk > 0) {
20795
20796
20797
20798 i__1 = -nb;
20799 for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
20800
20801 i__2 = nb, i__3 = *k - i__ + 1;
20802 ib = f2cmin(i__2,i__3);
20803 if (i__ + ib <= *m) {
20804
20805
20806
20807
20808 i__2 = *n - i__ + 1;
20809 slarft_("Forward", "Rowwise", &i__2, &ib, &a_ref(i__, i__),
20810 lda, &tau[i__], &work[1], &ldwork);
20811
20812
20813
20814 i__2 = *m - i__ - ib + 1;
20815 i__3 = *n - i__ + 1;
20816 slarfb_("Right", "Transpose", "Forward", "Rowwise", &i__2, &
20817 i__3, &ib, &a_ref(i__, i__), lda, &work[1], &ldwork, &
20818 a_ref(i__ + ib, i__), lda, &work[ib + 1], &ldwork);
20819 }
20820
20821
20822
20823 i__2 = *n - i__ + 1;
20824 sorgl2_(&ib, &i__2, &ib, &a_ref(i__, i__), lda, &tau[i__], &work[
20825 1], &iinfo);
20826
20827
20828
20829 i__2 = i__ - 1;
20830 for (j = 1; j <= i__2; ++j) {
20831 i__3 = i__ + ib - 1;
20832 for (l = i__; l <= i__3; ++l) {
20833 a_ref(l, j) = 0.f;
20834
20835 }
20836
20837 }
20838
20839 }
20840 }
20841
20842 work[1] = (real) iws;
20843 return 0;
20844
20845
20846
20847 }
20848
20849 #undef a_ref
20850
20851
20852
20853 doublereal slange_(const char *norm, integer *m, integer *n, real *a, integer *lda,
20854 real *work)
20855 {
20856
20857
20858
20859
20860
20861
20862
20863
20864
20865
20866
20867
20868
20869
20870
20871
20872
20873
20874
20875
20876
20877
20878
20879
20880
20881
20882
20883
20884
20885
20886
20887
20888
20889
20890
20891
20892
20893
20894
20895
20896
20897
20898
20899
20900
20901
20902
20903
20904
20905
20906
20907
20908
20909
20910
20911
20912
20913
20914
20915
20916
20917 static integer c__1 = 1;
20918
20919
20920 integer a_dim1, a_offset, i__1, i__2;
20921 real ret_val, r__1, r__2, r__3;
20922
20923
20924
20925 static integer i__, j;
20926 static real scale;
20927 extern logical lsame_(const char *, const char *);
20928 static real value;
20929 extern int slassq_(integer *, real *, integer *, real *,
20930 real *);
20931 static real sum;
20932 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
20933
20934
20935 a_dim1 = *lda;
20936 a_offset = 1 + a_dim1 * 1;
20937 a -= a_offset;
20938 --work;
20939
20940
20941 if (f2cmin(*m,*n) == 0) {
20942 value = 0.f;
20943 } else if (lsame_(norm, "M")) {
20944
20945
20946
20947 value = 0.f;
20948 i__1 = *n;
20949 for (j = 1; j <= i__1; ++j) {
20950 i__2 = *m;
20951 for (i__ = 1; i__ <= i__2; ++i__) {
20952
20953 r__2 = value, r__3 = (r__1 = a_ref(i__, j), dabs(r__1));
20954 value = df2cmax(r__2,r__3);
20955
20956 }
20957
20958 }
20959 } else if (lsame_(norm, "O") || *(unsigned char *)
20960 norm == '1') {
20961
20962
20963
20964 value = 0.f;
20965 i__1 = *n;
20966 for (j = 1; j <= i__1; ++j) {
20967 sum = 0.f;
20968 i__2 = *m;
20969 for (i__ = 1; i__ <= i__2; ++i__) {
20970 sum += (r__1 = a_ref(i__, j), dabs(r__1));
20971
20972 }
20973 value = df2cmax(value,sum);
20974
20975 }
20976 } else if (lsame_(norm, "I")) {
20977
20978
20979
20980 i__1 = *m;
20981 for (i__ = 1; i__ <= i__1; ++i__) {
20982 work[i__] = 0.f;
20983
20984 }
20985 i__1 = *n;
20986 for (j = 1; j <= i__1; ++j) {
20987 i__2 = *m;
20988 for (i__ = 1; i__ <= i__2; ++i__) {
20989 work[i__] += (r__1 = a_ref(i__, j), dabs(r__1));
20990
20991 }
20992
20993 }
20994 value = 0.f;
20995 i__1 = *m;
20996 for (i__ = 1; i__ <= i__1; ++i__) {
20997
20998 r__1 = value, r__2 = work[i__];
20999 value = df2cmax(r__1,r__2);
21000
21001 }
21002 } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
21003
21004
21005
21006 scale = 0.f;
21007 sum = 1.f;
21008 i__1 = *n;
21009 for (j = 1; j <= i__1; ++j) {
21010 slassq_(m, &a_ref(1, j), &c__1, &scale, &sum);
21011
21012 }
21013 value = scale * sqrt(sum);
21014 }
21015
21016 ret_val = value;
21017 return ret_val;
21018
21019
21020
21021 }
21022
21023 #undef a_ref
21024
21025
21026
21027 int sgebrd_(integer *m, integer *n, real *a, integer *lda,
21028 real *d__, real *e, real *tauq, real *taup, real *work, integer *
21029 lwork, integer *info)
21030 {
21031
21032
21033
21034
21035
21036
21037
21038
21039
21040
21041
21042
21043
21044
21045
21046
21047
21048
21049
21050
21051
21052
21053
21054
21055
21056
21057
21058
21059
21060
21061
21062
21063
21064
21065
21066
21067
21068
21069
21070
21071
21072
21073
21074
21075
21076
21077
21078
21079
21080
21081
21082
21083
21084
21085
21086
21087
21088
21089
21090
21091
21092
21093
21094
21095
21096
21097
21098
21099
21100
21101
21102
21103
21104
21105
21106
21107
21108
21109
21110
21111
21112
21113
21114
21115
21116
21117
21118
21119
21120
21121
21122
21123
21124
21125
21126
21127
21128
21129
21130
21131
21132
21133
21134
21135
21136
21137
21138
21139
21140
21141
21142
21143
21144
21145
21146
21147
21148
21149
21150
21151
21152
21153
21154
21155
21156
21157
21158
21159
21160
21161
21162
21163
21164 static integer c__1 = 1;
21165 static integer c_n1 = -1;
21166 static integer c__3 = 3;
21167 static integer c__2 = 2;
21168 static real c_b21 = -1.f;
21169 static real c_b22 = 1.f;
21170
21171
21172 integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
21173
21174 static integer i__, j, nbmin, iinfo;
21175 extern int sgemm_(const char *, const char *, integer *, integer *,
21176 integer *, real *, real *, integer *, real *, integer *, real *,
21177 real *, integer *);
21178 static integer minmn;
21179 extern int sgebd2_(integer *, integer *, real *, integer
21180 *, real *, real *, real *, real *, real *, integer *);
21181 static integer nb, nx;
21182 extern int slabrd_(integer *, integer *, integer *, real
21183 *, integer *, real *, real *, real *, real *, real *, integer *,
21184 real *, integer *);
21185 static real ws;
21186 extern int xerbla_(const char *, integer *);
21187 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
21188 integer *, integer *, ftnlen, ftnlen);
21189 static integer ldwrkx, ldwrky, lwkopt;
21190 static logical lquery;
21191 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
21192
21193
21194 a_dim1 = *lda;
21195 a_offset = 1 + a_dim1 * 1;
21196 a -= a_offset;
21197 --d__;
21198 --e;
21199 --tauq;
21200 --taup;
21201 --work;
21202
21203
21204 *info = 0;
21205
21206 i__1 = 1, i__2 = ilaenv_(&c__1, "SGEBRD", " ", m, n, &c_n1, &c_n1, (
21207 ftnlen)6, (ftnlen)1);
21208 nb = f2cmax(i__1,i__2);
21209 lwkopt = (*m + *n) * nb;
21210 work[1] = (real) lwkopt;
21211 lquery = *lwork == -1;
21212 if (*m < 0) {
21213 *info = -1;
21214 } else if (*n < 0) {
21215 *info = -2;
21216 } else if (*lda < f2cmax(1,*m)) {
21217 *info = -4;
21218 } else {
21219
21220 i__1 = f2cmax(1,*m);
21221 if (*lwork < f2cmax(i__1,*n) && ! lquery) {
21222 *info = -10;
21223 }
21224 }
21225 if (*info < 0) {
21226 i__1 = -(*info);
21227 xerbla_("SGEBRD", &i__1);
21228 return 0;
21229 } else if (lquery) {
21230 return 0;
21231 }
21232
21233
21234
21235 minmn = f2cmin(*m,*n);
21236 if (minmn == 0) {
21237 work[1] = 1.f;
21238 return 0;
21239 }
21240
21241 ws = (real) f2cmax(*m,*n);
21242 ldwrkx = *m;
21243 ldwrky = *n;
21244
21245 if (nb > 1 && nb < minmn) {
21246
21247
21248
21249
21250 i__1 = nb, i__2 = ilaenv_(&c__3, "SGEBRD", " ", m, n, &c_n1, &c_n1, (
21251 ftnlen)6, (ftnlen)1);
21252 nx = f2cmax(i__1,i__2);
21253
21254
21255
21256 if (nx < minmn) {
21257 ws = (real) ((*m + *n) * nb);
21258 if ((real) (*lwork) < ws) {
21259
21260
21261
21262
21263 nbmin = ilaenv_(&c__2, "SGEBRD", " ", m, n, &c_n1, &c_n1, (
21264 ftnlen)6, (ftnlen)1);
21265 if (*lwork >= (*m + *n) * nbmin) {
21266 nb = *lwork / (*m + *n);
21267 } else {
21268 nb = 1;
21269 nx = minmn;
21270 }
21271 }
21272 }
21273 } else {
21274 nx = minmn;
21275 }
21276
21277 i__1 = minmn - nx;
21278 i__2 = nb;
21279 for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
21280
21281
21282
21283
21284
21285 i__3 = *m - i__ + 1;
21286 i__4 = *n - i__ + 1;
21287 slabrd_(&i__3, &i__4, &nb, &a_ref(i__, i__), lda, &d__[i__], &e[i__],
21288 &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx * nb
21289 + 1], &ldwrky);
21290
21291
21292
21293
21294 i__3 = *m - i__ - nb + 1;
21295 i__4 = *n - i__ - nb + 1;
21296 sgemm_("No transpose", "Transpose", &i__3, &i__4, &nb, &c_b21, &a_ref(
21297 i__ + nb, i__), lda, &work[ldwrkx * nb + nb + 1], &ldwrky, &
21298 c_b22, &a_ref(i__ + nb, i__ + nb), lda)
21299 ;
21300 i__3 = *m - i__ - nb + 1;
21301 i__4 = *n - i__ - nb + 1;
21302 sgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &c_b21, &
21303 work[nb + 1], &ldwrkx, &a_ref(i__, i__ + nb), lda, &c_b22, &
21304 a_ref(i__ + nb, i__ + nb), lda);
21305
21306
21307
21308 if (*m >= *n) {
21309 i__3 = i__ + nb - 1;
21310 for (j = i__; j <= i__3; ++j) {
21311 a_ref(j, j) = d__[j];
21312 a_ref(j, j + 1) = e[j];
21313
21314 }
21315 } else {
21316 i__3 = i__ + nb - 1;
21317 for (j = i__; j <= i__3; ++j) {
21318 a_ref(j, j) = d__[j];
21319 a_ref(j + 1, j) = e[j];
21320
21321 }
21322 }
21323
21324 }
21325
21326
21327
21328 i__2 = *m - i__ + 1;
21329 i__1 = *n - i__ + 1;
21330 sgebd2_(&i__2, &i__1, &a_ref(i__, i__), lda, &d__[i__], &e[i__], &tauq[
21331 i__], &taup[i__], &work[1], &iinfo);
21332 work[1] = ws;
21333 return 0;
21334
21335
21336
21337 }
21338
21339 #undef a_ref
21340
21341
21342
21343 int sgebd2_(integer *m, integer *n, real *a, integer *lda,
21344 real *d__, real *e, real *tauq, real *taup, real *work, integer *info)
21345 {
21346
21347
21348
21349
21350
21351
21352
21353
21354
21355
21356
21357
21358
21359
21360
21361
21362
21363
21364
21365
21366
21367
21368
21369
21370
21371
21372
21373
21374
21375
21376
21377
21378
21379
21380
21381
21382
21383
21384
21385
21386
21387
21388
21389
21390
21391
21392
21393
21394
21395
21396
21397
21398
21399
21400
21401
21402
21403
21404
21405
21406
21407
21408
21409
21410
21411
21412
21413
21414
21415
21416
21417
21418
21419
21420
21421
21422
21423
21424
21425
21426
21427
21428
21429
21430
21431
21432
21433
21434
21435
21436
21437
21438
21439
21440
21441
21442
21443
21444
21445
21446
21447
21448
21449
21450
21451
21452
21453
21454
21455
21456
21457
21458
21459
21460
21461
21462
21463
21464
21465
21466
21467
21468 static integer c__1 = 1;
21469
21470
21471 integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
21472
21473 static integer i__;
21474 extern int slarf_(const char *, integer *, integer *, real *,
21475 integer *, real *, real *, integer *, real *), xerbla_(
21476 const char *, integer *), slarfg_(integer *, real *, real *,
21477 integer *, real *);
21478 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
21479
21480
21481 a_dim1 = *lda;
21482 a_offset = 1 + a_dim1 * 1;
21483 a -= a_offset;
21484 --d__;
21485 --e;
21486 --tauq;
21487 --taup;
21488 --work;
21489
21490
21491 *info = 0;
21492 if (*m < 0) {
21493 *info = -1;
21494 } else if (*n < 0) {
21495 *info = -2;
21496 } else if (*lda < f2cmax(1,*m)) {
21497 *info = -4;
21498 }
21499 if (*info < 0) {
21500 i__1 = -(*info);
21501 xerbla_("SGEBD2", &i__1);
21502 return 0;
21503 }
21504
21505 if (*m >= *n) {
21506
21507
21508
21509 i__1 = *n;
21510 for (i__ = 1; i__ <= i__1; ++i__) {
21511
21512
21513
21514
21515 i__2 = i__ + 1;
21516 i__3 = *m - i__ + 1;
21517 slarfg_(&i__3, &a_ref(i__, i__), &a_ref(f2cmin(i__2,*m), i__), &c__1,
21518 &tauq[i__]);
21519 d__[i__] = a_ref(i__, i__);
21520 a_ref(i__, i__) = 1.f;
21521
21522
21523
21524 i__2 = *m - i__ + 1;
21525 i__3 = *n - i__;
21526 slarf_("Left", &i__2, &i__3, &a_ref(i__, i__), &c__1, &tauq[i__],
21527 &a_ref(i__, i__ + 1), lda, &work[1]);
21528 a_ref(i__, i__) = d__[i__];
21529
21530 if (i__ < *n) {
21531
21532
21533
21534
21535
21536 i__2 = i__ + 2;
21537 i__3 = *n - i__;
21538 slarfg_(&i__3, &a_ref(i__, i__ + 1), &a_ref(i__, f2cmin(i__2,*n))
21539 , lda, &taup[i__]);
21540 e[i__] = a_ref(i__, i__ + 1);
21541 a_ref(i__, i__ + 1) = 1.f;
21542
21543
21544
21545 i__2 = *m - i__;
21546 i__3 = *n - i__;
21547 slarf_("Right", &i__2, &i__3, &a_ref(i__, i__ + 1), lda, &
21548 taup[i__], &a_ref(i__ + 1, i__ + 1), lda, &work[1]);
21549 a_ref(i__, i__ + 1) = e[i__];
21550 } else {
21551 taup[i__] = 0.f;
21552 }
21553
21554 }
21555 } else {
21556
21557
21558
21559 i__1 = *m;
21560 for (i__ = 1; i__ <= i__1; ++i__) {
21561
21562
21563
21564
21565 i__2 = i__ + 1;
21566 i__3 = *n - i__ + 1;
21567 slarfg_(&i__3, &a_ref(i__, i__), &a_ref(i__, f2cmin(i__2,*n)), lda, &
21568 taup[i__]);
21569 d__[i__] = a_ref(i__, i__);
21570 a_ref(i__, i__) = 1.f;
21571
21572
21573
21574
21575 i__2 = i__ + 1;
21576 i__3 = *m - i__;
21577 i__4 = *n - i__ + 1;
21578 slarf_("Right", &i__3, &i__4, &a_ref(i__, i__), lda, &taup[i__], &
21579 a_ref(f2cmin(i__2,*m), i__), lda, &work[1]);
21580 a_ref(i__, i__) = d__[i__];
21581
21582 if (i__ < *m) {
21583
21584
21585
21586
21587
21588 i__2 = i__ + 2;
21589 i__3 = *m - i__;
21590 slarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(f2cmin(i__2,*m), i__)
21591 , &c__1, &tauq[i__]);
21592 e[i__] = a_ref(i__ + 1, i__);
21593 a_ref(i__ + 1, i__) = 1.f;
21594
21595
21596
21597 i__2 = *m - i__;
21598 i__3 = *n - i__;
21599 slarf_("Left", &i__2, &i__3, &a_ref(i__ + 1, i__), &c__1, &
21600 tauq[i__], &a_ref(i__ + 1, i__ + 1), lda, &work[1]);
21601 a_ref(i__ + 1, i__) = e[i__];
21602 } else {
21603 tauq[i__] = 0.f;
21604 }
21605
21606 }
21607 }
21608 return 0;
21609
21610
21611
21612 }
21613
21614 #undef a_ref
21615
21616
21617
21618 int sormbr_(const char *vect, const char *side, const char *trans, integer *m,
21619 integer *n, integer *k, real *a, integer *lda, real *tau, real *c__,
21620 integer *ldc, real *work, integer *lwork, integer *info)
21621 {
21622
21623
21624
21625
21626
21627
21628
21629
21630
21631
21632
21633
21634
21635
21636
21637
21638
21639
21640
21641
21642
21643
21644
21645
21646
21647
21648
21649
21650
21651
21652
21653
21654
21655
21656
21657
21658
21659
21660
21661
21662
21663
21664
21665
21666
21667
21668
21669
21670
21671
21672
21673
21674
21675
21676
21677
21678
21679
21680
21681
21682
21683
21684
21685
21686
21687
21688
21689
21690
21691
21692
21693
21694
21695
21696
21697
21698
21699
21700
21701
21702
21703
21704
21705
21706
21707
21708
21709
21710
21711
21712
21713
21714
21715
21716
21717
21718
21719
21720
21721
21722
21723
21724
21725
21726
21727
21728
21729
21730
21731
21732
21733
21734
21735
21736
21737
21738
21739 static integer c__1 = 1;
21740 static integer c_n1 = -1;
21741 static integer c__2 = 2;
21742
21743 typedef const char *address;
21744
21745
21746 address a__1[2];
21747 integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2];
21748 char ch__1[2];
21749
21750 int s_cat(char *, const char **, integer *, integer *, ftnlen);
21751
21752 static logical left;
21753 extern logical lsame_(const char *, const char *);
21754 static integer iinfo, i1, i2, nb, mi, ni, nq, nw;
21755 extern int xerbla_(const char *, integer *);
21756 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
21757 integer *, integer *, ftnlen, ftnlen);
21758 static logical notran, applyq;
21759 static char transt[1];
21760 extern int sormlq_(const char *, const char *, integer *, integer *,
21761 integer *, real *, integer *, real *, real *, integer *, real *,
21762 integer *, integer *);
21763 static integer lwkopt;
21764 static logical lquery;
21765 extern int sormqr_(const char *, const char *, integer *, integer *,
21766 integer *, real *, integer *, real *, real *, integer *, real *,
21767 integer *, integer *);
21768 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
21769 #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
21770
21771
21772 a_dim1 = *lda;
21773 a_offset = 1 + a_dim1 * 1;
21774 a -= a_offset;
21775 --tau;
21776 c_dim1 = *ldc;
21777 c_offset = 1 + c_dim1 * 1;
21778 c__ -= c_offset;
21779 --work;
21780
21781
21782 *info = 0;
21783 applyq = lsame_(vect, "Q");
21784 left = lsame_(side, "L");
21785 notran = lsame_(trans, "N");
21786 lquery = *lwork == -1;
21787
21788
21789
21790 if (left) {
21791 nq = *m;
21792 nw = *n;
21793 } else {
21794 nq = *n;
21795 nw = *m;
21796 }
21797 if (! applyq && ! lsame_(vect, "P")) {
21798 *info = -1;
21799 } else if (! left && ! lsame_(side, "R")) {
21800 *info = -2;
21801 } else if (! notran && ! lsame_(trans, "T")) {
21802 *info = -3;
21803 } else if (*m < 0) {
21804 *info = -4;
21805 } else if (*n < 0) {
21806 *info = -5;
21807 } else if (*k < 0) {
21808 *info = -6;
21809 } else {
21810
21811 i__1 = 1, i__2 = f2cmin(nq,*k);
21812 if (applyq && *lda < f2cmax(1,nq) || ! applyq && *lda < f2cmax(i__1,i__2)) {
21813 *info = -8;
21814 } else if (*ldc < f2cmax(1,*m)) {
21815 *info = -11;
21816 } else if (*lwork < f2cmax(1,nw) && ! lquery) {
21817 *info = -13;
21818 }
21819 }
21820
21821 if (*info == 0) {
21822 if (applyq) {
21823 if (left) {
21824
21825 i__3[0] = 1, a__1[0] = side;
21826 i__3[1] = 1, a__1[1] = trans;
21827 s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
21828 i__1 = *m - 1;
21829 i__2 = *m - 1;
21830 nb = ilaenv_(&c__1, "SORMQR", ch__1, &i__1, n, &i__2, &c_n1, (
21831 ftnlen)6, (ftnlen)2);
21832 } else {
21833
21834 i__3[0] = 1, a__1[0] = side;
21835 i__3[1] = 1, a__1[1] = trans;
21836 s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
21837 i__1 = *n - 1;
21838 i__2 = *n - 1;
21839 nb = ilaenv_(&c__1, "SORMQR", ch__1, m, &i__1, &i__2, &c_n1, (
21840 ftnlen)6, (ftnlen)2);
21841 }
21842 } else {
21843 if (left) {
21844
21845 i__3[0] = 1, a__1[0] = side;
21846 i__3[1] = 1, a__1[1] = trans;
21847 s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
21848 i__1 = *m - 1;
21849 i__2 = *m - 1;
21850 nb = ilaenv_(&c__1, "SORMLQ", ch__1, &i__1, n, &i__2, &c_n1, (
21851 ftnlen)6, (ftnlen)2);
21852 } else {
21853
21854 i__3[0] = 1, a__1[0] = side;
21855 i__3[1] = 1, a__1[1] = trans;
21856 s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
21857 i__1 = *n - 1;
21858 i__2 = *n - 1;
21859 nb = ilaenv_(&c__1, "SORMLQ", ch__1, m, &i__1, &i__2, &c_n1, (
21860 ftnlen)6, (ftnlen)2);
21861 }
21862 }
21863 lwkopt = f2cmax(1,nw) * nb;
21864 work[1] = (real) lwkopt;
21865 }
21866
21867 if (*info != 0) {
21868 i__1 = -(*info);
21869 xerbla_("SORMBR", &i__1);
21870 return 0;
21871 } else if (lquery) {
21872 return 0;
21873 }
21874
21875
21876
21877 work[1] = 1.f;
21878 if (*m == 0 || *n == 0) {
21879 return 0;
21880 }
21881
21882 if (applyq) {
21883
21884
21885
21886 if (nq >= *k) {
21887
21888
21889
21890 sormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
21891 c_offset], ldc, &work[1], lwork, &iinfo);
21892 } else if (nq > 1) {
21893
21894
21895
21896 if (left) {
21897 mi = *m - 1;
21898 ni = *n;
21899 i1 = 2;
21900 i2 = 1;
21901 } else {
21902 mi = *m;
21903 ni = *n - 1;
21904 i1 = 1;
21905 i2 = 2;
21906 }
21907 i__1 = nq - 1;
21908 sormqr_(side, trans, &mi, &ni, &i__1, &a_ref(2, 1), lda, &tau[1],
21909 &c___ref(i1, i2), ldc, &work[1], lwork, &iinfo);
21910 }
21911 } else {
21912
21913
21914
21915 if (notran) {
21916 *(unsigned char *)transt = 'T';
21917 } else {
21918 *(unsigned char *)transt = 'N';
21919 }
21920 if (nq > *k) {
21921
21922
21923
21924 sormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[
21925 c_offset], ldc, &work[1], lwork, &iinfo);
21926 } else if (nq > 1) {
21927
21928
21929
21930 if (left) {
21931 mi = *m - 1;
21932 ni = *n;
21933 i1 = 2;
21934 i2 = 1;
21935 } else {
21936 mi = *m;
21937 ni = *n - 1;
21938 i1 = 1;
21939 i2 = 2;
21940 }
21941 i__1 = nq - 1;
21942 sormlq_(side, transt, &mi, &ni, &i__1, &a_ref(1, 2), lda, &tau[1],
21943 &c___ref(i1, i2), ldc, &work[1], lwork, &iinfo);
21944 }
21945 }
21946 work[1] = (real) lwkopt;
21947 return 0;
21948
21949
21950
21951 }
21952
21953 #undef c___ref
21954 #undef a_ref
21955
21956
21957
21958 int sgelqf_(integer *m, integer *n, real *a, integer *lda,
21959 real *tau, real *work, integer *lwork, integer *info)
21960 {
21961
21962
21963
21964
21965
21966
21967
21968
21969
21970
21971
21972
21973
21974
21975
21976
21977
21978
21979
21980
21981
21982
21983
21984
21985
21986
21987
21988
21989
21990
21991
21992
21993
21994
21995
21996
21997
21998
21999
22000
22001
22002
22003
22004
22005
22006
22007
22008
22009
22010
22011
22012
22013
22014
22015
22016
22017
22018
22019
22020
22021
22022
22023
22024
22025
22026
22027
22028
22029
22030
22031
22032
22033
22034
22035
22036 static integer c__1 = 1;
22037 static integer c_n1 = -1;
22038 static integer c__3 = 3;
22039 static integer c__2 = 2;
22040
22041
22042 integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
22043
22044 static integer i__, k, nbmin, iinfo;
22045 extern int sgelq2_(integer *, integer *, real *, integer
22046 *, real *, real *, integer *);
22047 static integer ib, nb, nx;
22048 extern int slarfb_(const char *, const char *, const char *, const char *,
22049 integer *, integer *, integer *, real *, integer *, real *,
22050 integer *, real *, integer *, real *, integer *), xerbla_(const char *, integer *);
22051 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
22052 integer *, integer *, ftnlen, ftnlen);
22053 extern int slarft_(const char *, const char *, integer *, integer *,
22054 real *, integer *, real *, real *, integer *);
22055 static integer ldwork, lwkopt;
22056 static logical lquery;
22057 static integer iws;
22058 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
22059
22060
22061 a_dim1 = *lda;
22062 a_offset = 1 + a_dim1 * 1;
22063 a -= a_offset;
22064 --tau;
22065 --work;
22066
22067
22068 *info = 0;
22069 nb = ilaenv_(&c__1, "SGELQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)
22070 1);
22071 lwkopt = *m * nb;
22072 work[1] = (real) lwkopt;
22073 lquery = *lwork == -1;
22074 if (*m < 0) {
22075 *info = -1;
22076 } else if (*n < 0) {
22077 *info = -2;
22078 } else if (*lda < f2cmax(1,*m)) {
22079 *info = -4;
22080 } else if (*lwork < f2cmax(1,*m) && ! lquery) {
22081 *info = -7;
22082 }
22083 if (*info != 0) {
22084 i__1 = -(*info);
22085 xerbla_("SGELQF", &i__1);
22086 return 0;
22087 } else if (lquery) {
22088 return 0;
22089 }
22090
22091
22092
22093 k = f2cmin(*m,*n);
22094 if (k == 0) {
22095 work[1] = 1.f;
22096 return 0;
22097 }
22098
22099 nbmin = 2;
22100 nx = 0;
22101 iws = *m;
22102 if (nb > 1 && nb < k) {
22103
22104
22105
22106
22107 i__1 = 0, i__2 = ilaenv_(&c__3, "SGELQF", " ", m, n, &c_n1, &c_n1, (
22108 ftnlen)6, (ftnlen)1);
22109 nx = f2cmax(i__1,i__2);
22110 if (nx < k) {
22111
22112
22113
22114 ldwork = *m;
22115 iws = ldwork * nb;
22116 if (*lwork < iws) {
22117
22118
22119
22120
22121 nb = *lwork / ldwork;
22122
22123 i__1 = 2, i__2 = ilaenv_(&c__2, "SGELQF", " ", m, n, &c_n1, &
22124 c_n1, (ftnlen)6, (ftnlen)1);
22125 nbmin = f2cmax(i__1,i__2);
22126 }
22127 }
22128 }
22129
22130 if (nb >= nbmin && nb < k && nx < k) {
22131
22132
22133
22134 i__1 = k - nx;
22135 i__2 = nb;
22136 for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
22137
22138 i__3 = k - i__ + 1;
22139 ib = f2cmin(i__3,nb);
22140
22141
22142
22143
22144 i__3 = *n - i__ + 1;
22145 sgelq2_(&ib, &i__3, &a_ref(i__, i__), lda, &tau[i__], &work[1], &
22146 iinfo);
22147 if (i__ + ib <= *m) {
22148
22149
22150
22151
22152 i__3 = *n - i__ + 1;
22153 slarft_("Forward", "Rowwise", &i__3, &ib, &a_ref(i__, i__),
22154 lda, &tau[i__], &work[1], &ldwork);
22155
22156
22157
22158 i__3 = *m - i__ - ib + 1;
22159 i__4 = *n - i__ + 1;
22160 slarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3,
22161 &i__4, &ib, &a_ref(i__, i__), lda, &work[1], &ldwork,
22162 &a_ref(i__ + ib, i__), lda, &work[ib + 1], &ldwork);
22163 }
22164
22165 }
22166 } else {
22167 i__ = 1;
22168 }
22169
22170
22171
22172 if (i__ <= k) {
22173 i__2 = *m - i__ + 1;
22174 i__1 = *n - i__ + 1;
22175 sgelq2_(&i__2, &i__1, &a_ref(i__, i__), lda, &tau[i__], &work[1], &
22176 iinfo);
22177 }
22178
22179 work[1] = (real) iws;
22180 return 0;
22181
22182
22183
22184 }
22185
22186 #undef a_ref
22187
22188
22189
22190 int sormlq_(const char *side, const char *trans, integer *m, integer *n,
22191 integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
22192 real *work, integer *lwork, integer *info)
22193 {
22194
22195
22196
22197
22198
22199
22200
22201
22202
22203
22204
22205
22206
22207
22208
22209
22210
22211
22212
22213
22214
22215
22216
22217
22218
22219
22220
22221
22222
22223
22224
22225
22226
22227
22228
22229
22230
22231
22232
22233
22234
22235
22236
22237
22238
22239
22240
22241
22242
22243
22244
22245
22246
22247
22248
22249
22250
22251
22252
22253
22254
22255
22256
22257
22258
22259
22260
22261
22262
22263
22264
22265
22266
22267
22268
22269
22270
22271
22272
22273
22274
22275
22276
22277
22278
22279
22280
22281
22282
22283
22284
22285
22286
22287
22288
22289 static integer c__1 = 1;
22290 static integer c_n1 = -1;
22291 static integer c__2 = 2;
22292 static integer c__65 = 65;
22293
22294 typedef const char *address;
22295
22296 address a__1[2];
22297 integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
22298 i__5;
22299 char ch__1[2];
22300
22301 int s_cat(char *, const char **, integer *, integer *, ftnlen);
22302
22303 static logical left;
22304 static integer i__;
22305 static real t[4160] ;
22306 extern logical lsame_(const char *, const char *);
22307 static integer nbmin, iinfo, i1, i2, i3, ib, ic, jc;
22308 extern int sorml2_(const char *, const char *, integer *, integer *,
22309 integer *, real *, integer *, real *, real *, integer *, real *,
22310 integer *);
22311 static integer nb, mi, ni, nq, nw;
22312 extern int slarfb_(const char *, const char *, const char *, const char *,
22313 integer *, integer *, integer *, real *, integer *, real *,
22314 integer *, real *, integer *, real *, integer *), xerbla_(const char *, integer *);
22315 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
22316 integer *, integer *, ftnlen, ftnlen);
22317 extern int slarft_(const char *, const char *, integer *, integer *,
22318 real *, integer *, real *, real *, integer *);
22319 static logical notran;
22320 static integer ldwork;
22321 static char transt[1];
22322 static integer lwkopt;
22323 static logical lquery;
22324 static integer iws;
22325 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
22326 #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
22327
22328
22329 a_dim1 = *lda;
22330 a_offset = 1 + a_dim1 * 1;
22331 a -= a_offset;
22332 --tau;
22333 c_dim1 = *ldc;
22334 c_offset = 1 + c_dim1 * 1;
22335 c__ -= c_offset;
22336 --work;
22337
22338
22339 *info = 0;
22340 left = lsame_(side, "L");
22341 notran = lsame_(trans, "N");
22342 lquery = *lwork == -1;
22343
22344
22345
22346 if (left) {
22347 nq = *m;
22348 nw = *n;
22349 } else {
22350 nq = *n;
22351 nw = *m;
22352 }
22353 if (! left && ! lsame_(side, "R")) {
22354 *info = -1;
22355 } else if (! notran && ! lsame_(trans, "T")) {
22356 *info = -2;
22357 } else if (*m < 0) {
22358 *info = -3;
22359 } else if (*n < 0) {
22360 *info = -4;
22361 } else if (*k < 0 || *k > nq) {
22362 *info = -5;
22363 } else if (*lda < f2cmax(1,*k)) {
22364 *info = -7;
22365 } else if (*ldc < f2cmax(1,*m)) {
22366 *info = -10;
22367 } else if (*lwork < f2cmax(1,nw) && ! lquery) {
22368 *info = -12;
22369 }
22370
22371 if (*info == 0) {
22372
22373
22374
22375
22376
22377
22378 i__3[0] = 1, a__1[0] = side;
22379 i__3[1] = 1, a__1[1] = trans;
22380 s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
22381 i__1 = 64, i__2 = ilaenv_(&c__1, "SORMLQ", ch__1, m, n, k, &c_n1, (
22382 ftnlen)6, (ftnlen)2);
22383 nb = f2cmin(i__1,i__2);
22384 lwkopt = f2cmax(1,nw) * nb;
22385 work[1] = (real) lwkopt;
22386 }
22387
22388 if (*info != 0) {
22389 i__1 = -(*info);
22390 xerbla_("SORMLQ", &i__1);
22391 return 0;
22392 } else if (lquery) {
22393 return 0;
22394 }
22395
22396
22397
22398 if (*m == 0 || *n == 0 || *k == 0) {
22399 work[1] = 1.f;
22400 return 0;
22401 }
22402
22403 nbmin = 2;
22404 ldwork = nw;
22405 if (nb > 1 && nb < *k) {
22406 iws = nw * nb;
22407 if (*lwork < iws) {
22408 nb = *lwork / ldwork;
22409
22410
22411 i__3[0] = 1, a__1[0] = side;
22412 i__3[1] = 1, a__1[1] = trans;
22413 s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
22414 i__1 = 2, i__2 = ilaenv_(&c__2, "SORMLQ", ch__1, m, n, k, &c_n1, (
22415 ftnlen)6, (ftnlen)2);
22416 nbmin = f2cmax(i__1,i__2);
22417 }
22418 } else {
22419 iws = nw;
22420 }
22421
22422 if (nb < nbmin || nb >= *k) {
22423
22424
22425
22426 sorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
22427 c_offset], ldc, &work[1], &iinfo);
22428 } else {
22429
22430
22431
22432 if (left && notran || ! left && ! notran) {
22433 i1 = 1;
22434 i2 = *k;
22435 i3 = nb;
22436 } else {
22437 i1 = (*k - 1) / nb * nb + 1;
22438 i2 = 1;
22439 i3 = -nb;
22440 }
22441
22442 if (left) {
22443 ni = *n;
22444 jc = 1;
22445 } else {
22446 mi = *m;
22447 ic = 1;
22448 }
22449
22450 if (notran) {
22451 *(unsigned char *)transt = 'T';
22452 } else {
22453 *(unsigned char *)transt = 'N';
22454 }
22455
22456 i__1 = i2;
22457 i__2 = i3;
22458 for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
22459
22460 i__4 = nb, i__5 = *k - i__ + 1;
22461 ib = f2cmin(i__4,i__5);
22462
22463
22464
22465
22466 i__4 = nq - i__ + 1;
22467 slarft_("Forward", "Rowwise", &i__4, &ib, &a_ref(i__, i__), lda, &
22468 tau[i__], t, &c__65);
22469 if (left) {
22470
22471
22472
22473 mi = *m - i__ + 1;
22474 ic = i__;
22475 } else {
22476
22477
22478
22479 ni = *n - i__ + 1;
22480 jc = i__;
22481 }
22482
22483
22484
22485 slarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a_ref(
22486 i__, i__), lda, t, &c__65, &c___ref(ic, jc), ldc, &work[1]
22487 , &ldwork);
22488
22489 }
22490 }
22491 work[1] = (real) lwkopt;
22492 return 0;
22493
22494
22495
22496 }
22497
22498 #undef c___ref
22499 #undef a_ref
22500
22501
22502
22503 int sormqr_(const char *side, const char *trans, integer *m, integer *n,
22504 integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
22505 real *work, integer *lwork, integer *info)
22506 {
22507
22508
22509
22510
22511
22512
22513
22514
22515
22516
22517
22518
22519
22520
22521
22522
22523
22524
22525
22526
22527
22528
22529
22530
22531
22532
22533
22534
22535
22536
22537
22538
22539
22540
22541
22542
22543
22544
22545
22546
22547
22548
22549
22550
22551
22552
22553
22554
22555
22556
22557
22558
22559
22560
22561
22562
22563
22564
22565
22566
22567
22568
22569
22570
22571
22572
22573
22574
22575
22576
22577
22578
22579
22580
22581
22582
22583
22584
22585
22586
22587
22588
22589
22590
22591
22592
22593
22594
22595
22596
22597
22598
22599
22600
22601
22602 static integer c__1 = 1;
22603 static integer c_n1 = -1;
22604 static integer c__2 = 2;
22605 static integer c__65 = 65;
22606
22607
22608 typedef const char *address;
22609 address a__1[2];
22610 integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
22611 i__5;
22612 char ch__1[2];
22613
22614 int s_cat(char *, const char **, integer *, integer *, ftnlen);
22615
22616 static logical left;
22617 static integer i__;
22618 static real t[4160] ;
22619 extern logical lsame_(const char *, const char *);
22620 static integer nbmin, iinfo, i1, i2, i3, ib, ic, jc, nb;
22621 extern int sorm2r_(const char *, const char *, integer *, integer *,
22622 integer *, real *, integer *, real *, real *, integer *, real *,
22623 integer *);
22624 static integer mi, ni, nq, nw;
22625 extern int slarfb_(const char *, const char *, const char *, const char *,
22626 integer *, integer *, integer *, real *, integer *, real *,
22627 integer *, real *, integer *, real *, integer *), xerbla_(const char *, integer *);
22628 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
22629 integer *, integer *, ftnlen, ftnlen);
22630 extern int slarft_(const char *, const char *, integer *, integer *,
22631 real *, integer *, real *, real *, integer *);
22632 static logical notran;
22633 static integer ldwork, lwkopt;
22634 static logical lquery;
22635 static integer iws;
22636 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
22637 #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
22638
22639
22640 a_dim1 = *lda;
22641 a_offset = 1 + a_dim1 * 1;
22642 a -= a_offset;
22643 --tau;
22644 c_dim1 = *ldc;
22645 c_offset = 1 + c_dim1 * 1;
22646 c__ -= c_offset;
22647 --work;
22648
22649
22650 *info = 0;
22651 left = lsame_(side, "L");
22652 notran = lsame_(trans, "N");
22653 lquery = *lwork == -1;
22654
22655
22656
22657 if (left) {
22658 nq = *m;
22659 nw = *n;
22660 } else {
22661 nq = *n;
22662 nw = *m;
22663 }
22664 if (! left && ! lsame_(side, "R")) {
22665 *info = -1;
22666 } else if (! notran && ! lsame_(trans, "T")) {
22667 *info = -2;
22668 } else if (*m < 0) {
22669 *info = -3;
22670 } else if (*n < 0) {
22671 *info = -4;
22672 } else if (*k < 0 || *k > nq) {
22673 *info = -5;
22674 } else if (*lda < f2cmax(1,nq)) {
22675 *info = -7;
22676 } else if (*ldc < f2cmax(1,*m)) {
22677 *info = -10;
22678 } else if (*lwork < f2cmax(1,nw) && ! lquery) {
22679 *info = -12;
22680 }
22681
22682 if (*info == 0) {
22683
22684
22685
22686
22687
22688
22689 i__3[0] = 1, a__1[0] = side;
22690 i__3[1] = 1, a__1[1] = trans;
22691 s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
22692 i__1 = 64, i__2 = ilaenv_(&c__1, "SORMQR", ch__1, m, n, k, &c_n1, (
22693 ftnlen)6, (ftnlen)2);
22694 nb = f2cmin(i__1,i__2);
22695 lwkopt = f2cmax(1,nw) * nb;
22696 work[1] = (real) lwkopt;
22697 }
22698
22699 if (*info != 0) {
22700 i__1 = -(*info);
22701 xerbla_("SORMQR", &i__1);
22702 return 0;
22703 } else if (lquery) {
22704 return 0;
22705 }
22706
22707
22708
22709 if (*m == 0 || *n == 0 || *k == 0) {
22710 work[1] = 1.f;
22711 return 0;
22712 }
22713
22714 nbmin = 2;
22715 ldwork = nw;
22716 if (nb > 1 && nb < *k) {
22717 iws = nw * nb;
22718 if (*lwork < iws) {
22719 nb = *lwork / ldwork;
22720
22721
22722 i__3[0] = 1, a__1[0] = side;
22723 i__3[1] = 1, a__1[1] = trans;
22724 s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
22725 i__1 = 2, i__2 = ilaenv_(&c__2, "SORMQR", ch__1, m, n, k, &c_n1, (
22726 ftnlen)6, (ftnlen)2);
22727 nbmin = f2cmax(i__1,i__2);
22728 }
22729 } else {
22730 iws = nw;
22731 }
22732
22733 if (nb < nbmin || nb >= *k) {
22734
22735
22736
22737 sorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
22738 c_offset], ldc, &work[1], &iinfo);
22739 } else {
22740
22741
22742
22743 if (left && ! notran || ! left && notran) {
22744 i1 = 1;
22745 i2 = *k;
22746 i3 = nb;
22747 } else {
22748 i1 = (*k - 1) / nb * nb + 1;
22749 i2 = 1;
22750 i3 = -nb;
22751 }
22752
22753 if (left) {
22754 ni = *n;
22755 jc = 1;
22756 } else {
22757 mi = *m;
22758 ic = 1;
22759 }
22760
22761 i__1 = i2;
22762 i__2 = i3;
22763 for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
22764
22765 i__4 = nb, i__5 = *k - i__ + 1;
22766 ib = f2cmin(i__4,i__5);
22767
22768
22769
22770
22771 i__4 = nq - i__ + 1;
22772 slarft_("Forward", "Columnwise", &i__4, &ib, &a_ref(i__, i__),
22773 lda, &tau[i__], t, &c__65);
22774 if (left) {
22775
22776
22777
22778 mi = *m - i__ + 1;
22779 ic = i__;
22780 } else {
22781
22782
22783
22784 ni = *n - i__ + 1;
22785 jc = i__;
22786 }
22787
22788
22789
22790 slarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &
22791 a_ref(i__, i__), lda, t, &c__65, &c___ref(ic, jc), ldc, &
22792 work[1], &ldwork);
22793
22794 }
22795 }
22796 work[1] = (real) lwkopt;
22797 return 0;
22798
22799
22800
22801 }
22802
22803 #undef c___ref
22804 #undef a_ref
22805
22806
22807
22808 int sgelq2_(integer *m, integer *n, real *a, integer *lda,
22809 real *tau, real *work, integer *info)
22810 {
22811
22812
22813
22814
22815
22816
22817
22818
22819
22820
22821
22822
22823
22824
22825
22826
22827
22828
22829
22830
22831
22832
22833
22834
22835
22836
22837
22838
22839
22840
22841
22842
22843
22844
22845
22846
22847
22848
22849
22850
22851
22852
22853
22854
22855
22856
22857
22858
22859
22860
22861
22862
22863
22864
22865
22866
22867
22868
22869
22870
22871
22872
22873
22874
22875 integer a_dim1, a_offset, i__1, i__2, i__3;
22876
22877 static integer i__, k;
22878 extern int slarf_(const char *, integer *, integer *, real *,
22879 integer *, real *, real *, integer *, real *), xerbla_(
22880 const char *, integer *), slarfg_(integer *, real *, real *,
22881 integer *, real *);
22882 static real aii;
22883 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
22884
22885 a_dim1 = *lda;
22886 a_offset = 1 + a_dim1 * 1;
22887 a -= a_offset;
22888 --tau;
22889 --work;
22890
22891
22892 *info = 0;
22893 if (*m < 0) {
22894 *info = -1;
22895 } else if (*n < 0) {
22896 *info = -2;
22897 } else if (*lda < f2cmax(1,*m)) {
22898 *info = -4;
22899 }
22900 if (*info != 0) {
22901 i__1 = -(*info);
22902 xerbla_("SGELQ2", &i__1);
22903 return 0;
22904 }
22905
22906 k = f2cmin(*m,*n);
22907
22908 i__1 = k;
22909 for (i__ = 1; i__ <= i__1; ++i__) {
22910
22911
22912
22913
22914 i__2 = i__ + 1;
22915 i__3 = *n - i__ + 1;
22916 slarfg_(&i__3, &a_ref(i__, i__), &a_ref(i__, f2cmin(i__2,*n)), lda, &tau[
22917 i__]);
22918 if (i__ < *m) {
22919
22920
22921
22922 aii = a_ref(i__, i__);
22923 a_ref(i__, i__) = 1.f;
22924 i__2 = *m - i__;
22925 i__3 = *n - i__ + 1;
22926 slarf_("Right", &i__2, &i__3, &a_ref(i__, i__), lda, &tau[i__], &
22927 a_ref(i__ + 1, i__), lda, &work[1]);
22928 a_ref(i__, i__) = aii;
22929 }
22930
22931 }
22932 return 0;
22933
22934
22935
22936 }
22937
22938 #undef a_ref
22939
22940
22941
22942
22943
22944
22945
22946
22947
22948
22949 static doublereal c_b15 = -.125;
22950
22951 static real c_b49 = 1.f;
22952 static real c_b72 = -1.f;
22953
22954 int sbdsqr_(const char *uplo, integer *n, integer *ncvt, integer *
22955 nru, integer *ncc, real *d__, real *e, real *vt, integer *ldvt, real *
22956 u, integer *ldu, real *c__, integer *ldc, real *work, integer *info)
22957 {
22958
22959 integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
22960 i__2;
22961 real r__1, r__2, r__3, r__4;
22962 doublereal d__1;
22963
22964
22965
22966
22967
22968 static real abse;
22969 static integer idir;
22970 static real abss;
22971 static integer oldm;
22972 static real cosl;
22973 static integer isub, iter;
22974 static real unfl, sinl, cosr, smin, smax, sinr;
22975 extern int srot_(integer *, real *, integer *, real *,
22976 integer *, real *, real *), slas2_(real *, real *, real *, real *,
22977 real *);
22978 static real f, g, h__;
22979 static integer i__, j, m;
22980 static real r__;
22981 extern logical lsame_(const char *, const char *);
22982 static real oldcs;
22983 extern int sscal_(integer *, real *, real *, integer *);
22984 static integer oldll;
22985 static real shift, sigmn, oldsn;
22986 static integer maxit;
22987 static real sminl;
22988 extern int slasr_(const char *, const char *, const char *, integer *,
22989 integer *, real *, real *, real *, integer *);
22990 static real sigmx;
22991 static logical lower;
22992 extern int sswap_(integer *, real *, integer *, real *,
22993 integer *), slasq1_(integer *, real *, real *, real *, integer *),
22994 slasv2_(real *, real *, real *, real *, real *, real *, real *,
22995 real *, real *);
22996 static real cs;
22997 static integer ll;
22998 static real sn, mu;
22999 extern doublereal slamch_(const char *);
23000 extern int xerbla_(const char *, integer *);
23001 static real sminoa;
23002 extern int slartg_(real *, real *, real *, real *, real *
23003 );
23004 static real thresh;
23005 static logical rotate;
23006 static real sminlo;
23007 static integer nm1;
23008 static real tolmul;
23009 static integer nm12, nm13, lll;
23010 static real eps, sll, tol;
23011
23012
23013 #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
23014 #define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
23015 #define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1]
23016
23017
23018
23019
23020
23021
23022
23023
23024
23025
23026
23027
23028
23029
23030
23031
23032
23033
23034
23035
23036
23037
23038
23039
23040
23041
23042
23043
23044
23045
23046
23047
23048
23049
23050
23051
23052
23053
23054
23055
23056
23057
23058
23059
23060
23061
23062
23063
23064
23065
23066
23067
23068
23069
23070
23071
23072
23073
23074
23075
23076
23077
23078
23079
23080
23081
23082
23083
23084
23085
23086
23087
23088
23089
23090
23091
23092
23093
23094
23095
23096
23097
23098
23099
23100
23101
23102
23103
23104
23105
23106
23107
23108
23109
23110
23111
23112
23113
23114
23115
23116
23117
23118
23119
23120
23121
23122
23123
23124
23125
23126
23127
23128
23129
23130
23131
23132
23133
23134
23135
23136
23137
23138
23139
23140
23141
23142
23143
23144 --d__;
23145 --e;
23146 vt_dim1 = *ldvt;
23147 vt_offset = 1 + vt_dim1 * 1;
23148 vt -= vt_offset;
23149 u_dim1 = *ldu;
23150 u_offset = 1 + u_dim1 * 1;
23151 u -= u_offset;
23152 c_dim1 = *ldc;
23153 c_offset = 1 + c_dim1 * 1;
23154 c__ -= c_offset;
23155 --work;
23156
23157
23158 *info = 0;
23159 lower = lsame_(uplo, "L");
23160 if (! lsame_(uplo, "U") && ! lower) {
23161 *info = -1;
23162 } else if (*n < 0) {
23163 *info = -2;
23164 } else if (*ncvt < 0) {
23165 *info = -3;
23166 } else if (*nru < 0) {
23167 *info = -4;
23168 } else if (*ncc < 0) {
23169 *info = -5;
23170 } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < f2cmax(1,*n)) {
23171 *info = -9;
23172 } else if (*ldu < f2cmax(1,*nru)) {
23173 *info = -11;
23174 } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < f2cmax(1,*n)) {
23175 *info = -13;
23176 }
23177 if (*info != 0) {
23178 i__1 = -(*info);
23179 xerbla_("SBDSQR", &i__1);
23180 return 0;
23181 }
23182 if (*n == 0) {
23183 return 0;
23184 }
23185 if (*n == 1) {
23186 goto L160;
23187 }
23188
23189
23190
23191 rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
23192
23193
23194
23195 if (! rotate) {
23196 slasq1_(n, &d__[1], &e[1], &work[1], info);
23197 return 0;
23198 }
23199
23200 nm1 = *n - 1;
23201 nm12 = nm1 + nm1;
23202 nm13 = nm12 + nm1;
23203 idir = 0;
23204
23205
23206
23207 eps = slamch_("Epsilon");
23208 unfl = slamch_("Safe minimum");
23209
23210
23211
23212
23213 if (lower) {
23214 i__1 = *n - 1;
23215 for (i__ = 1; i__ <= i__1; ++i__) {
23216 slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
23217 d__[i__] = r__;
23218 e[i__] = sn * d__[i__ + 1];
23219 d__[i__ + 1] = cs * d__[i__ + 1];
23220 work[i__] = cs;
23221 work[nm1 + i__] = sn;
23222
23223 }
23224
23225
23226
23227 if (*nru > 0) {
23228 slasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset],
23229 ldu);
23230 }
23231 if (*ncc > 0) {
23232 slasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset],
23233 ldc);
23234 }
23235 }
23236
23237
23238
23239
23240
23241
23242
23243 d__1 = (doublereal) eps;
23244
23245 r__3 = 100.f, r__4 = pow(d__1, c_b15);
23246 r__1 = 10.f, r__2 = df2cmin(r__3,r__4);
23247 tolmul = df2cmax(r__1,r__2);
23248 tol = tolmul * eps;
23249
23250
23251
23252 smax = 0.f;
23253 i__1 = *n;
23254 for (i__ = 1; i__ <= i__1; ++i__) {
23255
23256 r__2 = smax, r__3 = (r__1 = d__[i__], dabs(r__1));
23257 smax = df2cmax(r__2,r__3);
23258
23259 }
23260 i__1 = *n - 1;
23261 for (i__ = 1; i__ <= i__1; ++i__) {
23262
23263 r__2 = smax, r__3 = (r__1 = e[i__], dabs(r__1));
23264 smax = df2cmax(r__2,r__3);
23265
23266 }
23267 sminl = 0.f;
23268 if (tol >= 0.f) {
23269
23270
23271
23272 sminoa = dabs(d__[1]);
23273 if (sminoa == 0.f) {
23274 goto L50;
23275 }
23276 mu = sminoa;
23277 i__1 = *n;
23278 for (i__ = 2; i__ <= i__1; ++i__) {
23279 mu = (r__2 = d__[i__], dabs(r__2)) * (mu / (mu + (r__1 = e[i__ -
23280 1], dabs(r__1))));
23281 sminoa = df2cmin(sminoa,mu);
23282 if (sminoa == 0.f) {
23283 goto L50;
23284 }
23285
23286 }
23287 L50:
23288 sminoa /= sqrt((real) (*n));
23289
23290 r__1 = tol * sminoa, r__2 = *n * 6 * *n * unfl;
23291 thresh = df2cmax(r__1,r__2);
23292 } else {
23293
23294
23295
23296
23297 r__1 = dabs(tol) * smax, r__2 = *n * 6 * *n * unfl;
23298 thresh = df2cmax(r__1,r__2);
23299 }
23300
23301
23302
23303
23304
23305 maxit = *n * 6 * *n;
23306 iter = 0;
23307 oldll = -1;
23308 oldm = -1;
23309
23310
23311
23312 m = *n;
23313
23314
23315
23316 L60:
23317
23318
23319
23320 if (m <= 1) {
23321 goto L160;
23322 }
23323 if (iter > maxit) {
23324 goto L200;
23325 }
23326
23327
23328
23329 if (tol < 0.f && (r__1 = d__[m], dabs(r__1)) <= thresh) {
23330 d__[m] = 0.f;
23331 }
23332 smax = (r__1 = d__[m], dabs(r__1));
23333 smin = smax;
23334 i__1 = m - 1;
23335 for (lll = 1; lll <= i__1; ++lll) {
23336 ll = m - lll;
23337 abss = (r__1 = d__[ll], dabs(r__1));
23338 abse = (r__1 = e[ll], dabs(r__1));
23339 if (tol < 0.f && abss <= thresh) {
23340 d__[ll] = 0.f;
23341 }
23342 if (abse <= thresh) {
23343 goto L80;
23344 }
23345 smin = df2cmin(smin,abss);
23346
23347 r__1 = f2cmax(smax,abss);
23348 smax = df2cmax(r__1,abse);
23349
23350 }
23351 ll = 0;
23352 goto L90;
23353 L80:
23354 e[ll] = 0.f;
23355
23356
23357
23358 if (ll == m - 1) {
23359
23360
23361
23362 --m;
23363 goto L60;
23364 }
23365 L90:
23366 ++ll;
23367
23368
23369
23370 if (ll == m - 1) {
23371
23372
23373
23374 slasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
23375 &sinl, &cosl);
23376 d__[m - 1] = sigmx;
23377 e[m - 1] = 0.f;
23378 d__[m] = sigmn;
23379
23380
23381
23382 if (*ncvt > 0) {
23383 srot_(ncvt, &vt_ref(m - 1, 1), ldvt, &vt_ref(m, 1), ldvt, &cosr, &
23384 sinr);
23385 }
23386 if (*nru > 0) {
23387 srot_(nru, &u_ref(1, m - 1), &c__1, &u_ref(1, m), &c__1, &cosl, &
23388 sinl);
23389 }
23390 if (*ncc > 0) {
23391 srot_(ncc, &c___ref(m - 1, 1), ldc, &c___ref(m, 1), ldc, &cosl, &
23392 sinl);
23393 }
23394 m += -2;
23395 goto L60;
23396 }
23397
23398
23399
23400
23401 if (ll > oldm || m < oldll) {
23402 if ((r__1 = d__[ll], dabs(r__1)) >= (r__2 = d__[m], dabs(r__2))) {
23403
23404
23405
23406 idir = 1;
23407 } else {
23408
23409
23410
23411 idir = 2;
23412 }
23413 }
23414
23415
23416
23417 if (idir == 1) {
23418
23419
23420
23421
23422 if ((r__2 = e[m - 1], dabs(r__2)) <= dabs(tol) * (r__1 = d__[m], dabs(
23423 r__1)) || tol < 0.f && (r__3 = e[m - 1], dabs(r__3)) <=
23424 thresh) {
23425 e[m - 1] = 0.f;
23426 goto L60;
23427 }
23428
23429 if (tol >= 0.f) {
23430
23431
23432
23433
23434 mu = (r__1 = d__[ll], dabs(r__1));
23435 sminl = mu;
23436 i__1 = m - 1;
23437 for (lll = ll; lll <= i__1; ++lll) {
23438 if ((r__1 = e[lll], dabs(r__1)) <= tol * mu) {
23439 e[lll] = 0.f;
23440 goto L60;
23441 }
23442 sminlo = sminl;
23443 mu = (r__2 = d__[lll + 1], dabs(r__2)) * (mu / (mu + (r__1 =
23444 e[lll], dabs(r__1))));
23445 sminl = df2cmin(sminl,mu);
23446
23447 }
23448 }
23449
23450 } else {
23451
23452
23453
23454
23455 if ((r__2 = e[ll], dabs(r__2)) <= dabs(tol) * (r__1 = d__[ll], dabs(
23456 r__1)) || tol < 0.f && (r__3 = e[ll], dabs(r__3)) <= thresh) {
23457 e[ll] = 0.f;
23458 goto L60;
23459 }
23460
23461 if (tol >= 0.f) {
23462
23463
23464
23465
23466 mu = (r__1 = d__[m], dabs(r__1));
23467 sminl = mu;
23468 i__1 = ll;
23469 for (lll = m - 1; lll >= i__1; --lll) {
23470 if ((r__1 = e[lll], dabs(r__1)) <= tol * mu) {
23471 e[lll] = 0.f;
23472 goto L60;
23473 }
23474 sminlo = sminl;
23475 mu = (r__2 = d__[lll], dabs(r__2)) * (mu / (mu + (r__1 = e[
23476 lll], dabs(r__1))));
23477 sminl = df2cmin(sminl,mu);
23478
23479 }
23480 }
23481 }
23482 oldll = ll;
23483 oldm = m;
23484
23485
23486
23487
23488
23489 r__1 = eps, r__2 = tol * .01f;
23490 if (tol >= 0.f && *n * tol * (sminl / smax) <= df2cmax(r__1,r__2)) {
23491
23492
23493
23494 shift = 0.f;
23495 } else {
23496
23497
23498
23499 if (idir == 1) {
23500 sll = (r__1 = d__[ll], dabs(r__1));
23501 slas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
23502 } else {
23503 sll = (r__1 = d__[m], dabs(r__1));
23504 slas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
23505 }
23506
23507
23508
23509 if (sll > 0.f) {
23510
23511 r__1 = shift / sll;
23512 if (r__1 * r__1 < eps) {
23513 shift = 0.f;
23514 }
23515 }
23516 }
23517
23518
23519
23520 iter = iter + m - ll;
23521
23522
23523
23524 if (shift == 0.f) {
23525 if (idir == 1) {
23526
23527
23528
23529
23530 cs = 1.f;
23531 oldcs = 1.f;
23532 i__1 = m - 1;
23533 for (i__ = ll; i__ <= i__1; ++i__) {
23534 r__1 = d__[i__] * cs;
23535 slartg_(&r__1, &e[i__], &cs, &sn, &r__);
23536 if (i__ > ll) {
23537 e[i__ - 1] = oldsn * r__;
23538 }
23539 r__1 = oldcs * r__;
23540 r__2 = d__[i__ + 1] * sn;
23541 slartg_(&r__1, &r__2, &oldcs, &oldsn, &d__[i__]);
23542 work[i__ - ll + 1] = cs;
23543 work[i__ - ll + 1 + nm1] = sn;
23544 work[i__ - ll + 1 + nm12] = oldcs;
23545 work[i__ - ll + 1 + nm13] = oldsn;
23546
23547 }
23548 h__ = d__[m] * cs;
23549 d__[m] = h__ * oldcs;
23550 e[m - 1] = h__ * oldsn;
23551
23552
23553
23554 if (*ncvt > 0) {
23555 i__1 = m - ll + 1;
23556 slasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &
23557 vt_ref(ll, 1), ldvt);
23558 }
23559 if (*nru > 0) {
23560 i__1 = m - ll + 1;
23561 slasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
23562 + 1], &u_ref(1, ll), ldu);
23563 }
23564 if (*ncc > 0) {
23565 i__1 = m - ll + 1;
23566 slasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
23567 + 1], &c___ref(ll, 1), ldc);
23568 }
23569
23570
23571
23572 if ((r__1 = e[m - 1], dabs(r__1)) <= thresh) {
23573 e[m - 1] = 0.f;
23574 }
23575
23576 } else {
23577
23578
23579
23580
23581 cs = 1.f;
23582 oldcs = 1.f;
23583 i__1 = ll + 1;
23584 for (i__ = m; i__ >= i__1; --i__) {
23585 r__1 = d__[i__] * cs;
23586 slartg_(&r__1, &e[i__ - 1], &cs, &sn, &r__);
23587 if (i__ < m) {
23588 e[i__] = oldsn * r__;
23589 }
23590 r__1 = oldcs * r__;
23591 r__2 = d__[i__ - 1] * sn;
23592 slartg_(&r__1, &r__2, &oldcs, &oldsn, &d__[i__]);
23593 work[i__ - ll] = cs;
23594 work[i__ - ll + nm1] = -sn;
23595 work[i__ - ll + nm12] = oldcs;
23596 work[i__ - ll + nm13] = -oldsn;
23597
23598 }
23599 h__ = d__[ll] * cs;
23600 d__[ll] = h__ * oldcs;
23601 e[ll] = h__ * oldsn;
23602
23603
23604
23605 if (*ncvt > 0) {
23606 i__1 = m - ll + 1;
23607 slasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
23608 nm13 + 1], &vt_ref(ll, 1), ldvt);
23609 }
23610 if (*nru > 0) {
23611 i__1 = m - ll + 1;
23612 slasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u_ref(
23613 1, ll), ldu);
23614 }
23615 if (*ncc > 0) {
23616 i__1 = m - ll + 1;
23617 slasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &
23618 c___ref(ll, 1), ldc);
23619 }
23620
23621
23622
23623 if ((r__1 = e[ll], dabs(r__1)) <= thresh) {
23624 e[ll] = 0.f;
23625 }
23626 }
23627 } else {
23628
23629
23630
23631 if (idir == 1) {
23632
23633
23634
23635
23636 f = ((r__1 = d__[ll], dabs(r__1)) - shift) * (r_sign(&c_b49, &d__[
23637 ll]) + shift / d__[ll]);
23638 g = e[ll];
23639 i__1 = m - 1;
23640 for (i__ = ll; i__ <= i__1; ++i__) {
23641 slartg_(&f, &g, &cosr, &sinr, &r__);
23642 if (i__ > ll) {
23643 e[i__ - 1] = r__;
23644 }
23645 f = cosr * d__[i__] + sinr * e[i__];
23646 e[i__] = cosr * e[i__] - sinr * d__[i__];
23647 g = sinr * d__[i__ + 1];
23648 d__[i__ + 1] = cosr * d__[i__ + 1];
23649 slartg_(&f, &g, &cosl, &sinl, &r__);
23650 d__[i__] = r__;
23651 f = cosl * e[i__] + sinl * d__[i__ + 1];
23652 d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
23653 if (i__ < m - 1) {
23654 g = sinl * e[i__ + 1];
23655 e[i__ + 1] = cosl * e[i__ + 1];
23656 }
23657 work[i__ - ll + 1] = cosr;
23658 work[i__ - ll + 1 + nm1] = sinr;
23659 work[i__ - ll + 1 + nm12] = cosl;
23660 work[i__ - ll + 1 + nm13] = sinl;
23661
23662 }
23663 e[m - 1] = f;
23664
23665
23666
23667 if (*ncvt > 0) {
23668 i__1 = m - ll + 1;
23669 slasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &
23670 vt_ref(ll, 1), ldvt);
23671 }
23672 if (*nru > 0) {
23673 i__1 = m - ll + 1;
23674 slasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
23675 + 1], &u_ref(1, ll), ldu);
23676 }
23677 if (*ncc > 0) {
23678 i__1 = m - ll + 1;
23679 slasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
23680 + 1], &c___ref(ll, 1), ldc);
23681 }
23682
23683
23684
23685 if ((r__1 = e[m - 1], dabs(r__1)) <= thresh) {
23686 e[m - 1] = 0.f;
23687 }
23688
23689 } else {
23690
23691
23692
23693
23694 f = ((r__1 = d__[m], dabs(r__1)) - shift) * (r_sign(&c_b49, &d__[
23695 m]) + shift / d__[m]);
23696 g = e[m - 1];
23697 i__1 = ll + 1;
23698 for (i__ = m; i__ >= i__1; --i__) {
23699 slartg_(&f, &g, &cosr, &sinr, &r__);
23700 if (i__ < m) {
23701 e[i__] = r__;
23702 }
23703 f = cosr * d__[i__] + sinr * e[i__ - 1];
23704 e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
23705 g = sinr * d__[i__ - 1];
23706 d__[i__ - 1] = cosr * d__[i__ - 1];
23707 slartg_(&f, &g, &cosl, &sinl, &r__);
23708 d__[i__] = r__;
23709 f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
23710 d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
23711 if (i__ > ll + 1) {
23712 g = sinl * e[i__ - 2];
23713 e[i__ - 2] = cosl * e[i__ - 2];
23714 }
23715 work[i__ - ll] = cosr;
23716 work[i__ - ll + nm1] = -sinr;
23717 work[i__ - ll + nm12] = cosl;
23718 work[i__ - ll + nm13] = -sinl;
23719
23720 }
23721 e[ll] = f;
23722
23723
23724
23725 if ((r__1 = e[ll], dabs(r__1)) <= thresh) {
23726 e[ll] = 0.f;
23727 }
23728
23729
23730
23731 if (*ncvt > 0) {
23732 i__1 = m - ll + 1;
23733 slasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
23734 nm13 + 1], &vt_ref(ll, 1), ldvt);
23735 }
23736 if (*nru > 0) {
23737 i__1 = m - ll + 1;
23738 slasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u_ref(
23739 1, ll), ldu);
23740 }
23741 if (*ncc > 0) {
23742 i__1 = m - ll + 1;
23743 slasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &
23744 c___ref(ll, 1), ldc);
23745 }
23746 }
23747 }
23748
23749
23750
23751 goto L60;
23752
23753
23754
23755 L160:
23756 i__1 = *n;
23757 for (i__ = 1; i__ <= i__1; ++i__) {
23758 if (d__[i__] < 0.f) {
23759 d__[i__] = -d__[i__];
23760
23761
23762
23763 if (*ncvt > 0) {
23764 sscal_(ncvt, &c_b72, &vt_ref(i__, 1), ldvt);
23765 }
23766 }
23767
23768 }
23769
23770
23771
23772
23773 i__1 = *n - 1;
23774 for (i__ = 1; i__ <= i__1; ++i__) {
23775
23776
23777
23778 isub = 1;
23779 smin = d__[1];
23780 i__2 = *n + 1 - i__;
23781 for (j = 2; j <= i__2; ++j) {
23782 if (d__[j] <= smin) {
23783 isub = j;
23784 smin = d__[j];
23785 }
23786
23787 }
23788 if (isub != *n + 1 - i__) {
23789
23790
23791
23792 d__[isub] = d__[*n + 1 - i__];
23793 d__[*n + 1 - i__] = smin;
23794 if (*ncvt > 0) {
23795 sswap_(ncvt, &vt_ref(isub, 1), ldvt, &vt_ref(*n + 1 - i__, 1),
23796 ldvt);
23797 }
23798 if (*nru > 0) {
23799 sswap_(nru, &u_ref(1, isub), &c__1, &u_ref(1, *n + 1 - i__), &
23800 c__1);
23801 }
23802 if (*ncc > 0) {
23803 sswap_(ncc, &c___ref(isub, 1), ldc, &c___ref(*n + 1 - i__, 1),
23804 ldc);
23805 }
23806 }
23807
23808 }
23809 goto L220;
23810
23811
23812
23813 L200:
23814 *info = 0;
23815 i__1 = *n - 1;
23816 for (i__ = 1; i__ <= i__1; ++i__) {
23817 if (e[i__] != 0.f) {
23818 ++(*info);
23819 }
23820
23821 }
23822 L220:
23823 return 0;
23824
23825
23826
23827 }
23828
23829 #undef vt_ref
23830 #undef u_ref
23831 #undef c___ref
23832
23833
23834
23835 int sgeqrf_(integer *m, integer *n, real *a, integer *lda,
23836 real *tau, real *work, integer *lwork, integer *info)
23837 {
23838
23839
23840
23841
23842
23843
23844
23845
23846
23847
23848
23849
23850
23851
23852
23853
23854
23855
23856
23857
23858
23859
23860
23861
23862
23863
23864
23865
23866
23867
23868
23869
23870
23871
23872
23873
23874
23875
23876
23877
23878
23879
23880
23881
23882
23883
23884
23885
23886
23887
23888
23889
23890
23891
23892
23893
23894
23895
23896
23897
23898
23899
23900
23901
23902
23903
23904
23905
23906
23907
23908
23909
23910
23911
23912
23913
23914 static integer c__1 = 1;
23915 static integer c_n1 = -1;
23916 static integer c__3 = 3;
23917 static integer c__2 = 2;
23918
23919
23920 integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
23921
23922 static integer i__, k, nbmin, iinfo;
23923 extern int sgeqr2_(integer *, integer *, real *, integer
23924 *, real *, real *, integer *);
23925 static integer ib, nb, nx;
23926 extern int slarfb_(const char *, const char *, const char *, const char *,
23927 integer *, integer *, integer *, real *, integer *, real *,
23928 integer *, real *, integer *, real *, integer *), xerbla_(const char *, integer *);
23929 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
23930 integer *, integer *, ftnlen, ftnlen);
23931 extern int slarft_(const char *, const char *, integer *, integer *,
23932 real *, integer *, real *, real *, integer *);
23933 static integer ldwork, lwkopt;
23934 static logical lquery;
23935 static integer iws;
23936 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
23937
23938
23939 a_dim1 = *lda;
23940 a_offset = 1 + a_dim1 * 1;
23941 a -= a_offset;
23942 --tau;
23943 --work;
23944
23945
23946 *info = 0;
23947 nb = ilaenv_(&c__1, "SGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)
23948 1);
23949 lwkopt = *n * nb;
23950 work[1] = (real) lwkopt;
23951 lquery = *lwork == -1;
23952 if (*m < 0) {
23953 *info = -1;
23954 } else if (*n < 0) {
23955 *info = -2;
23956 } else if (*lda < f2cmax(1,*m)) {
23957 *info = -4;
23958 } else if (*lwork < f2cmax(1,*n) && ! lquery) {
23959 *info = -7;
23960 }
23961 if (*info != 0) {
23962 i__1 = -(*info);
23963 xerbla_("SGEQRF", &i__1);
23964 return 0;
23965 } else if (lquery) {
23966 return 0;
23967 }
23968
23969
23970
23971 k = f2cmin(*m,*n);
23972 if (k == 0) {
23973 work[1] = 1.f;
23974 return 0;
23975 }
23976
23977 nbmin = 2;
23978 nx = 0;
23979 iws = *n;
23980 if (nb > 1 && nb < k) {
23981
23982
23983
23984
23985 i__1 = 0, i__2 = ilaenv_(&c__3, "SGEQRF", " ", m, n, &c_n1, &c_n1, (
23986 ftnlen)6, (ftnlen)1);
23987 nx = f2cmax(i__1,i__2);
23988 if (nx < k) {
23989
23990
23991
23992 ldwork = *n;
23993 iws = ldwork * nb;
23994 if (*lwork < iws) {
23995
23996
23997
23998
23999 nb = *lwork / ldwork;
24000
24001 i__1 = 2, i__2 = ilaenv_(&c__2, "SGEQRF", " ", m, n, &c_n1, &
24002 c_n1, (ftnlen)6, (ftnlen)1);
24003 nbmin = f2cmax(i__1,i__2);
24004 }
24005 }
24006 }
24007
24008 if (nb >= nbmin && nb < k && nx < k) {
24009
24010
24011
24012 i__1 = k - nx;
24013 i__2 = nb;
24014 for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
24015
24016 i__3 = k - i__ + 1;
24017 ib = f2cmin(i__3,nb);
24018
24019
24020
24021
24022 i__3 = *m - i__ + 1;
24023 sgeqr2_(&i__3, &ib, &a_ref(i__, i__), lda, &tau[i__], &work[1], &
24024 iinfo);
24025 if (i__ + ib <= *n) {
24026
24027
24028
24029
24030 i__3 = *m - i__ + 1;
24031 slarft_("Forward", "Columnwise", &i__3, &ib, &a_ref(i__, i__),
24032 lda, &tau[i__], &work[1], &ldwork);
24033
24034
24035
24036 i__3 = *m - i__ + 1;
24037 i__4 = *n - i__ - ib + 1;
24038 slarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, &
24039 i__4, &ib, &a_ref(i__, i__), lda, &work[1], &ldwork, &
24040 a_ref(i__, i__ + ib), lda, &work[ib + 1], &ldwork);
24041 }
24042
24043 }
24044 } else {
24045 i__ = 1;
24046 }
24047
24048
24049
24050 if (i__ <= k) {
24051 i__2 = *m - i__ + 1;
24052 i__1 = *n - i__ + 1;
24053 sgeqr2_(&i__2, &i__1, &a_ref(i__, i__), lda, &tau[i__], &work[1], &
24054 iinfo);
24055 }
24056
24057 work[1] = (real) iws;
24058 return 0;
24059
24060
24061
24062 }
24063
24064 #undef a_ref
24065
24066
24067
24068
24069 int sorml2_(const char *side, const char *trans, integer *m, integer *n,
24070 integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
24071 real *work, integer *info)
24072 {
24073
24074
24075
24076
24077
24078
24079
24080
24081
24082
24083
24084
24085
24086
24087
24088
24089
24090
24091
24092
24093
24094
24095
24096
24097
24098
24099
24100
24101
24102
24103
24104
24105
24106
24107
24108
24109
24110
24111
24112
24113
24114
24115
24116
24117
24118
24119
24120
24121
24122
24123
24124
24125
24126
24127
24128
24129
24130
24131
24132
24133
24134
24135
24136
24137
24138
24139
24140
24141
24142
24143
24144
24145
24146
24147
24148
24149
24150
24151
24152
24153
24154
24155
24156
24157
24158
24159
24160 integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
24161
24162 static logical left;
24163 static integer i__;
24164 extern logical lsame_(const char *, const char *);
24165 extern int slarf_(const char *, integer *, integer *, real *,
24166 integer *, real *, real *, integer *, real *);
24167 static integer i1, i2, i3, ic, jc, mi, ni, nq;
24168 extern int xerbla_(const char *, integer *);
24169 static logical notran;
24170 static real aii;
24171 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
24172 #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
24173
24174 a_dim1 = *lda;
24175 a_offset = 1 + a_dim1 * 1;
24176 a -= a_offset;
24177 --tau;
24178 c_dim1 = *ldc;
24179 c_offset = 1 + c_dim1 * 1;
24180 c__ -= c_offset;
24181 --work;
24182
24183
24184 *info = 0;
24185 left = lsame_(side, "L");
24186 notran = lsame_(trans, "N");
24187
24188
24189
24190 if (left) {
24191 nq = *m;
24192 } else {
24193 nq = *n;
24194 }
24195 if (! left && ! lsame_(side, "R")) {
24196 *info = -1;
24197 } else if (! notran && ! lsame_(trans, "T")) {
24198 *info = -2;
24199 } else if (*m < 0) {
24200 *info = -3;
24201 } else if (*n < 0) {
24202 *info = -4;
24203 } else if (*k < 0 || *k > nq) {
24204 *info = -5;
24205 } else if (*lda < f2cmax(1,*k)) {
24206 *info = -7;
24207 } else if (*ldc < f2cmax(1,*m)) {
24208 *info = -10;
24209 }
24210 if (*info != 0) {
24211 i__1 = -(*info);
24212 xerbla_("SORML2", &i__1);
24213 return 0;
24214 }
24215
24216
24217
24218 if (*m == 0 || *n == 0 || *k == 0) {
24219 return 0;
24220 }
24221
24222 if (left && notran || ! left && ! notran) {
24223 i1 = 1;
24224 i2 = *k;
24225 i3 = 1;
24226 } else {
24227 i1 = *k;
24228 i2 = 1;
24229 i3 = -1;
24230 }
24231
24232 if (left) {
24233 ni = *n;
24234 jc = 1;
24235 } else {
24236 mi = *m;
24237 ic = 1;
24238 }
24239
24240 i__1 = i2;
24241 i__2 = i3;
24242 for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
24243 if (left) {
24244
24245
24246
24247 mi = *m - i__ + 1;
24248 ic = i__;
24249 } else {
24250
24251
24252
24253 ni = *n - i__ + 1;
24254 jc = i__;
24255 }
24256
24257
24258
24259 aii = a_ref(i__, i__);
24260 a_ref(i__, i__) = 1.f;
24261 slarf_(side, &mi, &ni, &a_ref(i__, i__), lda, &tau[i__], &c___ref(ic,
24262 jc), ldc, &work[1]);
24263 a_ref(i__, i__) = aii;
24264
24265 }
24266 return 0;
24267
24268
24269
24270 }
24271
24272 #undef c___ref
24273 #undef a_ref
24274
24275
24276
24277
24278 int slabrd_(integer *m, integer *n, integer *nb, real *a,
24279 integer *lda, real *d__, real *e, real *tauq, real *taup, real *x,
24280 integer *ldx, real *y, integer *ldy)
24281 {
24282
24283
24284
24285
24286
24287
24288
24289
24290
24291
24292
24293
24294
24295
24296
24297
24298
24299
24300
24301
24302
24303
24304
24305
24306
24307
24308
24309
24310
24311
24312
24313
24314
24315
24316
24317
24318
24319
24320
24321
24322
24323
24324
24325
24326
24327
24328
24329
24330
24331
24332
24333
24334
24335
24336
24337
24338
24339
24340
24341
24342
24343
24344
24345
24346
24347
24348
24349
24350
24351
24352
24353
24354
24355
24356
24357
24358
24359
24360
24361
24362
24363
24364
24365
24366
24367
24368
24369
24370
24371
24372
24373
24374
24375
24376
24377
24378
24379
24380
24381
24382
24383
24384
24385
24386
24387
24388
24389
24390
24391
24392
24393
24394
24395
24396
24397
24398
24399
24400
24401
24402
24403
24404
24405
24406
24407
24408
24409
24410
24411
24412
24413
24414 static real c_b4 = -1.f;
24415 static real c_b5 = 1.f;
24416 static integer c__1 = 1;
24417 static real c_b16 = 0.f;
24418
24419
24420 integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
24421 i__3;
24422
24423 static integer i__;
24424 extern int sscal_(integer *, real *, real *, integer *),
24425 sgemv_(const char *, integer *, integer *, real *, real *, integer *,
24426 real *, integer *, real *, real *, integer *), slarfg_(
24427 integer *, real *, real *, integer *, real *);
24428 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
24429 #define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
24430 #define y_ref(a_1,a_2) y[(a_2)*y_dim1 + a_1]
24431
24432
24433 a_dim1 = *lda;
24434 a_offset = 1 + a_dim1 * 1;
24435 a -= a_offset;
24436 --d__;
24437 --e;
24438 --tauq;
24439 --taup;
24440 x_dim1 = *ldx;
24441 x_offset = 1 + x_dim1 * 1;
24442 x -= x_offset;
24443 y_dim1 = *ldy;
24444 y_offset = 1 + y_dim1 * 1;
24445 y -= y_offset;
24446
24447
24448 if (*m <= 0 || *n <= 0) {
24449 return 0;
24450 }
24451
24452 if (*m >= *n) {
24453
24454
24455
24456 i__1 = *nb;
24457 for (i__ = 1; i__ <= i__1; ++i__) {
24458
24459
24460
24461 i__2 = *m - i__ + 1;
24462 i__3 = i__ - 1;
24463 sgemv_("No transpose", &i__2, &i__3, &c_b4, &a_ref(i__, 1), lda, &
24464 y_ref(i__, 1), ldy, &c_b5, &a_ref(i__, i__), &c__1);
24465 i__2 = *m - i__ + 1;
24466 i__3 = i__ - 1;
24467 sgemv_("No transpose", &i__2, &i__3, &c_b4, &x_ref(i__, 1), ldx, &
24468 a_ref(1, i__), &c__1, &c_b5, &a_ref(i__, i__), &c__1);
24469
24470
24471
24472
24473 i__2 = i__ + 1;
24474 i__3 = *m - i__ + 1;
24475 slarfg_(&i__3, &a_ref(i__, i__), &a_ref(f2cmin(i__2,*m), i__), &c__1,
24476 &tauq[i__]);
24477 d__[i__] = a_ref(i__, i__);
24478 if (i__ < *n) {
24479 a_ref(i__, i__) = 1.f;
24480
24481
24482
24483 i__2 = *m - i__ + 1;
24484 i__3 = *n - i__;
24485 sgemv_("Transpose", &i__2, &i__3, &c_b5, &a_ref(i__, i__ + 1),
24486 lda, &a_ref(i__, i__), &c__1, &c_b16, &y_ref(i__ + 1,
24487 i__), &c__1);
24488 i__2 = *m - i__ + 1;
24489 i__3 = i__ - 1;
24490 sgemv_("Transpose", &i__2, &i__3, &c_b5, &a_ref(i__, 1), lda,
24491 &a_ref(i__, i__), &c__1, &c_b16, &y_ref(1, i__), &
24492 c__1);
24493 i__2 = *n - i__;
24494 i__3 = i__ - 1;
24495 sgemv_("No transpose", &i__2, &i__3, &c_b4, &y_ref(i__ + 1, 1)
24496 , ldy, &y_ref(1, i__), &c__1, &c_b5, &y_ref(i__ + 1,
24497 i__), &c__1);
24498 i__2 = *m - i__ + 1;
24499 i__3 = i__ - 1;
24500 sgemv_("Transpose", &i__2, &i__3, &c_b5, &x_ref(i__, 1), ldx,
24501 &a_ref(i__, i__), &c__1, &c_b16, &y_ref(1, i__), &
24502 c__1);
24503 i__2 = i__ - 1;
24504 i__3 = *n - i__;
24505 sgemv_("Transpose", &i__2, &i__3, &c_b4, &a_ref(1, i__ + 1),
24506 lda, &y_ref(1, i__), &c__1, &c_b5, &y_ref(i__ + 1,
24507 i__), &c__1);
24508 i__2 = *n - i__;
24509 sscal_(&i__2, &tauq[i__], &y_ref(i__ + 1, i__), &c__1);
24510
24511
24512
24513 i__2 = *n - i__;
24514 sgemv_("No transpose", &i__2, &i__, &c_b4, &y_ref(i__ + 1, 1),
24515 ldy, &a_ref(i__, 1), lda, &c_b5, &a_ref(i__, i__ + 1)
24516 , lda);
24517 i__2 = i__ - 1;
24518 i__3 = *n - i__;
24519 sgemv_("Transpose", &i__2, &i__3, &c_b4, &a_ref(1, i__ + 1),
24520 lda, &x_ref(i__, 1), ldx, &c_b5, &a_ref(i__, i__ + 1),
24521 lda);
24522
24523
24524
24525
24526 i__2 = i__ + 2;
24527 i__3 = *n - i__;
24528 slarfg_(&i__3, &a_ref(i__, i__ + 1), &a_ref(i__, f2cmin(i__2,*n))
24529 , lda, &taup[i__]);
24530 e[i__] = a_ref(i__, i__ + 1);
24531 a_ref(i__, i__ + 1) = 1.f;
24532
24533
24534
24535 i__2 = *m - i__;
24536 i__3 = *n - i__;
24537 sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1,
24538 i__ + 1), lda, &a_ref(i__, i__ + 1), lda, &c_b16, &
24539 x_ref(i__ + 1, i__), &c__1);
24540 i__2 = *n - i__;
24541 sgemv_("Transpose", &i__2, &i__, &c_b5, &y_ref(i__ + 1, 1),
24542 ldy, &a_ref(i__, i__ + 1), lda, &c_b16, &x_ref(1, i__)
24543 , &c__1);
24544 i__2 = *m - i__;
24545 sgemv_("No transpose", &i__2, &i__, &c_b4, &a_ref(i__ + 1, 1),
24546 lda, &x_ref(1, i__), &c__1, &c_b5, &x_ref(i__ + 1,
24547 i__), &c__1);
24548 i__2 = i__ - 1;
24549 i__3 = *n - i__;
24550 sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(1, i__ + 1)
24551 , lda, &a_ref(i__, i__ + 1), lda, &c_b16, &x_ref(1,
24552 i__), &c__1);
24553 i__2 = *m - i__;
24554 i__3 = i__ - 1;
24555 sgemv_("No transpose", &i__2, &i__3, &c_b4, &x_ref(i__ + 1, 1)
24556 , ldx, &x_ref(1, i__), &c__1, &c_b5, &x_ref(i__ + 1,
24557 i__), &c__1);
24558 i__2 = *m - i__;
24559 sscal_(&i__2, &taup[i__], &x_ref(i__ + 1, i__), &c__1);
24560 }
24561
24562 }
24563 } else {
24564
24565
24566
24567 i__1 = *nb;
24568 for (i__ = 1; i__ <= i__1; ++i__) {
24569
24570
24571
24572 i__2 = *n - i__ + 1;
24573 i__3 = i__ - 1;
24574 sgemv_("No transpose", &i__2, &i__3, &c_b4, &y_ref(i__, 1), ldy, &
24575 a_ref(i__, 1), lda, &c_b5, &a_ref(i__, i__), lda);
24576 i__2 = i__ - 1;
24577 i__3 = *n - i__ + 1;
24578 sgemv_("Transpose", &i__2, &i__3, &c_b4, &a_ref(1, i__), lda, &
24579 x_ref(i__, 1), ldx, &c_b5, &a_ref(i__, i__), lda);
24580
24581
24582
24583
24584 i__2 = i__ + 1;
24585 i__3 = *n - i__ + 1;
24586 slarfg_(&i__3, &a_ref(i__, i__), &a_ref(i__, f2cmin(i__2,*n)), lda, &
24587 taup[i__]);
24588 d__[i__] = a_ref(i__, i__);
24589 if (i__ < *m) {
24590 a_ref(i__, i__) = 1.f;
24591
24592
24593
24594 i__2 = *m - i__;
24595 i__3 = *n - i__ + 1;
24596 sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1,
24597 i__), lda, &a_ref(i__, i__), lda, &c_b16, &x_ref(i__
24598 + 1, i__), &c__1);
24599 i__2 = *n - i__ + 1;
24600 i__3 = i__ - 1;
24601 sgemv_("Transpose", &i__2, &i__3, &c_b5, &y_ref(i__, 1), ldy,
24602 &a_ref(i__, i__), lda, &c_b16, &x_ref(1, i__), &c__1);
24603 i__2 = *m - i__;
24604 i__3 = i__ - 1;
24605 sgemv_("No transpose", &i__2, &i__3, &c_b4, &a_ref(i__ + 1, 1)
24606 , lda, &x_ref(1, i__), &c__1, &c_b5, &x_ref(i__ + 1,
24607 i__), &c__1);
24608 i__2 = i__ - 1;
24609 i__3 = *n - i__ + 1;
24610 sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(1, i__),
24611 lda, &a_ref(i__, i__), lda, &c_b16, &x_ref(1, i__), &
24612 c__1);
24613 i__2 = *m - i__;
24614 i__3 = i__ - 1;
24615 sgemv_("No transpose", &i__2, &i__3, &c_b4, &x_ref(i__ + 1, 1)
24616 , ldx, &x_ref(1, i__), &c__1, &c_b5, &x_ref(i__ + 1,
24617 i__), &c__1);
24618 i__2 = *m - i__;
24619 sscal_(&i__2, &taup[i__], &x_ref(i__ + 1, i__), &c__1);
24620
24621
24622
24623 i__2 = *m - i__;
24624 i__3 = i__ - 1;
24625 sgemv_("No transpose", &i__2, &i__3, &c_b4, &a_ref(i__ + 1, 1)
24626 , lda, &y_ref(i__, 1), ldy, &c_b5, &a_ref(i__ + 1,
24627 i__), &c__1);
24628 i__2 = *m - i__;
24629 sgemv_("No transpose", &i__2, &i__, &c_b4, &x_ref(i__ + 1, 1),
24630 ldx, &a_ref(1, i__), &c__1, &c_b5, &a_ref(i__ + 1,
24631 i__), &c__1);
24632
24633
24634
24635
24636 i__2 = i__ + 2;
24637 i__3 = *m - i__;
24638 slarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(f2cmin(i__2,*m), i__)
24639 , &c__1, &tauq[i__]);
24640 e[i__] = a_ref(i__ + 1, i__);
24641 a_ref(i__ + 1, i__) = 1.f;
24642
24643
24644
24645 i__2 = *m - i__;
24646 i__3 = *n - i__;
24647 sgemv_("Transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, i__
24648 + 1), lda, &a_ref(i__ + 1, i__), &c__1, &c_b16, &
24649 y_ref(i__ + 1, i__), &c__1);
24650 i__2 = *m - i__;
24651 i__3 = i__ - 1;
24652 sgemv_("Transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, 1),
24653 lda, &a_ref(i__ + 1, i__), &c__1, &c_b16, &y_ref(1,
24654 i__), &c__1);
24655 i__2 = *n - i__;
24656 i__3 = i__ - 1;
24657 sgemv_("No transpose", &i__2, &i__3, &c_b4, &y_ref(i__ + 1, 1)
24658 , ldy, &y_ref(1, i__), &c__1, &c_b5, &y_ref(i__ + 1,
24659 i__), &c__1);
24660 i__2 = *m - i__;
24661 sgemv_("Transpose", &i__2, &i__, &c_b5, &x_ref(i__ + 1, 1),
24662 ldx, &a_ref(i__ + 1, i__), &c__1, &c_b16, &y_ref(1,
24663 i__), &c__1);
24664 i__2 = *n - i__;
24665 sgemv_("Transpose", &i__, &i__2, &c_b4, &a_ref(1, i__ + 1),
24666 lda, &y_ref(1, i__), &c__1, &c_b5, &y_ref(i__ + 1,
24667 i__), &c__1);
24668 i__2 = *n - i__;
24669 sscal_(&i__2, &tauq[i__], &y_ref(i__ + 1, i__), &c__1);
24670 }
24671
24672 }
24673 }
24674 return 0;
24675
24676
24677
24678 }
24679
24680 #undef y_ref
24681 #undef x_ref
24682 #undef a_ref
24683
24684 int sgeqr2_(integer *m, integer *n, real *a, integer *lda,
24685 real *tau, real *work, integer *info)
24686 {
24687
24688
24689
24690
24691
24692
24693
24694
24695
24696
24697
24698
24699
24700
24701
24702
24703
24704
24705
24706
24707
24708
24709
24710
24711
24712
24713
24714
24715
24716
24717
24718
24719
24720
24721
24722
24723
24724
24725
24726
24727
24728
24729
24730
24731
24732
24733
24734
24735
24736
24737
24738
24739
24740
24741
24742
24743
24744
24745
24746
24747
24748
24749
24750
24751 static integer c__1 = 1;
24752
24753
24754 integer a_dim1, a_offset, i__1, i__2, i__3;
24755
24756 static integer i__, k;
24757 extern int slarf_(const char *, integer *, integer *, real *,
24758 integer *, real *, real *, integer *, real *), xerbla_(
24759 const char *, integer *), slarfg_(integer *, real *, real *,
24760 integer *, real *);
24761 static real aii;
24762 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
24763
24764
24765 a_dim1 = *lda;
24766 a_offset = 1 + a_dim1 * 1;
24767 a -= a_offset;
24768 --tau;
24769 --work;
24770
24771
24772 *info = 0;
24773 if (*m < 0) {
24774 *info = -1;
24775 } else if (*n < 0) {
24776 *info = -2;
24777 } else if (*lda < f2cmax(1,*m)) {
24778 *info = -4;
24779 }
24780 if (*info != 0) {
24781 i__1 = -(*info);
24782 xerbla_("SGEQR2", &i__1);
24783 return 0;
24784 }
24785
24786 k = f2cmin(*m,*n);
24787
24788 i__1 = k;
24789 for (i__ = 1; i__ <= i__1; ++i__) {
24790
24791
24792
24793
24794 i__2 = i__ + 1;
24795 i__3 = *m - i__ + 1;
24796 slarfg_(&i__3, &a_ref(i__, i__), &a_ref(f2cmin(i__2,*m), i__), &c__1, &
24797 tau[i__]);
24798 if (i__ < *n) {
24799
24800
24801
24802 aii = a_ref(i__, i__);
24803 a_ref(i__, i__) = 1.f;
24804 i__2 = *m - i__ + 1;
24805 i__3 = *n - i__;
24806 slarf_("Left", &i__2, &i__3, &a_ref(i__, i__), &c__1, &tau[i__], &
24807 a_ref(i__, i__ + 1), lda, &work[1]);
24808 a_ref(i__, i__) = aii;
24809 }
24810
24811 }
24812 return 0;
24813
24814
24815
24816 }
24817
24818 #undef a_ref
24819
24820
24821
24822
24823 int sorm2r_(const char *side, const char *trans, integer *m, integer *n,
24824 integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
24825 real *work, integer *info)
24826 {
24827
24828
24829
24830
24831
24832
24833
24834
24835
24836
24837
24838
24839
24840
24841
24842
24843
24844
24845
24846
24847
24848
24849
24850
24851
24852
24853
24854
24855
24856
24857
24858
24859
24860
24861
24862
24863
24864
24865
24866
24867
24868
24869
24870
24871
24872
24873
24874
24875
24876
24877
24878
24879
24880
24881
24882
24883
24884
24885
24886
24887
24888
24889
24890
24891
24892
24893
24894
24895
24896
24897
24898
24899
24900
24901
24902
24903
24904
24905
24906
24907
24908
24909
24910
24911
24912
24913
24914 static integer c__1 = 1;
24915
24916
24917 integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
24918
24919 static logical left;
24920 static integer i__;
24921 extern logical lsame_(const char *, const char *);
24922 extern int slarf_(const char *, integer *, integer *, real *,
24923 integer *, real *, real *, integer *, real *);
24924 static integer i1, i2, i3, ic, jc, mi, ni, nq;
24925 extern int xerbla_(const char *, integer *);
24926 static logical notran;
24927 static real aii;
24928 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
24929 #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
24930
24931
24932 a_dim1 = *lda;
24933 a_offset = 1 + a_dim1 * 1;
24934 a -= a_offset;
24935 --tau;
24936 c_dim1 = *ldc;
24937 c_offset = 1 + c_dim1 * 1;
24938 c__ -= c_offset;
24939 --work;
24940
24941
24942 *info = 0;
24943 left = lsame_(side, "L");
24944 notran = lsame_(trans, "N");
24945
24946
24947
24948 if (left) {
24949 nq = *m;
24950 } else {
24951 nq = *n;
24952 }
24953 if (! left && ! lsame_(side, "R")) {
24954 *info = -1;
24955 } else if (! notran && ! lsame_(trans, "T")) {
24956 *info = -2;
24957 } else if (*m < 0) {
24958 *info = -3;
24959 } else if (*n < 0) {
24960 *info = -4;
24961 } else if (*k < 0 || *k > nq) {
24962 *info = -5;
24963 } else if (*lda < f2cmax(1,nq)) {
24964 *info = -7;
24965 } else if (*ldc < f2cmax(1,*m)) {
24966 *info = -10;
24967 }
24968 if (*info != 0) {
24969 i__1 = -(*info);
24970 xerbla_("SORM2R", &i__1);
24971 return 0;
24972 }
24973
24974
24975
24976 if (*m == 0 || *n == 0 || *k == 0) {
24977 return 0;
24978 }
24979
24980 if (left && ! notran || ! left && notran) {
24981 i1 = 1;
24982 i2 = *k;
24983 i3 = 1;
24984 } else {
24985 i1 = *k;
24986 i2 = 1;
24987 i3 = -1;
24988 }
24989
24990 if (left) {
24991 ni = *n;
24992 jc = 1;
24993 } else {
24994 mi = *m;
24995 ic = 1;
24996 }
24997
24998 i__1 = i2;
24999 i__2 = i3;
25000 for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
25001 if (left) {
25002
25003
25004
25005 mi = *m - i__ + 1;
25006 ic = i__;
25007 } else {
25008
25009
25010
25011 ni = *n - i__ + 1;
25012 jc = i__;
25013 }
25014
25015
25016
25017 aii = a_ref(i__, i__);
25018 a_ref(i__, i__) = 1.f;
25019 slarf_(side, &mi, &ni, &a_ref(i__, i__), &c__1, &tau[i__], &c___ref(
25020 ic, jc), ldc, &work[1]);
25021 a_ref(i__, i__) = aii;
25022
25023 }
25024 return 0;
25025
25026
25027
25028 }
25029
25030 #undef c___ref
25031 #undef a_ref
25032
25033
25034
25035 int sorgbr_(const char *vect, integer *m, integer *n, integer *k,
25036 real *a, integer *lda, real *tau, real *work, integer *lwork, integer
25037 *info)
25038 {
25039
25040
25041
25042
25043
25044
25045
25046
25047
25048
25049
25050
25051
25052
25053
25054
25055
25056
25057
25058
25059
25060
25061
25062
25063
25064
25065
25066
25067
25068
25069
25070
25071
25072
25073
25074
25075
25076
25077
25078
25079
25080
25081
25082
25083
25084
25085
25086
25087
25088
25089
25090
25091
25092
25093
25094
25095
25096
25097
25098
25099
25100
25101
25102
25103
25104
25105
25106
25107
25108
25109
25110
25111
25112
25113
25114
25115
25116
25117
25118
25119
25120
25121
25122
25123
25124
25125
25126
25127
25128
25129
25130
25131
25132 static integer c__1 = 1;
25133 static integer c_n1 = -1;
25134
25135
25136 integer a_dim1, a_offset, i__1, i__2, i__3;
25137
25138 static integer i__, j;
25139 extern logical lsame_(const char *, const char *);
25140 static integer iinfo;
25141 static logical wantq;
25142 static integer nb, mn;
25143 extern int xerbla_(const char *, integer *);
25144 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
25145 integer *, integer *, ftnlen, ftnlen);
25146 extern int sorglq_(integer *, integer *, integer *, real
25147 *, integer *, real *, real *, integer *, integer *), sorgqr_(
25148 integer *, integer *, integer *, real *, integer *, real *, real *
25149 , integer *, integer *);
25150 static integer lwkopt;
25151 static logical lquery;
25152 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
25153
25154
25155 a_dim1 = *lda;
25156 a_offset = 1 + a_dim1 * 1;
25157 a -= a_offset;
25158 --tau;
25159 --work;
25160
25161
25162 *info = 0;
25163 wantq = lsame_(vect, "Q");
25164 mn = f2cmin(*m,*n);
25165 lquery = *lwork == -1;
25166 if (! wantq && ! lsame_(vect, "P")) {
25167 *info = -1;
25168 } else if (*m < 0) {
25169 *info = -2;
25170 } else if (*n < 0 || wantq && (*n > *m || *n < f2cmin(*m,*k)) || ! wantq && (
25171 *m > *n || *m < f2cmin(*n,*k))) {
25172 *info = -3;
25173 } else if (*k < 0) {
25174 *info = -4;
25175 } else if (*lda < f2cmax(1,*m)) {
25176 *info = -6;
25177 } else if (*lwork < f2cmax(1,mn) && ! lquery) {
25178 *info = -9;
25179 }
25180
25181 if (*info == 0) {
25182 if (wantq) {
25183 nb = ilaenv_(&c__1, "SORGQR", " ", m, n, k, &c_n1, (ftnlen)6, (
25184 ftnlen)1);
25185 } else {
25186 nb = ilaenv_(&c__1, "SORGLQ", " ", m, n, k, &c_n1, (ftnlen)6, (
25187 ftnlen)1);
25188 }
25189 lwkopt = f2cmax(1,mn) * nb;
25190 work[1] = (real) lwkopt;
25191 }
25192
25193 if (*info != 0) {
25194 i__1 = -(*info);
25195 xerbla_("SORGBR", &i__1);
25196 return 0;
25197 } else if (lquery) {
25198 return 0;
25199 }
25200
25201
25202
25203 if (*m == 0 || *n == 0) {
25204 work[1] = 1.f;
25205 return 0;
25206 }
25207
25208 if (wantq) {
25209
25210
25211
25212
25213 if (*m >= *k) {
25214
25215
25216
25217 sorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
25218 iinfo);
25219
25220 } else {
25221
25222
25223
25224
25225
25226
25227
25228 for (j = *m; j >= 2; --j) {
25229 a_ref(1, j) = 0.f;
25230 i__1 = *m;
25231 for (i__ = j + 1; i__ <= i__1; ++i__) {
25232 a_ref(i__, j) = a_ref(i__, j - 1);
25233
25234 }
25235
25236 }
25237 a_ref(1, 1) = 1.f;
25238 i__1 = *m;
25239 for (i__ = 2; i__ <= i__1; ++i__) {
25240 a_ref(i__, 1) = 0.f;
25241
25242 }
25243 if (*m > 1) {
25244
25245
25246
25247 i__1 = *m - 1;
25248 i__2 = *m - 1;
25249 i__3 = *m - 1;
25250 sorgqr_(&i__1, &i__2, &i__3, &a_ref(2, 2), lda, &tau[1], &
25251 work[1], lwork, &iinfo);
25252 }
25253 }
25254 } else {
25255
25256
25257
25258
25259 if (*k < *n) {
25260
25261
25262
25263 sorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
25264 iinfo);
25265
25266 } else {
25267
25268
25269
25270
25271
25272
25273
25274 a_ref(1, 1) = 1.f;
25275 i__1 = *n;
25276 for (i__ = 2; i__ <= i__1; ++i__) {
25277 a_ref(i__, 1) = 0.f;
25278
25279 }
25280 i__1 = *n;
25281 for (j = 2; j <= i__1; ++j) {
25282 for (i__ = j - 1; i__ >= 2; --i__) {
25283 a_ref(i__, j) = a_ref(i__ - 1, j);
25284
25285 }
25286 a_ref(1, j) = 0.f;
25287
25288 }
25289 if (*n > 1) {
25290
25291
25292
25293 i__1 = *n - 1;
25294 i__2 = *n - 1;
25295 i__3 = *n - 1;
25296 sorglq_(&i__1, &i__2, &i__3, &a_ref(2, 2), lda, &tau[1], &
25297 work[1], lwork, &iinfo);
25298 }
25299 }
25300 }
25301 work[1] = (real) lwkopt;
25302 return 0;
25303
25304
25305
25306 }
25307
25308 #undef a_ref
25309
25310
25311
25312
25313
25314
25315
25316
25317
25318 int slasq1_(integer *n, real *d__, real *e, real *work,
25319 integer *info)
25320 {
25321
25322 integer i__1, i__2;
25323 real r__1, r__2, r__3;
25324
25325
25326
25327
25328
25329 extern int slas2_(real *, real *, real *, real *, real *)
25330 ;
25331 static integer i__;
25332 static real scale;
25333 static integer iinfo;
25334 static real sigmn, sigmx;
25335 extern int scopy_(integer *, real *, integer *, real *,
25336 integer *), slasq2_(integer *, real *, integer *);
25337 extern doublereal slamch_(const char *);
25338 static real safmin;
25339 extern int xerbla_(const char *, integer *), slascl_(
25340 const char *, integer *, integer *, real *, real *, integer *, integer *
25341 , real *, integer *, integer *), slasrt_(const char *, integer *
25342 , real *, integer *);
25343 static real eps;
25344
25345
25346
25347
25348
25349
25350
25351
25352
25353
25354
25355
25356
25357
25358
25359
25360
25361
25362
25363
25364
25365
25366
25367
25368
25369
25370
25371
25372
25373
25374
25375
25376
25377
25378
25379
25380
25381
25382
25383
25384
25385
25386
25387
25388
25389
25390
25391
25392
25393
25394
25395
25396
25397
25398
25399
25400 --work;
25401 --e;
25402 --d__;
25403
25404
25405 *info = 0;
25406 if (*n < 0) {
25407 *info = -2;
25408 i__1 = -(*info);
25409 xerbla_("SLASQ1", &i__1);
25410 return 0;
25411 } else if (*n == 0) {
25412 return 0;
25413 } else if (*n == 1) {
25414 d__[1] = dabs(d__[1]);
25415 return 0;
25416 } else if (*n == 2) {
25417 slas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx);
25418 d__[1] = sigmx;
25419 d__[2] = sigmn;
25420 return 0;
25421 }
25422
25423
25424
25425 sigmx = 0.f;
25426 i__1 = *n - 1;
25427 for (i__ = 1; i__ <= i__1; ++i__) {
25428 d__[i__] = (r__1 = d__[i__], dabs(r__1));
25429
25430 r__2 = sigmx, r__3 = (r__1 = e[i__], dabs(r__1));
25431 sigmx = df2cmax(r__2,r__3);
25432
25433 }
25434 d__[*n] = (r__1 = d__[*n], dabs(r__1));
25435
25436
25437
25438 if (sigmx == 0.f) {
25439 slasrt_("D", n, &d__[1], &iinfo);
25440 return 0;
25441 }
25442
25443 i__1 = *n;
25444 for (i__ = 1; i__ <= i__1; ++i__) {
25445
25446 r__1 = sigmx, r__2 = d__[i__];
25447 sigmx = df2cmax(r__1,r__2);
25448
25449 }
25450
25451
25452
25453
25454 eps = slamch_("Precision");
25455 safmin = slamch_("Safe minimum");
25456 scale = sqrt(eps / safmin);
25457 scopy_(n, &d__[1], &c__1, &work[1], &c__2);
25458 i__1 = *n - 1;
25459 scopy_(&i__1, &e[1], &c__1, &work[2], &c__2);
25460 i__1 = (*n << 1) - 1;
25461 i__2 = (*n << 1) - 1;
25462 slascl_("G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2,
25463 &iinfo);
25464
25465
25466
25467 i__1 = (*n << 1) - 1;
25468 for (i__ = 1; i__ <= i__1; ++i__) {
25469
25470 r__1 = work[i__];
25471 work[i__] = r__1 * r__1;
25472
25473 }
25474 work[*n * 2] = 0.f;
25475
25476 slasq2_(n, &work[1], info);
25477
25478 if (*info == 0) {
25479 i__1 = *n;
25480 for (i__ = 1; i__ <= i__1; ++i__) {
25481 d__[i__] = sqrt(work[i__]);
25482
25483 }
25484 slascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &
25485 iinfo);
25486 }
25487
25488 return 0;
25489
25490
25491
25492 }
25493
25494
25495
25496
25497
25498 static integer c__10 = 10;
25499 static integer c__3 = 3;
25500 static integer c__4 = 4;
25501 static integer c__11 = 11;
25502
25503 int slasq2_(integer *n, real *z__, integer *info)
25504 {
25505
25506 integer i__1, i__2, i__3;
25507 real r__1, r__2;
25508
25509
25510
25511
25512
25513 static logical ieee;
25514 static integer nbig;
25515 static real dmin__, emin, emax;
25516 static integer ndiv, iter;
25517 static real qmin, temp, qmax, zmax;
25518 static integer splt;
25519 static real d__, e;
25520 static integer k;
25521 static real s, t;
25522 static integer nfail;
25523 static real desig, trace, sigma;
25524 static integer iinfo, i0, i4, n0;
25525 extern int slasq3_(integer *, integer *, real *, integer
25526 *, real *, real *, real *, real *, integer *, integer *, integer *
25527 , logical *);
25528 static integer pp;
25529 extern doublereal slamch_(const char *);
25530 static integer iwhila, iwhilb;
25531 static real oldemn, safmin;
25532 extern int xerbla_(const char *, integer *);
25533 extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *,
25534 integer *, integer *, ftnlen, ftnlen);
25535 extern int slasrt_(const char *, integer *, real *, integer *);
25536 static real eps, tol;
25537 static integer ipn4;
25538 static real tol2;
25539
25540
25541
25542
25543
25544
25545
25546
25547
25548
25549
25550
25551
25552
25553
25554
25555
25556
25557
25558
25559
25560
25561
25562
25563
25564
25565
25566
25567
25568
25569
25570
25571
25572
25573
25574
25575
25576
25577
25578
25579
25580
25581
25582
25583
25584
25585
25586
25587
25588
25589
25590
25591
25592
25593
25594
25595
25596
25597
25598
25599
25600
25601
25602
25603
25604
25605
25606 --z__;
25607
25608
25609 *info = 0;
25610 eps = slamch_("Precision");
25611 safmin = slamch_("Safe minimum");
25612 tol = eps * 100.f;
25613
25614 r__1 = tol;
25615 tol2 = r__1 * r__1;
25616
25617 if (*n < 0) {
25618 *info = -1;
25619 xerbla_("SLASQ2", &c__1);
25620 return 0;
25621 } else if (*n == 0) {
25622 return 0;
25623 } else if (*n == 1) {
25624
25625
25626
25627 if (z__[1] < 0.f) {
25628 *info = -201;
25629 xerbla_("SLASQ2", &c__2);
25630 }
25631 return 0;
25632 } else if (*n == 2) {
25633
25634
25635
25636 if (z__[2] < 0.f || z__[3] < 0.f) {
25637 *info = -2;
25638 xerbla_("SLASQ2", &c__2);
25639 return 0;
25640 } else if (z__[3] > z__[1]) {
25641 d__ = z__[3];
25642 z__[3] = z__[1];
25643 z__[1] = d__;
25644 }
25645 z__[5] = z__[1] + z__[2] + z__[3];
25646 if (z__[2] > z__[3] * tol2) {
25647 t = (z__[1] - z__[3] + z__[2]) * .5f;
25648 s = z__[3] * (z__[2] / t);
25649 if (s <= t) {
25650 s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.f) + 1.f)));
25651 } else {
25652 s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s)));
25653 }
25654 t = z__[1] + (s + z__[2]);
25655 z__[3] *= z__[1] / t;
25656 z__[1] = t;
25657 }
25658 z__[2] = z__[3];
25659 z__[6] = z__[2] + z__[1];
25660 return 0;
25661 }
25662
25663
25664
25665 z__[*n * 2] = 0.f;
25666 emin = z__[2];
25667 qmax = 0.f;
25668 zmax = 0.f;
25669 d__ = 0.f;
25670 e = 0.f;
25671
25672 i__1 = *n - 1 << 1;
25673 for (k = 1; k <= i__1; k += 2) {
25674 if (z__[k] < 0.f) {
25675 *info = -(k + 200);
25676 xerbla_("SLASQ2", &c__2);
25677 return 0;
25678 } else if (z__[k + 1] < 0.f) {
25679 *info = -(k + 201);
25680 xerbla_("SLASQ2", &c__2);
25681 return 0;
25682 }
25683 d__ += z__[k];
25684 e += z__[k + 1];
25685
25686 r__1 = qmax, r__2 = z__[k];
25687 qmax = df2cmax(r__1,r__2);
25688
25689 r__1 = emin, r__2 = z__[k + 1];
25690 emin = df2cmin(r__1,r__2);
25691
25692 r__1 = f2cmax(qmax,zmax), r__2 = z__[k + 1];
25693 zmax = df2cmax(r__1,r__2);
25694
25695 }
25696 if (z__[(*n << 1) - 1] < 0.f) {
25697 *info = -((*n << 1) + 199);
25698 xerbla_("SLASQ2", &c__2);
25699 return 0;
25700 }
25701 d__ += z__[(*n << 1) - 1];
25702
25703 r__1 = qmax, r__2 = z__[(*n << 1) - 1];
25704 qmax = df2cmax(r__1,r__2);
25705 zmax = df2cmax(qmax,zmax);
25706
25707
25708
25709 if (e == 0.f) {
25710 i__1 = *n;
25711 for (k = 2; k <= i__1; ++k) {
25712 z__[k] = z__[(k << 1) - 1];
25713
25714 }
25715 slasrt_("D", n, &z__[1], &iinfo);
25716 z__[(*n << 1) - 1] = d__;
25717 return 0;
25718 }
25719
25720 trace = d__ + e;
25721
25722
25723
25724 if (trace == 0.f) {
25725 z__[(*n << 1) - 1] = 0.f;
25726 return 0;
25727 }
25728
25729
25730
25731 ieee = ilaenv_(&c__10, "SLASQ2", "N", &c__1, &c__2, &c__3, &c__4, (ftnlen)
25732 6, (ftnlen)1) == 1 && ilaenv_(&c__11, "SLASQ2", "N", &c__1, &c__2,
25733 &c__3, &c__4, (ftnlen)6, (ftnlen)1) == 1;
25734
25735
25736
25737 for (k = *n << 1; k >= 2; k += -2) {
25738 z__[k * 2] = 0.f;
25739 z__[(k << 1) - 1] = z__[k];
25740 z__[(k << 1) - 2] = 0.f;
25741 z__[(k << 1) - 3] = z__[k - 1];
25742
25743 }
25744
25745 i0 = 1;
25746 n0 = *n;
25747
25748
25749
25750 if (z__[(i0 << 2) - 3] * 1.5f < z__[(n0 << 2) - 3]) {
25751 ipn4 = i0 + n0 << 2;
25752 i__1 = i0 + n0 - 1 << 1;
25753 for (i4 = i0 << 2; i4 <= i__1; i4 += 4) {
25754 temp = z__[i4 - 3];
25755 z__[i4 - 3] = z__[ipn4 - i4 - 3];
25756 z__[ipn4 - i4 - 3] = temp;
25757 temp = z__[i4 - 1];
25758 z__[i4 - 1] = z__[ipn4 - i4 - 5];
25759 z__[ipn4 - i4 - 5] = temp;
25760
25761 }
25762 }
25763
25764
25765
25766 pp = 0;
25767
25768 for (k = 1; k <= 2; ++k) {
25769
25770 d__ = z__[(n0 << 2) + pp - 3];
25771 i__1 = (i0 << 2) + pp;
25772 for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) {
25773 if (z__[i4 - 1] <= tol2 * d__) {
25774 z__[i4 - 1] = 0.f;
25775 d__ = z__[i4 - 3];
25776 } else {
25777 d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1]));
25778 }
25779
25780 }
25781
25782
25783
25784 emin = z__[(i0 << 2) + pp + 1];
25785 d__ = z__[(i0 << 2) + pp - 3];
25786 i__1 = (n0 - 1 << 2) + pp;
25787 for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) {
25788 z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1];
25789 if (z__[i4 - 1] <= tol2 * d__) {
25790 z__[i4 - 1] = 0.f;
25791 z__[i4 - (pp << 1) - 2] = d__;
25792 z__[i4 - (pp << 1)] = 0.f;
25793 d__ = z__[i4 + 1];
25794 } else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] &&
25795 safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) {
25796 temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2];
25797 z__[i4 - (pp << 1)] = z__[i4 - 1] * temp;
25798 d__ *= temp;
25799 } else {
25800 z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - (
25801 pp << 1) - 2]);
25802 d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]);
25803 }
25804
25805 r__1 = emin, r__2 = z__[i4 - (pp << 1)];
25806 emin = df2cmin(r__1,r__2);
25807
25808 }
25809 z__[(n0 << 2) - pp - 2] = d__;
25810
25811
25812
25813 qmax = z__[(i0 << 2) - pp - 2];
25814 i__1 = (n0 << 2) - pp - 2;
25815 for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) {
25816
25817 r__1 = qmax, r__2 = z__[i4];
25818 qmax = df2cmax(r__1,r__2);
25819
25820 }
25821
25822
25823
25824 pp = 1 - pp;
25825
25826 }
25827
25828 iter = 2;
25829 nfail = 0;
25830 ndiv = n0 - i0 << 1;
25831
25832 i__1 = *n + 1;
25833 for (iwhila = 1; iwhila <= i__1; ++iwhila) {
25834 if (n0 < 1) {
25835 goto L150;
25836 }
25837
25838
25839
25840
25841
25842
25843 desig = 0.f;
25844 if (n0 == *n) {
25845 sigma = 0.f;
25846 } else {
25847 sigma = -z__[(n0 << 2) - 1];
25848 }
25849 if (sigma < 0.f) {
25850 *info = 1;
25851 return 0;
25852 }
25853
25854
25855
25856
25857 emax = 0.f;
25858 if (n0 > i0) {
25859 emin = (r__1 = z__[(n0 << 2) - 5], dabs(r__1));
25860 } else {
25861 emin = 0.f;
25862 }
25863 qmin = z__[(n0 << 2) - 3];
25864 qmax = qmin;
25865 for (i4 = n0 << 2; i4 >= 8; i4 += -4) {
25866 if (z__[i4 - 5] <= 0.f) {
25867 goto L100;
25868 }
25869 if (qmin >= emax * 4.f) {
25870
25871 r__1 = qmin, r__2 = z__[i4 - 3];
25872 qmin = df2cmin(r__1,r__2);
25873
25874 r__1 = emax, r__2 = z__[i4 - 5];
25875 emax = df2cmax(r__1,r__2);
25876 }
25877
25878 r__1 = qmax, r__2 = z__[i4 - 7] + z__[i4 - 5];
25879 qmax = df2cmax(r__1,r__2);
25880
25881 r__1 = emin, r__2 = z__[i4 - 5];
25882 emin = df2cmin(r__1,r__2);
25883
25884 }
25885 i4 = 4;
25886
25887 L100:
25888 i0 = i4 / 4;
25889
25890
25891
25892 z__[(n0 << 2) - 1] = emin;
25893
25894
25895
25896
25897 r__1 = 0.f, r__2 = qmin - sqrt(qmin) * 2.f * sqrt(emax);
25898 dmin__ = -df2cmax(r__1,r__2);
25899
25900
25901
25902 pp = 0;
25903
25904 nbig = (n0 - i0 + 1) * 30;
25905 i__2 = nbig;
25906 for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) {
25907 if (i0 > n0) {
25908 goto L130;
25909 }
25910
25911
25912
25913 slasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, &
25914 nfail, &iter, &ndiv, &ieee);
25915
25916 pp = 1 - pp;
25917
25918
25919
25920 if (pp == 0 && n0 - i0 >= 3) {
25921 if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 *
25922 sigma) {
25923 splt = i0 - 1;
25924 qmax = z__[(i0 << 2) - 3];
25925 emin = z__[(i0 << 2) - 1];
25926 oldemn = z__[i0 * 4];
25927 i__3 = n0 - 3 << 2;
25928 for (i4 = i0 << 2; i4 <= i__3; i4 += 4) {
25929 if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <=
25930 tol2 * sigma) {
25931 z__[i4 - 1] = -sigma;
25932 splt = i4 / 4;
25933 qmax = 0.f;
25934 emin = z__[i4 + 3];
25935 oldemn = z__[i4 + 4];
25936 } else {
25937
25938 r__1 = qmax, r__2 = z__[i4 + 1];
25939 qmax = df2cmax(r__1,r__2);
25940
25941 r__1 = emin, r__2 = z__[i4 - 1];
25942 emin = df2cmin(r__1,r__2);
25943
25944 r__1 = oldemn, r__2 = z__[i4];
25945 oldemn = df2cmin(r__1,r__2);
25946 }
25947
25948 }
25949 z__[(n0 << 2) - 1] = emin;
25950 z__[n0 * 4] = oldemn;
25951 i0 = splt + 1;
25952 }
25953 }
25954
25955
25956 }
25957
25958 *info = 2;
25959 return 0;
25960
25961
25962
25963 L130:
25964
25965
25966 ;
25967 }
25968
25969 *info = 3;
25970 return 0;
25971
25972
25973
25974 L150:
25975
25976
25977
25978 i__1 = *n;
25979 for (k = 2; k <= i__1; ++k) {
25980 z__[k] = z__[(k << 2) - 3];
25981
25982 }
25983
25984
25985
25986 slasrt_("D", n, &z__[1], &iinfo);
25987
25988 e = 0.f;
25989 for (k = *n; k >= 1; --k) {
25990 e += z__[k];
25991
25992 }
25993
25994
25995
25996 z__[(*n << 1) + 1] = trace;
25997 z__[(*n << 1) + 2] = e;
25998 z__[(*n << 1) + 3] = (real) iter;
25999
26000 i__1 = *n;
26001 z__[(*n << 1) + 4] = (real) ndiv / (real) (i__1 * i__1);
26002 z__[(*n << 1) + 5] = nfail * 100.f / (real) iter;
26003 return 0;
26004
26005
26006
26007 }
26008
26009
26010
26011 int slasq3_(integer *i0, integer *n0, real *z__, integer *pp,
26012 real *dmin__, real *sigma, real *desig, real *qmax, integer *nfail,
26013 integer *iter, integer *ndiv, logical *ieee)
26014 {
26015
26016
26017
26018
26019
26020
26021
26022
26023
26024
26025
26026
26027
26028
26029
26030
26031
26032
26033
26034
26035
26036
26037
26038
26039
26040
26041
26042
26043
26044
26045
26046
26047
26048
26049
26050
26051
26052
26053
26054
26055
26056
26057
26058
26059
26060
26061
26062
26063
26064
26065
26066
26067
26068
26069
26070
26071
26072
26073
26074 static integer ttype = 0;
26075 static real dmin1 = 0.f;
26076 static real dmin2 = 0.f;
26077 static real dn = 0.f;
26078 static real dn1 = 0.f;
26079 static real dn2 = 0.f;
26080 static real tau = 0.f;
26081
26082 integer i__1;
26083 real r__1, r__2;
26084
26085
26086
26087 static real temp, s, t;
26088 static integer j4;
26089 extern int slasq4_(integer *, integer *, real *, integer
26090 *, integer *, real *, real *, real *, real *, real *, real *,
26091 real *, integer *), slasq5_(integer *, integer *, real *, integer
26092 *, real *, real *, real *, real *, real *, real *, real *,
26093 logical *), slasq6_(integer *, integer *, real *, integer *, real
26094 *, real *, real *, real *, real *, real *);
26095 static integer nn;
26096 extern doublereal slamch_(const char *);
26097 static real safmin, eps, tol;
26098 static integer n0in, ipn4;
26099 static real tol2;
26100
26101 --z__;
26102
26103
26104
26105 n0in = *n0;
26106 eps = slamch_("Precision");
26107 safmin = slamch_("Safe minimum");
26108 tol = eps * 100.f;
26109
26110 r__1 = tol;
26111 tol2 = r__1 * r__1;
26112
26113
26114
26115 L10:
26116
26117 if (*n0 < *i0) {
26118 return 0;
26119 }
26120 if (*n0 == *i0) {
26121 goto L20;
26122 }
26123 nn = (*n0 << 2) + *pp;
26124 if (*n0 == *i0 + 1) {
26125 goto L40;
26126 }
26127
26128
26129
26130 if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) -
26131 4] > tol2 * z__[nn - 7]) {
26132 goto L30;
26133 }
26134
26135 L20:
26136
26137 z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma;
26138 --(*n0);
26139 goto L10;
26140
26141
26142
26143 L30:
26144
26145 if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[
26146 nn - 11]) {
26147 goto L50;
26148 }
26149
26150 L40:
26151
26152 if (z__[nn - 3] > z__[nn - 7]) {
26153 s = z__[nn - 3];
26154 z__[nn - 3] = z__[nn - 7];
26155 z__[nn - 7] = s;
26156 }
26157 if (z__[nn - 5] > z__[nn - 3] * tol2) {
26158 t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5f;
26159 s = z__[nn - 3] * (z__[nn - 5] / t);
26160 if (s <= t) {
26161 s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.f) + 1.f)));
26162 } else {
26163 s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s)));
26164 }
26165 t = z__[nn - 7] + (s + z__[nn - 5]);
26166 z__[nn - 3] *= z__[nn - 7] / t;
26167 z__[nn - 7] = t;
26168 }
26169 z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma;
26170 z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma;
26171 *n0 += -2;
26172 goto L10;
26173
26174 L50:
26175
26176
26177
26178 if (*dmin__ <= 0.f || *n0 < n0in) {
26179 if (z__[(*i0 << 2) + *pp - 3] * 1.5f < z__[(*n0 << 2) + *pp - 3]) {
26180 ipn4 = *i0 + *n0 << 2;
26181 i__1 = *i0 + *n0 - 1 << 1;
26182 for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
26183 temp = z__[j4 - 3];
26184 z__[j4 - 3] = z__[ipn4 - j4 - 3];
26185 z__[ipn4 - j4 - 3] = temp;
26186 temp = z__[j4 - 2];
26187 z__[j4 - 2] = z__[ipn4 - j4 - 2];
26188 z__[ipn4 - j4 - 2] = temp;
26189 temp = z__[j4 - 1];
26190 z__[j4 - 1] = z__[ipn4 - j4 - 5];
26191 z__[ipn4 - j4 - 5] = temp;
26192 temp = z__[j4];
26193 z__[j4] = z__[ipn4 - j4 - 4];
26194 z__[ipn4 - j4 - 4] = temp;
26195
26196 }
26197 if (*n0 - *i0 <= 4) {
26198 z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1];
26199 z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp];
26200 }
26201
26202 r__1 = dmin2, r__2 = z__[(*n0 << 2) + *pp - 1];
26203 dmin2 = df2cmin(r__1,r__2);
26204
26205 r__1 = z__[(*n0 << 2) + *pp - 1], r__2 = z__[(*i0 << 2) + *pp - 1]
26206 , r__1 = f2cmin(r__1,r__2), r__2 = z__[(*i0 << 2) + *pp + 3];
26207 z__[(*n0 << 2) + *pp - 1] = df2cmin(r__1,r__2);
26208
26209 r__1 = z__[(*n0 << 2) - *pp], r__2 = z__[(*i0 << 2) - *pp], r__1 =
26210 f2cmin(r__1,r__2), r__2 = z__[(*i0 << 2) - *pp + 4];
26211 z__[(*n0 << 2) - *pp] = df2cmin(r__1,r__2);
26212
26213 r__1 = *qmax, r__2 = z__[(*i0 << 2) + *pp - 3], r__1 = f2cmax(r__1,
26214 r__2), r__2 = z__[(*i0 << 2) + *pp + 1];
26215 *qmax = df2cmax(r__1,r__2);
26216 *dmin__ = 0.f;
26217 }
26218 }
26219
26220
26221
26222
26223 r__1 = z__[(*n0 << 2) + *pp - 1], r__2 = z__[(*n0 << 2) + *pp - 9], r__1 =
26224 f2cmin(r__1,r__2), r__2 = dmin2 + z__[(*n0 << 2) - *pp];
26225 if (*dmin__ < 0.f || safmin * *qmax < df2cmin(r__1,r__2)) {
26226
26227
26228
26229 slasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, &dmin1, &dmin2, &dn, &dn1,
26230 &dn2, &tau, &ttype);
26231
26232
26233
26234 L80:
26235
26236 slasq5_(i0, n0, &z__[1], pp, &tau, dmin__, &dmin1, &dmin2, &dn, &dn1,
26237 &dn2, ieee);
26238
26239 *ndiv += *n0 - *i0 + 2;
26240 ++(*iter);
26241
26242
26243
26244 if (*dmin__ >= 0.f && dmin1 > 0.f) {
26245
26246
26247
26248 goto L100;
26249
26250 } else if (*dmin__ < 0.f && dmin1 > 0.f && z__[(*n0 - 1 << 2) - *pp] <
26251 tol * (*sigma + dn1) && dabs(dn) < tol * *sigma) {
26252
26253
26254
26255 z__[(*n0 - 1 << 2) - *pp + 2] = 0.f;
26256 *dmin__ = 0.f;
26257 goto L100;
26258 } else if (*dmin__ < 0.f) {
26259
26260
26261
26262 ++(*nfail);
26263 if (ttype < -22) {
26264
26265
26266
26267 tau = 0.f;
26268 } else if (dmin1 > 0.f) {
26269
26270
26271
26272 tau = (tau + *dmin__) * (1.f - eps * 2.f);
26273 ttype += -11;
26274 } else {
26275
26276
26277
26278 tau *= .25f;
26279 ttype += -12;
26280 }
26281 goto L80;
26282 } else if (*dmin__ != *dmin__) {
26283
26284
26285
26286 tau = 0.f;
26287 goto L80;
26288 } else {
26289
26290
26291
26292 goto L90;
26293 }
26294 }
26295
26296
26297
26298 L90:
26299 slasq6_(i0, n0, &z__[1], pp, dmin__, &dmin1, &dmin2, &dn, &dn1, &dn2);
26300 *ndiv += *n0 - *i0 + 2;
26301 ++(*iter);
26302 tau = 0.f;
26303
26304 L100:
26305 if (tau < *sigma) {
26306 *desig += tau;
26307 t = *sigma + *desig;
26308 *desig -= t - *sigma;
26309 } else {
26310 t = *sigma + tau;
26311 *desig = *sigma - (t - tau) + *desig;
26312 }
26313 *sigma = t;
26314
26315 return 0;
26316
26317
26318
26319 }
26320
26321
26322
26323 int slasq4_(integer *i0, integer *n0, real *z__, integer *pp,
26324 integer *n0in, real *dmin__, real *dmin1, real *dmin2, real *dn,
26325 real *dn1, real *dn2, real *tau, integer *ttype)
26326 {
26327
26328
26329 static real g = 0.f;
26330
26331
26332 integer i__1;
26333 real r__1, r__2;
26334
26335
26336
26337
26338
26339 static real s, a2, b1, b2;
26340 static integer i4, nn, np;
26341 static real gam, gap1, gap2;
26342
26343
26344
26345
26346
26347
26348
26349
26350
26351
26352
26353
26354
26355
26356
26357
26358
26359
26360
26361
26362
26363
26364
26365
26366
26367
26368
26369
26370
26371
26372
26373
26374
26375
26376
26377
26378
26379
26380
26381
26382
26383
26384
26385
26386
26387
26388
26389
26390
26391
26392
26393
26394
26395
26396
26397
26398
26399
26400
26401
26402 --z__;
26403
26404
26405
26406
26407
26408
26409 if (*dmin__ <= 0.f) {
26410 *tau = -(*dmin__);
26411 *ttype = -1;
26412 return 0;
26413 }
26414
26415 nn = (*n0 << 2) + *pp;
26416 if (*n0in == *n0) {
26417
26418
26419
26420 if (*dmin__ == *dn || *dmin__ == *dn1) {
26421
26422 b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]);
26423 b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]);
26424 a2 = z__[nn - 7] + z__[nn - 5];
26425
26426
26427
26428 if (*dmin__ == *dn && *dmin1 == *dn1) {
26429 gap2 = *dmin2 - a2 - *dmin2 * .25f;
26430 if (gap2 > 0.f && gap2 > b2) {
26431 gap1 = a2 - *dn - b2 / gap2 * b2;
26432 } else {
26433 gap1 = a2 - *dn - (b1 + b2);
26434 }
26435 if (gap1 > 0.f && gap1 > b1) {
26436
26437 r__1 = *dn - b1 / gap1 * b1, r__2 = *dmin__ * .5f;
26438 s = df2cmax(r__1,r__2);
26439 *ttype = -2;
26440 } else {
26441 s = 0.f;
26442 if (*dn > b1) {
26443 s = *dn - b1;
26444 }
26445 if (a2 > b1 + b2) {
26446
26447 r__1 = s, r__2 = a2 - (b1 + b2);
26448 s = df2cmin(r__1,r__2);
26449 }
26450
26451 r__1 = s, r__2 = *dmin__ * .333f;
26452 s = df2cmax(r__1,r__2);
26453 *ttype = -3;
26454 }
26455 } else {
26456
26457
26458
26459 *ttype = -4;
26460 s = *dmin__ * .25f;
26461 if (*dmin__ == *dn) {
26462 gam = *dn;
26463 a2 = 0.f;
26464 if (z__[nn - 5] > z__[nn - 7]) {
26465 return 0;
26466 }
26467 b2 = z__[nn - 5] / z__[nn - 7];
26468 np = nn - 9;
26469 } else {
26470 np = nn - (*pp << 1);
26471 b2 = z__[np - 2];
26472 gam = *dn1;
26473 if (z__[np - 4] > z__[np - 2]) {
26474 return 0;
26475 }
26476 a2 = z__[np - 4] / z__[np - 2];
26477 if (z__[nn - 9] > z__[nn - 11]) {
26478 return 0;
26479 }
26480 b2 = z__[nn - 9] / z__[nn - 11];
26481 np = nn - 13;
26482 }
26483
26484
26485
26486 a2 += b2;
26487 i__1 = (*i0 << 2) - 1 + *pp;
26488 for (i4 = np; i4 >= i__1; i4 += -4) {
26489 if (b2 == 0.f) {
26490 goto L20;
26491 }
26492 b1 = b2;
26493 if (z__[i4] > z__[i4 - 2]) {
26494 return 0;
26495 }
26496 b2 *= z__[i4] / z__[i4 - 2];
26497 a2 += b2;
26498 if (df2cmax(b2,b1) * 100.f < a2 || .563f < a2) {
26499 goto L20;
26500 }
26501
26502 }
26503 L20:
26504 a2 *= 1.05f;
26505
26506
26507
26508 if (a2 < .563f) {
26509 s = gam * (1.f - sqrt(a2)) / (a2 + 1.f);
26510 }
26511 }
26512 } else if (*dmin__ == *dn2) {
26513
26514
26515
26516 *ttype = -5;
26517 s = *dmin__ * .25f;
26518
26519
26520
26521 np = nn - (*pp << 1);
26522 b1 = z__[np - 2];
26523 b2 = z__[np - 6];
26524 gam = *dn2;
26525 if (z__[np - 8] > b2 || z__[np - 4] > b1) {
26526 return 0;
26527 }
26528 a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.f);
26529
26530
26531
26532 if (*n0 - *i0 > 2) {
26533 b2 = z__[nn - 13] / z__[nn - 15];
26534 a2 += b2;
26535 i__1 = (*i0 << 2) - 1 + *pp;
26536 for (i4 = nn - 17; i4 >= i__1; i4 += -4) {
26537 if (b2 == 0.f) {
26538 goto L40;
26539 }
26540 b1 = b2;
26541 if (z__[i4] > z__[i4 - 2]) {
26542 return 0;
26543 }
26544 b2 *= z__[i4] / z__[i4 - 2];
26545 a2 += b2;
26546 if (df2cmax(b2,b1) * 100.f < a2 || .563f < a2) {
26547 goto L40;
26548 }
26549
26550 }
26551 L40:
26552 a2 *= 1.05f;
26553 }
26554
26555 if (a2 < .563f) {
26556 s = gam * (1.f - sqrt(a2)) / (a2 + 1.f);
26557 }
26558 } else {
26559
26560
26561
26562 if (*ttype == -6) {
26563 g += (1.f - g) * .333f;
26564 } else if (*ttype == -18) {
26565 g = .083250000000000005f;
26566 } else {
26567 g = .25f;
26568 }
26569 s = g * *dmin__;
26570 *ttype = -6;
26571 }
26572
26573 } else if (*n0in == *n0 + 1) {
26574
26575
26576
26577 if (*dmin1 == *dn1 && *dmin2 == *dn2) {
26578
26579
26580
26581 *ttype = -7;
26582 s = *dmin1 * .333f;
26583 if (z__[nn - 5] > z__[nn - 7]) {
26584 return 0;
26585 }
26586 b1 = z__[nn - 5] / z__[nn - 7];
26587 b2 = b1;
26588 if (b2 == 0.f) {
26589 goto L60;
26590 }
26591 i__1 = (*i0 << 2) - 1 + *pp;
26592 for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
26593 a2 = b1;
26594 if (z__[i4] > z__[i4 - 2]) {
26595 return 0;
26596 }
26597 b1 *= z__[i4] / z__[i4 - 2];
26598 b2 += b1;
26599 if (df2cmax(b1,a2) * 100.f < b2) {
26600 goto L60;
26601 }
26602
26603 }
26604 L60:
26605 b2 = sqrt(b2 * 1.05f);
26606
26607 r__1 = b2;
26608 a2 = *dmin1 / (r__1 * r__1 + 1.f);
26609 gap2 = *dmin2 * .5f - a2;
26610 if (gap2 > 0.f && gap2 > b2 * a2) {
26611
26612 r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2);
26613 s = df2cmax(r__1,r__2);
26614 } else {
26615
26616 r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f);
26617 s = df2cmax(r__1,r__2);
26618 *ttype = -8;
26619 }
26620 } else {
26621
26622
26623
26624 s = *dmin1 * .25f;
26625 if (*dmin1 == *dn1) {
26626 s = *dmin1 * .5f;
26627 }
26628 *ttype = -9;
26629 }
26630
26631 } else if (*n0in == *n0 + 2) {
26632
26633
26634
26635
26636
26637 if (*dmin2 == *dn2 && z__[nn - 5] * 2.f < z__[nn - 7]) {
26638 *ttype = -10;
26639 s = *dmin2 * .333f;
26640 if (z__[nn - 5] > z__[nn - 7]) {
26641 return 0;
26642 }
26643 b1 = z__[nn - 5] / z__[nn - 7];
26644 b2 = b1;
26645 if (b2 == 0.f) {
26646 goto L80;
26647 }
26648 i__1 = (*i0 << 2) - 1 + *pp;
26649 for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
26650 if (z__[i4] > z__[i4 - 2]) {
26651 return 0;
26652 }
26653 b1 *= z__[i4] / z__[i4 - 2];
26654 b2 += b1;
26655 if (b1 * 100.f < b2) {
26656 goto L80;
26657 }
26658
26659 }
26660 L80:
26661 b2 = sqrt(b2 * 1.05f);
26662
26663 r__1 = b2;
26664 a2 = *dmin2 / (r__1 * r__1 + 1.f);
26665 gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[
26666 nn - 9]) - a2;
26667 if (gap2 > 0.f && gap2 > b2 * a2) {
26668
26669 r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2);
26670 s = df2cmax(r__1,r__2);
26671 } else {
26672
26673 r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f);
26674 s = df2cmax(r__1,r__2);
26675 }
26676 } else {
26677 s = *dmin2 * .25f;
26678 *ttype = -11;
26679 }
26680 } else if (*n0in > *n0 + 2) {
26681
26682
26683
26684 s = 0.f;
26685 *ttype = -12;
26686 }
26687
26688 *tau = s;
26689 return 0;
26690
26691
26692
26693 }
26694
26695
26696
26697 int slasq5_(integer *i0, integer *n0, real *z__, integer *pp,
26698 real *tau, real *dmin__, real *dmin1, real *dmin2, real *dn, real *
26699 dnm1, real *dnm2, logical *ieee)
26700 {
26701
26702
26703
26704
26705
26706
26707
26708
26709
26710
26711
26712
26713
26714
26715
26716
26717
26718
26719
26720
26721
26722
26723
26724
26725
26726
26727
26728
26729
26730
26731
26732
26733
26734
26735
26736
26737
26738
26739
26740
26741
26742
26743
26744
26745
26746
26747
26748
26749
26750
26751
26752
26753
26754
26755
26756
26757
26758 integer i__1;
26759 real r__1, r__2;
26760
26761 static real emin, temp, d__;
26762 static integer j4, j4p2;
26763
26764 --z__;
26765
26766
26767 if (*n0 - *i0 - 1 <= 0) {
26768 return 0;
26769 }
26770
26771 j4 = (*i0 << 2) + *pp - 3;
26772 emin = z__[j4 + 4];
26773 d__ = z__[j4] - *tau;
26774 *dmin__ = d__;
26775 *dmin1 = -z__[j4];
26776
26777 if (*ieee) {
26778
26779
26780
26781 if (*pp == 0) {
26782 i__1 = *n0 - 3 << 2;
26783 for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
26784 z__[j4 - 2] = d__ + z__[j4 - 1];
26785 temp = z__[j4 + 1] / z__[j4 - 2];
26786 d__ = d__ * temp - *tau;
26787 *dmin__ = df2cmin(*dmin__,d__);
26788 z__[j4] = z__[j4 - 1] * temp;
26789
26790 r__1 = z__[j4];
26791 emin = df2cmin(r__1,emin);
26792
26793 }
26794 } else {
26795 i__1 = *n0 - 3 << 2;
26796 for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
26797 z__[j4 - 3] = d__ + z__[j4];
26798 temp = z__[j4 + 2] / z__[j4 - 3];
26799 d__ = d__ * temp - *tau;
26800 *dmin__ = df2cmin(*dmin__,d__);
26801 z__[j4 - 1] = z__[j4] * temp;
26802
26803 r__1 = z__[j4 - 1];
26804 emin = df2cmin(r__1,emin);
26805
26806 }
26807 }
26808
26809
26810
26811 *dnm2 = d__;
26812 *dmin2 = *dmin__;
26813 j4 = (*n0 - 2 << 2) - *pp;
26814 j4p2 = j4 + (*pp << 1) - 1;
26815 z__[j4 - 2] = *dnm2 + z__[j4p2];
26816 z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
26817 *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
26818 *dmin__ = df2cmin(*dmin__,*dnm1);
26819
26820 *dmin1 = *dmin__;
26821 j4 += 4;
26822 j4p2 = j4 + (*pp << 1) - 1;
26823 z__[j4 - 2] = *dnm1 + z__[j4p2];
26824 z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
26825 *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
26826 *dmin__ = df2cmin(*dmin__,*dn);
26827
26828 } else {
26829
26830
26831
26832 if (*pp == 0) {
26833 i__1 = *n0 - 3 << 2;
26834 for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
26835 z__[j4 - 2] = d__ + z__[j4 - 1];
26836 if (d__ < 0.f) {
26837 return 0;
26838 } else {
26839 z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
26840 d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau;
26841 }
26842 *dmin__ = df2cmin(*dmin__,d__);
26843
26844 r__1 = emin, r__2 = z__[j4];
26845 emin = df2cmin(r__1,r__2);
26846
26847 }
26848 } else {
26849 i__1 = *n0 - 3 << 2;
26850 for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
26851 z__[j4 - 3] = d__ + z__[j4];
26852 if (d__ < 0.f) {
26853 return 0;
26854 } else {
26855 z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
26856 d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau;
26857 }
26858 *dmin__ = df2cmin(*dmin__,d__);
26859
26860 r__1 = emin, r__2 = z__[j4 - 1];
26861 emin = df2cmin(r__1,r__2);
26862
26863 }
26864 }
26865
26866
26867
26868 *dnm2 = d__;
26869 *dmin2 = *dmin__;
26870 j4 = (*n0 - 2 << 2) - *pp;
26871 j4p2 = j4 + (*pp << 1) - 1;
26872 z__[j4 - 2] = *dnm2 + z__[j4p2];
26873 if (*dnm2 < 0.f) {
26874 return 0;
26875 } else {
26876 z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
26877 *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
26878 }
26879 *dmin__ = df2cmin(*dmin__,*dnm1);
26880
26881 *dmin1 = *dmin__;
26882 j4 += 4;
26883 j4p2 = j4 + (*pp << 1) - 1;
26884 z__[j4 - 2] = *dnm1 + z__[j4p2];
26885 if (*dnm1 < 0.f) {
26886 return 0;
26887 } else {
26888 z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
26889 *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
26890 }
26891 *dmin__ = df2cmin(*dmin__,*dn);
26892
26893 }
26894
26895 z__[j4 + 2] = *dn;
26896 z__[(*n0 << 2) - *pp] = emin;
26897 return 0;
26898
26899
26900
26901 }
26902
26903
26904
26905 int slasq6_(integer *i0, integer *n0, real *z__, integer *pp,
26906 real *dmin__, real *dmin1, real *dmin2, real *dn, real *dnm1, real *
26907 dnm2)
26908 {
26909
26910 integer i__1;
26911 real r__1, r__2;
26912
26913
26914 static real emin, temp, d__;
26915 static integer j4;
26916 extern doublereal slamch_(const char *);
26917 static real safmin;
26918 static integer j4p2;
26919
26920
26921
26922
26923
26924
26925
26926
26927
26928
26929
26930
26931
26932
26933
26934
26935
26936
26937
26938
26939
26940
26941
26942
26943
26944
26945
26946
26947
26948
26949
26950
26951
26952
26953
26954
26955
26956
26957
26958
26959
26960
26961
26962
26963
26964
26965
26966
26967
26968
26969
26970
26971 --z__;
26972
26973
26974 if (*n0 - *i0 - 1 <= 0) {
26975 return 0;
26976 }
26977
26978 safmin = slamch_("Safe minimum");
26979 j4 = (*i0 << 2) + *pp - 3;
26980 emin = z__[j4 + 4];
26981 d__ = z__[j4];
26982 *dmin__ = d__;
26983
26984 if (*pp == 0) {
26985 i__1 = *n0 - 3 << 2;
26986 for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
26987 z__[j4 - 2] = d__ + z__[j4 - 1];
26988 if (z__[j4 - 2] == 0.f) {
26989 z__[j4] = 0.f;
26990 d__ = z__[j4 + 1];
26991 *dmin__ = d__;
26992 emin = 0.f;
26993 } else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4
26994 - 2] < z__[j4 + 1]) {
26995 temp = z__[j4 + 1] / z__[j4 - 2];
26996 z__[j4] = z__[j4 - 1] * temp;
26997 d__ *= temp;
26998 } else {
26999 z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
27000 d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]);
27001 }
27002 *dmin__ = df2cmin(*dmin__,d__);
27003
27004 r__1 = emin, r__2 = z__[j4];
27005 emin = df2cmin(r__1,r__2);
27006
27007 }
27008 } else {
27009 i__1 = *n0 - 3 << 2;
27010 for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
27011 z__[j4 - 3] = d__ + z__[j4];
27012 if (z__[j4 - 3] == 0.f) {
27013 z__[j4 - 1] = 0.f;
27014 d__ = z__[j4 + 2];
27015 *dmin__ = d__;
27016 emin = 0.f;
27017 } else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4
27018 - 3] < z__[j4 + 2]) {
27019 temp = z__[j4 + 2] / z__[j4 - 3];
27020 z__[j4 - 1] = z__[j4] * temp;
27021 d__ *= temp;
27022 } else {
27023 z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
27024 d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]);
27025 }
27026 *dmin__ = df2cmin(*dmin__,d__);
27027
27028 r__1 = emin, r__2 = z__[j4 - 1];
27029 emin = df2cmin(r__1,r__2);
27030
27031 }
27032 }
27033
27034
27035
27036 *dnm2 = d__;
27037 *dmin2 = *dmin__;
27038 j4 = (*n0 - 2 << 2) - *pp;
27039 j4p2 = j4 + (*pp << 1) - 1;
27040 z__[j4 - 2] = *dnm2 + z__[j4p2];
27041 if (z__[j4 - 2] == 0.f) {
27042 z__[j4] = 0.f;
27043 *dnm1 = z__[j4p2 + 2];
27044 *dmin__ = *dnm1;
27045 emin = 0.f;
27046 } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
27047 z__[j4p2 + 2]) {
27048 temp = z__[j4p2 + 2] / z__[j4 - 2];
27049 z__[j4] = z__[j4p2] * temp;
27050 *dnm1 = *dnm2 * temp;
27051 } else {
27052 z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
27053 *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]);
27054 }
27055 *dmin__ = df2cmin(*dmin__,*dnm1);
27056
27057 *dmin1 = *dmin__;
27058 j4 += 4;
27059 j4p2 = j4 + (*pp << 1) - 1;
27060 z__[j4 - 2] = *dnm1 + z__[j4p2];
27061 if (z__[j4 - 2] == 0.f) {
27062 z__[j4] = 0.f;
27063 *dn = z__[j4p2 + 2];
27064 *dmin__ = *dn;
27065 emin = 0.f;
27066 } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
27067 z__[j4p2 + 2]) {
27068 temp = z__[j4p2 + 2] / z__[j4 - 2];
27069 z__[j4] = z__[j4p2] * temp;
27070 *dn = *dnm1 * temp;
27071 } else {
27072 z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
27073 *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]);
27074 }
27075 *dmin__ = df2cmin(*dmin__,*dn);
27076
27077 z__[j4 + 2] = *dn;
27078 z__[(*n0 << 2) - *pp] = emin;
27079 return 0;
27080
27081
27082
27083 }
27084
27085
27086
27087 int slasv2_(real *f, real *g, real *h__, real *ssmin, real *
27088 ssmax, real *snr, real *csr, real *snl, real *csl)
27089 {
27090
27091
27092
27093
27094
27095
27096
27097
27098
27099
27100
27101
27102
27103
27104
27105
27106
27107
27108
27109
27110
27111
27112
27113
27114
27115
27116
27117
27118
27119
27120
27121
27122
27123
27124
27125
27126
27127
27128
27129
27130
27131
27132
27133
27134
27135
27136
27137
27138
27139
27140
27141
27142
27143
27144
27145
27146
27147
27148
27149
27150
27151
27152
27153
27154
27155
27156
27157
27158
27159
27160
27161 static real c_b3 = 2.f;
27162 static real c_b4 = 1.f;
27163
27164
27165 real r__1;
27166
27167
27168
27169 static integer pmax;
27170 static real temp;
27171 static logical swap;
27172 static real a, d__, l, m, r__, s, t, tsign, fa, ga, ha, ft, gt, ht, mm;
27173 static logical gasmal;
27174 extern doublereal slamch_(const char *);
27175 static real tt, clt, crt, slt, srt;
27176
27177
27178
27179
27180 ft = *f;
27181 fa = dabs(ft);
27182 ht = *h__;
27183 ha = dabs(*h__);
27184
27185
27186
27187
27188
27189
27190 pmax = 1;
27191 swap = ha > fa;
27192 if (swap) {
27193 pmax = 3;
27194 temp = ft;
27195 ft = ht;
27196 ht = temp;
27197 temp = fa;
27198 fa = ha;
27199 ha = temp;
27200
27201
27202
27203 }
27204 gt = *g;
27205 ga = dabs(gt);
27206 if (ga == 0.f) {
27207
27208
27209
27210 *ssmin = ha;
27211 *ssmax = fa;
27212 clt = 1.f;
27213 crt = 1.f;
27214 slt = 0.f;
27215 srt = 0.f;
27216 } else {
27217 gasmal = TRUE_;
27218 if (ga > fa) {
27219 pmax = 2;
27220 if (fa / ga < slamch_("EPS")) {
27221
27222
27223
27224 gasmal = FALSE_;
27225 *ssmax = ga;
27226 if (ha > 1.f) {
27227 *ssmin = fa / (ga / ha);
27228 } else {
27229 *ssmin = fa / ga * ha;
27230 }
27231 clt = 1.f;
27232 slt = ht / gt;
27233 srt = 1.f;
27234 crt = ft / gt;
27235 }
27236 }
27237 if (gasmal) {
27238
27239
27240
27241 d__ = fa - ha;
27242 if (d__ == fa) {
27243
27244
27245
27246 l = 1.f;
27247 } else {
27248 l = d__ / fa;
27249 }
27250
27251
27252
27253 m = gt / ft;
27254
27255
27256
27257 t = 2.f - l;
27258
27259
27260
27261 mm = m * m;
27262 tt = t * t;
27263 s = sqrt(tt + mm);
27264
27265
27266
27267 if (l == 0.f) {
27268 r__ = dabs(m);
27269 } else {
27270 r__ = sqrt(l * l + mm);
27271 }
27272
27273
27274
27275 a = (s + r__) * .5f;
27276
27277
27278
27279 *ssmin = ha / a;
27280 *ssmax = fa * a;
27281 if (mm == 0.f) {
27282
27283
27284
27285 if (l == 0.f) {
27286 t = r_sign(&c_b3, &ft) * r_sign(&c_b4, >);
27287 } else {
27288 t = gt / r_sign(&d__, &ft) + m / t;
27289 }
27290 } else {
27291 t = (m / (s + t) + m / (r__ + l)) * (a + 1.f);
27292 }
27293 l = sqrt(t * t + 4.f);
27294 crt = 2.f / l;
27295 srt = t / l;
27296 clt = (crt + srt * m) / a;
27297 slt = ht / ft * srt / a;
27298 }
27299 }
27300 if (swap) {
27301 *csl = srt;
27302 *snl = crt;
27303 *csr = slt;
27304 *snr = clt;
27305 } else {
27306 *csl = clt;
27307 *snl = slt;
27308 *csr = crt;
27309 *snr = srt;
27310 }
27311
27312
27313
27314 if (pmax == 1) {
27315 tsign = r_sign(&c_b4, csr) * r_sign(&c_b4, csl) * r_sign(&c_b4, f);
27316 }
27317 if (pmax == 2) {
27318 tsign = r_sign(&c_b4, snr) * r_sign(&c_b4, csl) * r_sign(&c_b4, g);
27319 }
27320 if (pmax == 3) {
27321 tsign = r_sign(&c_b4, snr) * r_sign(&c_b4, snl) * r_sign(&c_b4, h__);
27322 }
27323 *ssmax = r_sign(ssmax, &tsign);
27324 r__1 = tsign * r_sign(&c_b4, f) * r_sign(&c_b4, h__);
27325 *ssmin = r_sign(ssmin, &r__1);
27326 return 0;
27327
27328
27329
27330 }
27331
27332
27333
27334 int slas2_(real *f, real *g, real *h__, real *ssmin, real *
27335 ssmax)
27336 {
27337
27338
27339
27340
27341
27342
27343
27344
27345
27346
27347
27348
27349
27350
27351
27352
27353
27354
27355
27356
27357
27358
27359
27360
27361
27362
27363
27364
27365
27366
27367
27368
27369
27370
27371
27372
27373
27374
27375
27376
27377
27378
27379
27380
27381
27382
27383
27384
27385
27386
27387
27388
27389
27390
27391 real r__1, r__2;
27392
27393
27394
27395 static real fhmn, fhmx, c__, fa, ga, ha, as, at, au;
27396
27397
27398
27399 fa = dabs(*f);
27400 ga = dabs(*g);
27401 ha = dabs(*h__);
27402 fhmn = df2cmin(fa,ha);
27403 fhmx = df2cmax(fa,ha);
27404 if (fhmn == 0.f) {
27405 *ssmin = 0.f;
27406 if (fhmx == 0.f) {
27407 *ssmax = ga;
27408 } else {
27409
27410 r__1 = df2cmin(fhmx,ga) / df2cmax(fhmx,ga);
27411 *ssmax = df2cmax(fhmx,ga) * sqrt(r__1 * r__1 + 1.f);
27412 }
27413 } else {
27414 if (ga < fhmx) {
27415 as = fhmn / fhmx + 1.f;
27416 at = (fhmx - fhmn) / fhmx;
27417
27418 r__1 = ga / fhmx;
27419 au = r__1 * r__1;
27420 c__ = 2.f / (sqrt(as * as + au) + sqrt(at * at + au));
27421 *ssmin = fhmn * c__;
27422 *ssmax = fhmx / c__;
27423 } else {
27424 au = fhmx / ga;
27425 if (au == 0.f) {
27426
27427
27428
27429
27430
27431 *ssmin = fhmn * fhmx / ga;
27432 *ssmax = ga;
27433 } else {
27434 as = fhmn / fhmx + 1.f;
27435 at = (fhmx - fhmn) / fhmx;
27436
27437 r__1 = as * au;
27438
27439 r__2 = at * au;
27440 c__ = 1.f / (sqrt(r__1 * r__1 + 1.f) + sqrt(r__2 * r__2 + 1.f)
27441 );
27442 *ssmin = fhmn * c__ * au;
27443 *ssmin += *ssmin;
27444 *ssmax = ga / (c__ + c__);
27445 }
27446 }
27447 }
27448 return 0;
27449
27450
27451
27452 }
27453