00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015
00016
00017
00018 static integer c__1 = 1;
00019 static real c_b23 = 0.f;
00020 static integer c__0 = 0;
00021 static real c_b39 = 1.f;
00022
00023 int slatme_(integer *n, char *dist, integer *iseed, real *
00024 d__, integer *mode, real *cond, real *dmax__, char *ei, char *rsign,
00025 char *upper, char *sim, real *ds, integer *modes, real *conds,
00026 integer *kl, integer *ku, real *anorm, real *a, integer *lda, real *
00027 work, integer *info)
00028 {
00029
00030 integer a_dim1, a_offset, i__1, i__2;
00031 real r__1, r__2, r__3;
00032
00033
00034 integer i__, j, ic, jc, ir, jr, jcr;
00035 real tau;
00036 logical bads;
00037 extern int sger_(integer *, integer *, real *, real *,
00038 integer *, real *, integer *, real *, integer *);
00039 integer isim;
00040 real temp;
00041 logical badei;
00042 real alpha;
00043 extern logical lsame_(char *, char *);
00044 integer iinfo;
00045 extern int sscal_(integer *, real *, real *, integer *);
00046 real tempa[1];
00047 integer icols;
00048 logical useei;
00049 integer idist;
00050 extern int sgemv_(char *, integer *, integer *, real *,
00051 real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *);
00052 integer irows;
00053 extern int slatm1_(integer *, real *, integer *, integer
00054 *, integer *, real *, integer *, integer *);
00055 extern doublereal slange_(char *, integer *, integer *, real *, integer *,
00056 real *);
00057 extern int slarge_(integer *, real *, integer *, integer
00058 *, real *, integer *), slarfg_(integer *, real *, real *, integer
00059 *, real *), xerbla_(char *, integer *);
00060 extern doublereal slaran_(integer *);
00061 integer irsign;
00062 extern int slaset_(char *, integer *, integer *, real *,
00063 real *, real *, integer *);
00064 integer iupper;
00065 extern int slarnv_(integer *, integer *, integer *, real
00066 *);
00067 real xnorms;
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
00094
00095
00096
00097
00098
00099
00100
00101
00102
00103
00104
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118
00119
00120
00121
00122
00123
00124
00125
00126
00127
00128
00129
00130
00131
00132
00133
00134
00135
00136
00137
00138
00139
00140
00141
00142
00143
00144
00145
00146
00147
00148
00149
00150
00151
00152
00153
00154
00155
00156
00157
00158
00159
00160
00161
00162
00163
00164
00165
00166
00167
00168
00169
00170
00171
00172
00173
00174
00175
00176
00177
00178
00179
00180
00181
00182
00183
00184
00185
00186
00187
00188
00189
00190
00191
00192
00193
00194
00195
00196
00197
00198
00199
00200
00201
00202
00203
00204
00205
00206
00207
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
00306
00307
00308
00309
00310
00311
00312
00313
00314
00315
00316
00317
00318
00319 --iseed;
00320 --d__;
00321 --ei;
00322 --ds;
00323 a_dim1 = *lda;
00324 a_offset = 1 + a_dim1;
00325 a -= a_offset;
00326 --work;
00327
00328
00329 *info = 0;
00330
00331
00332
00333 if (*n == 0) {
00334 return 0;
00335 }
00336
00337
00338
00339 if (lsame_(dist, "U")) {
00340 idist = 1;
00341 } else if (lsame_(dist, "S")) {
00342 idist = 2;
00343 } else if (lsame_(dist, "N")) {
00344 idist = 3;
00345 } else {
00346 idist = -1;
00347 }
00348
00349
00350
00351 useei = TRUE_;
00352 badei = FALSE_;
00353 if (lsame_(ei + 1, " ") || *mode != 0) {
00354 useei = FALSE_;
00355 } else {
00356 if (lsame_(ei + 1, "R")) {
00357 i__1 = *n;
00358 for (j = 2; j <= i__1; ++j) {
00359 if (lsame_(ei + j, "I")) {
00360 if (lsame_(ei + (j - 1), "I")) {
00361 badei = TRUE_;
00362 }
00363 } else {
00364 if (! lsame_(ei + j, "R")) {
00365 badei = TRUE_;
00366 }
00367 }
00368
00369 }
00370 } else {
00371 badei = TRUE_;
00372 }
00373 }
00374
00375
00376
00377 if (lsame_(rsign, "T")) {
00378 irsign = 1;
00379 } else if (lsame_(rsign, "F")) {
00380 irsign = 0;
00381 } else {
00382 irsign = -1;
00383 }
00384
00385
00386
00387 if (lsame_(upper, "T")) {
00388 iupper = 1;
00389 } else if (lsame_(upper, "F")) {
00390 iupper = 0;
00391 } else {
00392 iupper = -1;
00393 }
00394
00395
00396
00397 if (lsame_(sim, "T")) {
00398 isim = 1;
00399 } else if (lsame_(sim, "F")) {
00400 isim = 0;
00401 } else {
00402 isim = -1;
00403 }
00404
00405
00406
00407 bads = FALSE_;
00408 if (*modes == 0 && isim == 1) {
00409 i__1 = *n;
00410 for (j = 1; j <= i__1; ++j) {
00411 if (ds[j] == 0.f) {
00412 bads = TRUE_;
00413 }
00414
00415 }
00416 }
00417
00418
00419
00420 if (*n < 0) {
00421 *info = -1;
00422 } else if (idist == -1) {
00423 *info = -2;
00424 } else if (abs(*mode) > 6) {
00425 *info = -5;
00426 } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) {
00427 *info = -6;
00428 } else if (badei) {
00429 *info = -8;
00430 } else if (irsign == -1) {
00431 *info = -9;
00432 } else if (iupper == -1) {
00433 *info = -10;
00434 } else if (isim == -1) {
00435 *info = -11;
00436 } else if (bads) {
00437 *info = -12;
00438 } else if (isim == 1 && abs(*modes) > 5) {
00439 *info = -13;
00440 } else if (isim == 1 && *modes != 0 && *conds < 1.f) {
00441 *info = -14;
00442 } else if (*kl < 1) {
00443 *info = -15;
00444 } else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
00445 *info = -16;
00446 } else if (*lda < max(1,*n)) {
00447 *info = -19;
00448 }
00449
00450 if (*info != 0) {
00451 i__1 = -(*info);
00452 xerbla_("SLATME", &i__1);
00453 return 0;
00454 }
00455
00456
00457
00458 for (i__ = 1; i__ <= 4; ++i__) {
00459 iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
00460
00461 }
00462
00463 if (iseed[4] % 2 != 1) {
00464 ++iseed[4];
00465 }
00466
00467
00468
00469
00470
00471 slatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo);
00472 if (iinfo != 0) {
00473 *info = 1;
00474 return 0;
00475 }
00476 if (*mode != 0 && abs(*mode) != 6) {
00477
00478
00479
00480 temp = dabs(d__[1]);
00481 i__1 = *n;
00482 for (i__ = 2; i__ <= i__1; ++i__) {
00483
00484 r__2 = temp, r__3 = (r__1 = d__[i__], dabs(r__1));
00485 temp = dmax(r__2,r__3);
00486
00487 }
00488
00489 if (temp > 0.f) {
00490 alpha = *dmax__ / temp;
00491 } else if (*dmax__ != 0.f) {
00492 *info = 2;
00493 return 0;
00494 } else {
00495 alpha = 0.f;
00496 }
00497
00498 sscal_(n, &alpha, &d__[1], &c__1);
00499
00500 }
00501
00502 slaset_("Full", n, n, &c_b23, &c_b23, &a[a_offset], lda);
00503 i__1 = *lda + 1;
00504 scopy_(n, &d__[1], &c__1, &a[a_offset], &i__1);
00505
00506
00507
00508 if (*mode == 0) {
00509 if (useei) {
00510 i__1 = *n;
00511 for (j = 2; j <= i__1; ++j) {
00512 if (lsame_(ei + j, "I")) {
00513 a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
00514 a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
00515 a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
00516 }
00517
00518 }
00519 }
00520
00521 } else if (abs(*mode) == 5) {
00522
00523 i__1 = *n;
00524 for (j = 2; j <= i__1; j += 2) {
00525 if (slaran_(&iseed[1]) > .5f) {
00526 a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
00527 a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
00528 a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
00529 }
00530
00531 }
00532 }
00533
00534
00535
00536
00537 if (iupper != 0) {
00538 i__1 = *n;
00539 for (jc = 2; jc <= i__1; ++jc) {
00540 if (a[jc - 1 + jc * a_dim1] != 0.f) {
00541 jr = jc - 2;
00542 } else {
00543 jr = jc - 1;
00544 }
00545 slarnv_(&idist, &iseed[1], &jr, &a[jc * a_dim1 + 1]);
00546
00547 }
00548 }
00549
00550
00551
00552
00553
00554
00555
00556
00557 if (isim != 0) {
00558
00559
00560
00561
00562 slatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
00563 if (iinfo != 0) {
00564 *info = 3;
00565 return 0;
00566 }
00567
00568
00569
00570 slarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
00571 if (iinfo != 0) {
00572 *info = 4;
00573 return 0;
00574 }
00575
00576
00577
00578 i__1 = *n;
00579 for (j = 1; j <= i__1; ++j) {
00580 sscal_(n, &ds[j], &a[j + a_dim1], lda);
00581 if (ds[j] != 0.f) {
00582 r__1 = 1.f / ds[j];
00583 sscal_(n, &r__1, &a[j * a_dim1 + 1], &c__1);
00584 } else {
00585 *info = 5;
00586 return 0;
00587 }
00588
00589 }
00590
00591
00592
00593 slarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
00594 if (iinfo != 0) {
00595 *info = 4;
00596 return 0;
00597 }
00598 }
00599
00600
00601
00602 if (*kl < *n - 1) {
00603
00604
00605
00606 i__1 = *n - 1;
00607 for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
00608 ic = jcr - *kl;
00609 irows = *n + 1 - jcr;
00610 icols = *n + *kl - jcr;
00611
00612 scopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
00613 xnorms = work[1];
00614 slarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
00615 work[1] = 1.f;
00616
00617 sgemv_("T", &irows, &icols, &c_b39, &a[jcr + (ic + 1) * a_dim1],
00618 lda, &work[1], &c__1, &c_b23, &work[irows + 1], &c__1);
00619 r__1 = -tau;
00620 sger_(&irows, &icols, &r__1, &work[1], &c__1, &work[irows + 1], &
00621 c__1, &a[jcr + (ic + 1) * a_dim1], lda);
00622
00623 sgemv_("N", n, &irows, &c_b39, &a[jcr * a_dim1 + 1], lda, &work[1]
00624 , &c__1, &c_b23, &work[irows + 1], &c__1);
00625 r__1 = -tau;
00626 sger_(n, &irows, &r__1, &work[irows + 1], &c__1, &work[1], &c__1,
00627 &a[jcr * a_dim1 + 1], lda);
00628
00629 a[jcr + ic * a_dim1] = xnorms;
00630 i__2 = irows - 1;
00631 slaset_("Full", &i__2, &c__1, &c_b23, &c_b23, &a[jcr + 1 + ic *
00632 a_dim1], lda);
00633
00634 }
00635 } else if (*ku < *n - 1) {
00636
00637
00638
00639 i__1 = *n - 1;
00640 for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
00641 ir = jcr - *ku;
00642 irows = *n + *ku - jcr;
00643 icols = *n + 1 - jcr;
00644
00645 scopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
00646 xnorms = work[1];
00647 slarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
00648 work[1] = 1.f;
00649
00650 sgemv_("N", &irows, &icols, &c_b39, &a[ir + 1 + jcr * a_dim1],
00651 lda, &work[1], &c__1, &c_b23, &work[icols + 1], &c__1);
00652 r__1 = -tau;
00653 sger_(&irows, &icols, &r__1, &work[icols + 1], &c__1, &work[1], &
00654 c__1, &a[ir + 1 + jcr * a_dim1], lda);
00655
00656 sgemv_("C", &icols, n, &c_b39, &a[jcr + a_dim1], lda, &work[1], &
00657 c__1, &c_b23, &work[icols + 1], &c__1);
00658 r__1 = -tau;
00659 sger_(&icols, n, &r__1, &work[1], &c__1, &work[icols + 1], &c__1,
00660 &a[jcr + a_dim1], lda);
00661
00662 a[ir + jcr * a_dim1] = xnorms;
00663 i__2 = icols - 1;
00664 slaset_("Full", &c__1, &i__2, &c_b23, &c_b23, &a[ir + (jcr + 1) *
00665 a_dim1], lda);
00666
00667 }
00668 }
00669
00670
00671
00672 if (*anorm >= 0.f) {
00673 temp = slange_("M", n, n, &a[a_offset], lda, tempa);
00674 if (temp > 0.f) {
00675 alpha = *anorm / temp;
00676 i__1 = *n;
00677 for (j = 1; j <= i__1; ++j) {
00678 sscal_(n, &alpha, &a[j * a_dim1 + 1], &c__1);
00679
00680 }
00681 }
00682 }
00683
00684 return 0;
00685
00686
00687
00688 }