00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015
00016
00017
00018 struct {
00019 integer infot, nunit;
00020 logical ok, lerr;
00021 } infoc_;
00022
00023 #define infoc_1 infoc_
00024
00025 struct {
00026 char srnamt[32];
00027 } srnamc_;
00028
00029 #define srnamc_1 srnamc_
00030
00031
00032
00033 static integer c__2 = 2;
00034 static integer c__0 = 0;
00035 static integer c_n1 = -1;
00036 static integer c__1 = 1;
00037 static integer c__3 = 3;
00038
00039 int dchkql_(logical *dotype, integer *nm, integer *mval,
00040 integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
00041 nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
00042 nmax, doublereal *a, doublereal *af, doublereal *aq, doublereal *al,
00043 doublereal *ac, doublereal *b, doublereal *x, doublereal *xact,
00044 doublereal *tau, doublereal *work, doublereal *rwork, integer *iwork,
00045 integer *nout)
00046 {
00047
00048
00049 static integer iseedy[4] = { 1988,1989,1990,1991 };
00050
00051
00052 static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
00053 "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
00054 "t(\002,i2,\002)=\002,g12.5)";
00055
00056
00057 integer i__1, i__2, i__3, i__4, i__5;
00058
00059
00060 int s_copy(char *, char *, ftnlen, ftnlen);
00061 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00062
00063
00064 integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
00065 imat, info;
00066 char path[3];
00067 integer kval[4];
00068 char dist[1], type__[1];
00069 integer nrun;
00070 extern int alahd_(integer *, char *), dget02_(
00071 char *, integer *, integer *, integer *, doublereal *, integer *,
00072 doublereal *, integer *, doublereal *, integer *, doublereal *,
00073 doublereal *);
00074 integer nfail, iseed[4];
00075 extern int dqlt01_(integer *, integer *, doublereal *,
00076 doublereal *, doublereal *, doublereal *, integer *, doublereal *,
00077 doublereal *, integer *, doublereal *, doublereal *), dqlt02_(
00078 integer *, integer *, integer *, doublereal *, doublereal *,
00079 doublereal *, doublereal *, integer *, doublereal *, doublereal *,
00080 integer *, doublereal *, doublereal *), dqlt03_(integer *,
00081 integer *, integer *, doublereal *, doublereal *, doublereal *,
00082 doublereal *, integer *, doublereal *, doublereal *, integer *,
00083 doublereal *, doublereal *);
00084 doublereal anorm;
00085 integer minmn, nerrs, lwork;
00086 extern int dlatb4_(char *, integer *, integer *, integer
00087 *, char *, integer *, integer *, doublereal *, integer *,
00088 doublereal *, char *), alaerh_(char *,
00089 char *, integer *, integer *, char *, integer *, integer *,
00090 integer *, integer *, integer *, integer *, integer *, integer *,
00091 integer *);
00092 extern logical dgennd_(integer *, integer *, doublereal *, integer *);
00093 extern int dlacpy_(char *, integer *, integer *,
00094 doublereal *, integer *, doublereal *, integer *),
00095 dlarhs_(char *, char *, char *, char *, integer *, integer *,
00096 integer *, integer *, integer *, doublereal *, integer *,
00097 doublereal *, integer *, doublereal *, integer *, integer *,
00098 integer *), dgeqls_(integer *,
00099 integer *, integer *, doublereal *, integer *, doublereal *,
00100 doublereal *, integer *, doublereal *, integer *, integer *),
00101 alasum_(char *, integer *, integer *, integer *, integer *);
00102 doublereal cndnum;
00103 extern int dlatms_(integer *, integer *, char *, integer
00104 *, char *, doublereal *, integer *, doublereal *, doublereal *,
00105 integer *, integer *, char *, doublereal *, integer *, doublereal
00106 *, integer *), derrql_(char *, integer *), xlaenv_(integer *, integer *);
00107 doublereal result[8];
00108
00109
00110 static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
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 --iwork;
00223 --rwork;
00224 --work;
00225 --tau;
00226 --xact;
00227 --x;
00228 --b;
00229 --ac;
00230 --al;
00231 --aq;
00232 --af;
00233 --a;
00234 --nxval;
00235 --nbval;
00236 --nval;
00237 --mval;
00238 --dotype;
00239
00240
00241
00242
00243
00244
00245
00246 s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
00247 s_copy(path + 1, "QL", (ftnlen)2, (ftnlen)2);
00248 nrun = 0;
00249 nfail = 0;
00250 nerrs = 0;
00251 for (i__ = 1; i__ <= 4; ++i__) {
00252 iseed[i__ - 1] = iseedy[i__ - 1];
00253
00254 }
00255
00256
00257
00258 if (*tsterr) {
00259 derrql_(path, nout);
00260 }
00261 infoc_1.infot = 0;
00262 xlaenv_(&c__2, &c__2);
00263
00264 lda = *nmax;
00265 lwork = *nmax * max(*nmax,*nrhs);
00266
00267
00268
00269 i__1 = *nm;
00270 for (im = 1; im <= i__1; ++im) {
00271 m = mval[im];
00272
00273
00274
00275 i__2 = *nn;
00276 for (in = 1; in <= i__2; ++in) {
00277 n = nval[in];
00278 minmn = min(m,n);
00279 for (imat = 1; imat <= 8; ++imat) {
00280
00281
00282
00283 if (! dotype[imat]) {
00284 goto L50;
00285 }
00286
00287
00288
00289
00290 dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
00291 &cndnum, dist);
00292
00293 s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
00294 dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
00295 cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
00296 work[1], &info);
00297
00298
00299
00300 if (info != 0) {
00301 alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
00302 &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
00303 goto L50;
00304 }
00305
00306
00307
00308
00309
00310 kval[0] = minmn;
00311 kval[1] = 0;
00312 kval[2] = 1;
00313 kval[3] = minmn / 2;
00314 if (minmn == 0) {
00315 nk = 1;
00316 } else if (minmn == 1) {
00317 nk = 2;
00318 } else if (minmn <= 3) {
00319 nk = 3;
00320 } else {
00321 nk = 4;
00322 }
00323
00324
00325
00326 i__3 = nk;
00327 for (ik = 1; ik <= i__3; ++ik) {
00328 k = kval[ik - 1];
00329
00330
00331
00332 i__4 = *nnb;
00333 for (inb = 1; inb <= i__4; ++inb) {
00334 nb = nbval[inb];
00335 xlaenv_(&c__1, &nb);
00336 nx = nxval[inb];
00337 xlaenv_(&c__3, &nx);
00338 for (i__ = 1; i__ <= 8; ++i__) {
00339 result[i__ - 1] = 0.;
00340 }
00341 nt = 2;
00342 if (ik == 1) {
00343
00344
00345
00346 dqlt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
00347 lda, &tau[1], &work[1], &lwork, &rwork[1],
00348 result);
00349 if (m >= n) {
00350
00351 if (! dgennd_(&n, &n, &af[m - n + 1], &lda)) {
00352 result[7] = *thresh * 2;
00353 }
00354 } else {
00355
00356 if (! dgennd_(&m, &m, &af[(n - m) * lda + 1],
00357 &lda)) {
00358 result[7] = *thresh * 2;
00359 }
00360 }
00361 } else if (m >= n) {
00362
00363
00364
00365
00366 dqlt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
00367 &lda, &tau[1], &work[1], &lwork, &rwork[
00368 1], result);
00369 } else {
00370 result[0] = 0.;
00371 result[1] = 0.;
00372 }
00373 if (m >= k) {
00374
00375
00376
00377
00378 dqlt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
00379 , &lda, &tau[1], &work[1], &lwork, &rwork[
00380 1], &result[2]);
00381 nt += 4;
00382
00383
00384
00385
00386
00387 if (k == n && inb == 1) {
00388
00389
00390
00391
00392 s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32,
00393 (ftnlen)6);
00394 dlarhs_(path, "New", "Full", "No transpose", &
00395 m, &n, &c__0, &c__0, nrhs, &a[1], &
00396 lda, &xact[1], &lda, &b[1], &lda,
00397 iseed, &info);
00398
00399 dlacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
00400 &lda);
00401 s_copy(srnamc_1.srnamt, "DGEQLS", (ftnlen)32,
00402 (ftnlen)6);
00403 dgeqls_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
00404 x[1], &lda, &work[1], &lwork, &info);
00405
00406
00407
00408 if (info != 0) {
00409 alaerh_(path, "DGEQLS", &info, &c__0,
00410 " ", &m, &n, nrhs, &c_n1, &nb, &
00411 imat, &nfail, &nerrs, nout);
00412 }
00413
00414 dget02_("No transpose", &m, &n, nrhs, &a[1], &
00415 lda, &x[m - n + 1], &lda, &b[1], &lda,
00416 &rwork[1], &result[6]);
00417 ++nt;
00418 } else {
00419 result[6] = 0.;
00420 }
00421 } else {
00422 result[2] = 0.;
00423 result[3] = 0.;
00424 result[4] = 0.;
00425 result[5] = 0.;
00426 }
00427
00428
00429
00430
00431 i__5 = nt;
00432 for (i__ = 1; i__ <= i__5; ++i__) {
00433 if (result[i__ - 1] >= *thresh) {
00434 if (nfail == 0 && nerrs == 0) {
00435 alahd_(nout, path);
00436 }
00437 io___33.ciunit = *nout;
00438 s_wsfe(&io___33);
00439 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
00440 integer));
00441 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00442 integer));
00443 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00444 integer));
00445 do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
00446 integer));
00447 do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
00448 integer));
00449 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00450 integer));
00451 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
00452 integer));
00453 do_fio(&c__1, (char *)&result[i__ - 1], (
00454 ftnlen)sizeof(doublereal));
00455 e_wsfe();
00456 ++nfail;
00457 }
00458
00459 }
00460 nrun += nt;
00461
00462 }
00463
00464 }
00465 L50:
00466 ;
00467 }
00468
00469 }
00470
00471 }
00472
00473
00474
00475 alasum_(path, nout, &nfail, &nrun, &nerrs);
00476
00477 return 0;
00478
00479
00480
00481 }