dchkql.c
Go to the documentation of this file.
00001 /* dchkql.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 
00016 /* Common Block Declarations */
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 /* Table of constant values */
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 /* Subroutine */ 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     /* Initialized data */
00048 
00049     static integer iseedy[4] = { 1988,1989,1990,1991 };
00050 
00051     /* Format strings */
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     /* System generated locals */
00057     integer i__1, i__2, i__3, i__4, i__5;
00058 
00059     /* Builtin functions */
00060     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00061     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00062 
00063     /* Local variables */
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 /* Subroutine */ 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 /* Subroutine */ 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 /* Subroutine */ 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 /* Subroutine */ 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 /* Subroutine */ 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     /* Fortran I/O blocks */
00110     static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
00111 
00112 
00113 
00114 /*  -- LAPACK test routine (version 3.1) -- */
00115 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00116 /*     November 2006 */
00117 
00118 /*     .. Scalar Arguments .. */
00119 /*     .. */
00120 /*     .. Array Arguments .. */
00121 /*     .. */
00122 
00123 /*  Purpose */
00124 /*  ======= */
00125 
00126 /*  DCHKQL tests DGEQLF, DORGQL and DORMQL. */
00127 
00128 /*  Arguments */
00129 /*  ========= */
00130 
00131 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00132 /*          The matrix types to be used for testing.  Matrices of type j */
00133 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00134 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00135 
00136 /*  NM      (input) INTEGER */
00137 /*          The number of values of M contained in the vector MVAL. */
00138 
00139 /*  MVAL    (input) INTEGER array, dimension (NM) */
00140 /*          The values of the matrix row dimension M. */
00141 
00142 /*  NN      (input) INTEGER */
00143 /*          The number of values of N contained in the vector NVAL. */
00144 
00145 /*  NVAL    (input) INTEGER array, dimension (NN) */
00146 /*          The values of the matrix column dimension N. */
00147 
00148 /*  NNB     (input) INTEGER */
00149 /*          The number of values of NB and NX contained in the */
00150 /*          vectors NBVAL and NXVAL.  The blocking parameters are used */
00151 /*          in pairs (NB,NX). */
00152 
00153 /*  NBVAL   (input) INTEGER array, dimension (NNB) */
00154 /*          The values of the blocksize NB. */
00155 
00156 /*  NXVAL   (input) INTEGER array, dimension (NNB) */
00157 /*          The values of the crossover point NX. */
00158 
00159 /*  NRHS    (input) INTEGER */
00160 /*          The number of right hand side vectors to be generated for */
00161 /*          each linear system. */
00162 
00163 /*  THRESH  (input) DOUBLE PRECISION */
00164 /*          The threshold value for the test ratios.  A result is */
00165 /*          included in the output file if RESULT >= THRESH.  To have */
00166 /*          every test ratio printed, use THRESH = 0. */
00167 
00168 /*  TSTERR  (input) LOGICAL */
00169 /*          Flag that indicates whether error exits are to be tested. */
00170 
00171 /*  NMAX    (input) INTEGER */
00172 /*          The maximum value permitted for M or N, used in dimensioning */
00173 /*          the work arrays. */
00174 
00175 /*  A       (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00176 
00177 /*  AF      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00178 
00179 /*  AQ      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00180 
00181 /*  AL      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00182 
00183 /*  AC      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00184 
00185 /*  B       (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
00186 
00187 /*  X       (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
00188 
00189 /*  XACT    (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
00190 
00191 /*  TAU     (workspace) DOUBLE PRECISION array, dimension (NMAX) */
00192 
00193 /*  WORK    (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00194 
00195 /*  RWORK   (workspace) DOUBLE PRECISION array, dimension (NMAX) */
00196 
00197 /*  IWORK   (workspace) INTEGER array, dimension (NMAX) */
00198 
00199 /*  NOUT    (input) INTEGER */
00200 /*          The unit number for output. */
00201 
00202 /*  ===================================================================== */
00203 
00204 /*     .. Parameters .. */
00205 /*     .. */
00206 /*     .. Local Scalars .. */
00207 /*     .. */
00208 /*     .. Local Arrays .. */
00209 /*     .. */
00210 /*     .. External Functions .. */
00211 /*     .. */
00212 /*     .. External Subroutines .. */
00213 /*     .. */
00214 /*     .. Intrinsic Functions .. */
00215 /*     .. */
00216 /*     .. Scalars in Common .. */
00217 /*     .. */
00218 /*     .. Common blocks .. */
00219 /*     .. */
00220 /*     .. Data statements .. */
00221     /* Parameter adjustments */
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     /* Function Body */
00241 /*     .. */
00242 /*     .. Executable Statements .. */
00243 
00244 /*     Initialize constants and the random number seed. */
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 /* L10: */
00254     }
00255 
00256 /*     Test the error exits */
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 /*     Do for each value of M in MVAL. */
00268 
00269     i__1 = *nm;
00270     for (im = 1; im <= i__1; ++im) {
00271         m = mval[im];
00272 
00273 /*        Do for each value of N in NVAL. */
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 /*              Do the tests only if DOTYPE( IMAT ) is true. */
00282 
00283                 if (! dotype[imat]) {
00284                     goto L50;
00285                 }
00286 
00287 /*              Set up parameters with DLATB4 and generate a test matrix */
00288 /*              with DLATMS. */
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 /*              Check error code from DLATMS. */
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 /*              Set some values for K: the first value must be MINMN, */
00307 /*              corresponding to the call of DQLT01; other values are */
00308 /*              used in the calls of DQLT02, and must not exceed MINMN. */
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 /*              Do for each value of K in KVAL */
00325 
00326                 i__3 = nk;
00327                 for (ik = 1; ik <= i__3; ++ik) {
00328                     k = kval[ik - 1];
00329 
00330 /*                 Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
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 /*                       Test DGEQLF */
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 /*                          Check the lower-left n-by-n corner */
00351                                 if (! dgennd_(&n, &n, &af[m - n + 1], &lda)) {
00352                                     result[7] = *thresh * 2;
00353                                 }
00354                             } else {
00355 /*                          Check the (n-m)th superdiagonal */
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 /*                       Test DORGQL, using factorization */
00364 /*                       returned by DQLT01 */
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 /*                       Test DORMQL, using factorization returned */
00376 /*                       by DQLT01 */
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 /*                       If M>=N and K=N, call DGEQLS to solve a system */
00384 /*                       with NRHS right hand sides and compute the */
00385 /*                       residual. */
00386 
00387                             if (k == n && inb == 1) {
00388 
00389 /*                          Generate a solution and set the right */
00390 /*                          hand side. */
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 /*                          Check error code from DGEQLS. */
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 /*                    Print information about the tests that did not */
00429 /*                    pass the threshold. */
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 /* L20: */
00459                         }
00460                         nrun += nt;
00461 /* L30: */
00462                     }
00463 /* L40: */
00464                 }
00465 L50:
00466                 ;
00467             }
00468 /* L60: */
00469         }
00470 /* L70: */
00471     }
00472 
00473 /*     Print a summary of the results. */
00474 
00475     alasum_(path, nout, &nfail, &nrun, &nerrs);
00476 
00477     return 0;
00478 
00479 /*     End of DCHKQL */
00480 
00481 } /* dchkql_ */

swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:55:38