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 doublereal c_b23 = 0.;
00020 static integer c__0 = 0;
00021 static doublereal c_b39 = 1.;
00022
00023 int dlatme_(integer *n, char *dist, integer *iseed,
00024 doublereal *d__, integer *mode, doublereal *cond, doublereal *dmax__,
00025 char *ei, char *rsign, char *upper, char *sim, doublereal *ds,
00026 integer *modes, doublereal *conds, integer *kl, integer *ku,
00027 doublereal *anorm, doublereal *a, integer *lda, doublereal *work,
00028 integer *info)
00029 {
00030
00031 integer a_dim1, a_offset, i__1, i__2;
00032 doublereal d__1, d__2, d__3;
00033
00034
00035 integer i__, j, ic, jc, ir, jr, jcr;
00036 doublereal tau;
00037 logical bads;
00038 extern int dger_(integer *, integer *, doublereal *,
00039 doublereal *, integer *, doublereal *, integer *, doublereal *,
00040 integer *);
00041 integer isim;
00042 doublereal temp;
00043 logical badei;
00044 doublereal alpha;
00045 extern int dscal_(integer *, doublereal *, doublereal *,
00046 integer *);
00047 extern logical lsame_(char *, char *);
00048 extern int dgemv_(char *, integer *, integer *,
00049 doublereal *, doublereal *, integer *, doublereal *, integer *,
00050 doublereal *, doublereal *, integer *);
00051 integer iinfo;
00052 doublereal tempa[1];
00053 integer icols;
00054 logical useei;
00055 integer idist;
00056 extern int dcopy_(integer *, doublereal *, integer *,
00057 doublereal *, integer *);
00058 integer irows;
00059 extern int dlatm1_(integer *, doublereal *, integer *,
00060 integer *, integer *, doublereal *, integer *, integer *);
00061 extern doublereal dlange_(char *, integer *, integer *, doublereal *,
00062 integer *, doublereal *);
00063 extern int dlarge_(integer *, doublereal *, integer *,
00064 integer *, doublereal *, integer *), dlarfg_(integer *,
00065 doublereal *, doublereal *, integer *, doublereal *);
00066 extern doublereal dlaran_(integer *);
00067 extern int dlaset_(char *, integer *, integer *,
00068 doublereal *, doublereal *, doublereal *, integer *),
00069 xerbla_(char *, integer *), dlarnv_(integer *, integer *,
00070 integer *, doublereal *);
00071 integer irsign, iupper;
00072 doublereal xnorms;
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
00320
00321
00322
00323
00324 --iseed;
00325 --d__;
00326 --ei;
00327 --ds;
00328 a_dim1 = *lda;
00329 a_offset = 1 + a_dim1;
00330 a -= a_offset;
00331 --work;
00332
00333
00334 *info = 0;
00335
00336
00337
00338 if (*n == 0) {
00339 return 0;
00340 }
00341
00342
00343
00344 if (lsame_(dist, "U")) {
00345 idist = 1;
00346 } else if (lsame_(dist, "S")) {
00347 idist = 2;
00348 } else if (lsame_(dist, "N")) {
00349 idist = 3;
00350 } else {
00351 idist = -1;
00352 }
00353
00354
00355
00356 useei = TRUE_;
00357 badei = FALSE_;
00358 if (lsame_(ei + 1, " ") || *mode != 0) {
00359 useei = FALSE_;
00360 } else {
00361 if (lsame_(ei + 1, "R")) {
00362 i__1 = *n;
00363 for (j = 2; j <= i__1; ++j) {
00364 if (lsame_(ei + j, "I")) {
00365 if (lsame_(ei + (j - 1), "I")) {
00366 badei = TRUE_;
00367 }
00368 } else {
00369 if (! lsame_(ei + j, "R")) {
00370 badei = TRUE_;
00371 }
00372 }
00373
00374 }
00375 } else {
00376 badei = TRUE_;
00377 }
00378 }
00379
00380
00381
00382 if (lsame_(rsign, "T")) {
00383 irsign = 1;
00384 } else if (lsame_(rsign, "F")) {
00385 irsign = 0;
00386 } else {
00387 irsign = -1;
00388 }
00389
00390
00391
00392 if (lsame_(upper, "T")) {
00393 iupper = 1;
00394 } else if (lsame_(upper, "F")) {
00395 iupper = 0;
00396 } else {
00397 iupper = -1;
00398 }
00399
00400
00401
00402 if (lsame_(sim, "T")) {
00403 isim = 1;
00404 } else if (lsame_(sim, "F")) {
00405 isim = 0;
00406 } else {
00407 isim = -1;
00408 }
00409
00410
00411
00412 bads = FALSE_;
00413 if (*modes == 0 && isim == 1) {
00414 i__1 = *n;
00415 for (j = 1; j <= i__1; ++j) {
00416 if (ds[j] == 0.) {
00417 bads = TRUE_;
00418 }
00419
00420 }
00421 }
00422
00423
00424
00425 if (*n < 0) {
00426 *info = -1;
00427 } else if (idist == -1) {
00428 *info = -2;
00429 } else if (abs(*mode) > 6) {
00430 *info = -5;
00431 } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
00432 *info = -6;
00433 } else if (badei) {
00434 *info = -8;
00435 } else if (irsign == -1) {
00436 *info = -9;
00437 } else if (iupper == -1) {
00438 *info = -10;
00439 } else if (isim == -1) {
00440 *info = -11;
00441 } else if (bads) {
00442 *info = -12;
00443 } else if (isim == 1 && abs(*modes) > 5) {
00444 *info = -13;
00445 } else if (isim == 1 && *modes != 0 && *conds < 1.) {
00446 *info = -14;
00447 } else if (*kl < 1) {
00448 *info = -15;
00449 } else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
00450 *info = -16;
00451 } else if (*lda < max(1,*n)) {
00452 *info = -19;
00453 }
00454
00455 if (*info != 0) {
00456 i__1 = -(*info);
00457 xerbla_("DLATME", &i__1);
00458 return 0;
00459 }
00460
00461
00462
00463 for (i__ = 1; i__ <= 4; ++i__) {
00464 iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
00465
00466 }
00467
00468 if (iseed[4] % 2 != 1) {
00469 ++iseed[4];
00470 }
00471
00472
00473
00474
00475
00476 dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo);
00477 if (iinfo != 0) {
00478 *info = 1;
00479 return 0;
00480 }
00481 if (*mode != 0 && abs(*mode) != 6) {
00482
00483
00484
00485 temp = abs(d__[1]);
00486 i__1 = *n;
00487 for (i__ = 2; i__ <= i__1; ++i__) {
00488
00489 d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
00490 temp = max(d__2,d__3);
00491
00492 }
00493
00494 if (temp > 0.) {
00495 alpha = *dmax__ / temp;
00496 } else if (*dmax__ != 0.) {
00497 *info = 2;
00498 return 0;
00499 } else {
00500 alpha = 0.;
00501 }
00502
00503 dscal_(n, &alpha, &d__[1], &c__1);
00504
00505 }
00506
00507 dlaset_("Full", n, n, &c_b23, &c_b23, &a[a_offset], lda);
00508 i__1 = *lda + 1;
00509 dcopy_(n, &d__[1], &c__1, &a[a_offset], &i__1);
00510
00511
00512
00513 if (*mode == 0) {
00514 if (useei) {
00515 i__1 = *n;
00516 for (j = 2; j <= i__1; ++j) {
00517 if (lsame_(ei + j, "I")) {
00518 a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
00519 a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
00520 a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
00521 }
00522
00523 }
00524 }
00525
00526 } else if (abs(*mode) == 5) {
00527
00528 i__1 = *n;
00529 for (j = 2; j <= i__1; j += 2) {
00530 if (dlaran_(&iseed[1]) > .5) {
00531 a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
00532 a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
00533 a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
00534 }
00535
00536 }
00537 }
00538
00539
00540
00541
00542 if (iupper != 0) {
00543 i__1 = *n;
00544 for (jc = 2; jc <= i__1; ++jc) {
00545 if (a[jc - 1 + jc * a_dim1] != 0.) {
00546 jr = jc - 2;
00547 } else {
00548 jr = jc - 1;
00549 }
00550 dlarnv_(&idist, &iseed[1], &jr, &a[jc * a_dim1 + 1]);
00551
00552 }
00553 }
00554
00555
00556
00557
00558
00559
00560
00561
00562 if (isim != 0) {
00563
00564
00565
00566
00567 dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
00568 if (iinfo != 0) {
00569 *info = 3;
00570 return 0;
00571 }
00572
00573
00574
00575 dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
00576 if (iinfo != 0) {
00577 *info = 4;
00578 return 0;
00579 }
00580
00581
00582
00583 i__1 = *n;
00584 for (j = 1; j <= i__1; ++j) {
00585 dscal_(n, &ds[j], &a[j + a_dim1], lda);
00586 if (ds[j] != 0.) {
00587 d__1 = 1. / ds[j];
00588 dscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1);
00589 } else {
00590 *info = 5;
00591 return 0;
00592 }
00593
00594 }
00595
00596
00597
00598 dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
00599 if (iinfo != 0) {
00600 *info = 4;
00601 return 0;
00602 }
00603 }
00604
00605
00606
00607 if (*kl < *n - 1) {
00608
00609
00610
00611 i__1 = *n - 1;
00612 for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
00613 ic = jcr - *kl;
00614 irows = *n + 1 - jcr;
00615 icols = *n + *kl - jcr;
00616
00617 dcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
00618 xnorms = work[1];
00619 dlarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
00620 work[1] = 1.;
00621
00622 dgemv_("T", &irows, &icols, &c_b39, &a[jcr + (ic + 1) * a_dim1],
00623 lda, &work[1], &c__1, &c_b23, &work[irows + 1], &c__1);
00624 d__1 = -tau;
00625 dger_(&irows, &icols, &d__1, &work[1], &c__1, &work[irows + 1], &
00626 c__1, &a[jcr + (ic + 1) * a_dim1], lda);
00627
00628 dgemv_("N", n, &irows, &c_b39, &a[jcr * a_dim1 + 1], lda, &work[1]
00629 , &c__1, &c_b23, &work[irows + 1], &c__1);
00630 d__1 = -tau;
00631 dger_(n, &irows, &d__1, &work[irows + 1], &c__1, &work[1], &c__1,
00632 &a[jcr * a_dim1 + 1], lda);
00633
00634 a[jcr + ic * a_dim1] = xnorms;
00635 i__2 = irows - 1;
00636 dlaset_("Full", &i__2, &c__1, &c_b23, &c_b23, &a[jcr + 1 + ic *
00637 a_dim1], lda);
00638
00639 }
00640 } else if (*ku < *n - 1) {
00641
00642
00643
00644 i__1 = *n - 1;
00645 for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
00646 ir = jcr - *ku;
00647 irows = *n + *ku - jcr;
00648 icols = *n + 1 - jcr;
00649
00650 dcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
00651 xnorms = work[1];
00652 dlarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
00653 work[1] = 1.;
00654
00655 dgemv_("N", &irows, &icols, &c_b39, &a[ir + 1 + jcr * a_dim1],
00656 lda, &work[1], &c__1, &c_b23, &work[icols + 1], &c__1);
00657 d__1 = -tau;
00658 dger_(&irows, &icols, &d__1, &work[icols + 1], &c__1, &work[1], &
00659 c__1, &a[ir + 1 + jcr * a_dim1], lda);
00660
00661 dgemv_("C", &icols, n, &c_b39, &a[jcr + a_dim1], lda, &work[1], &
00662 c__1, &c_b23, &work[icols + 1], &c__1);
00663 d__1 = -tau;
00664 dger_(&icols, n, &d__1, &work[1], &c__1, &work[icols + 1], &c__1,
00665 &a[jcr + a_dim1], lda);
00666
00667 a[ir + jcr * a_dim1] = xnorms;
00668 i__2 = icols - 1;
00669 dlaset_("Full", &c__1, &i__2, &c_b23, &c_b23, &a[ir + (jcr + 1) *
00670 a_dim1], lda);
00671
00672 }
00673 }
00674
00675
00676
00677 if (*anorm >= 0.) {
00678 temp = dlange_("M", n, n, &a[a_offset], lda, tempa);
00679 if (temp > 0.) {
00680 alpha = *anorm / temp;
00681 i__1 = *n;
00682 for (j = 1; j <= i__1; ++j) {
00683 dscal_(n, &alpha, &a[j * a_dim1 + 1], &c__1);
00684
00685 }
00686 }
00687 }
00688
00689 return 0;
00690
00691
00692
00693 }