cchkrq.c
Go to the documentation of this file.
00001 /* cchkrq.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 cchkrq_(logical *dotype, integer *nm, integer *mval, 
00040         integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
00041         nxval, integer *nrhs, real *thresh, logical *tsterr, integer *nmax, 
00042         complex *a, complex *af, complex *aq, complex *ar, complex *ac, 
00043         complex *b, complex *x, complex *xact, complex *tau, complex *work, 
00044         real *rwork, integer *iwork, integer *nout)
00045 {
00046     /* Initialized data */
00047 
00048     static integer iseedy[4] = { 1988,1989,1990,1991 };
00049 
00050     /* Format strings */
00051     static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
00052             "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
00053             "t(\002,i2,\002)=\002,g12.5)";
00054 
00055     /* System generated locals */
00056     integer i__1, i__2, i__3, i__4, i__5;
00057 
00058     /* Builtin functions */
00059     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00060     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00061 
00062     /* Local variables */
00063     integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode, 
00064             imat, info;
00065     char path[3];
00066     integer kval[4];
00067     char dist[1], type__[1];
00068     integer nrun;
00069     extern /* Subroutine */ int alahd_(integer *, char *), cget02_(
00070             char *, integer *, integer *, integer *, complex *, integer *, 
00071             complex *, integer *, complex *, integer *, real *, real *);
00072     integer nfail, iseed[4];
00073     extern /* Subroutine */ int crqt01_(integer *, integer *, complex *, 
00074             complex *, complex *, complex *, integer *, complex *, complex *, 
00075             integer *, real *, real *), crqt02_(integer *, integer *, integer 
00076             *, complex *, complex *, complex *, complex *, integer *, complex 
00077             *, complex *, integer *, real *, real *);
00078     real anorm;
00079     extern /* Subroutine */ int crqt03_(integer *, integer *, integer *, 
00080             complex *, complex *, complex *, complex *, integer *, complex *, 
00081             complex *, integer *, real *, real *);
00082     integer minmn, nerrs, lwork;
00083     extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer 
00084             *, char *, integer *, integer *, real *, integer *, real *, char *
00085 ), alaerh_(char *, char *, integer *, 
00086             integer *, char *, integer *, integer *, integer *, integer *, 
00087             integer *, integer *, integer *, integer *, integer *);
00088     extern logical cgennd_(integer *, integer *, complex *, integer *);
00089     extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex 
00090             *, integer *, complex *, integer *), clarhs_(char *, char 
00091             *, char *, char *, integer *, integer *, integer *, integer *, 
00092             integer *, complex *, integer *, complex *, integer *, complex *, 
00093             integer *, integer *, integer *), 
00094             alasum_(char *, integer *, integer *, integer *, integer *);
00095     real cndnum;
00096     extern /* Subroutine */ int cgerqs_(integer *, integer *, integer *, 
00097             complex *, integer *, complex *, complex *, integer *, complex *, 
00098             integer *, integer *), clatms_(integer *, integer *, char *, 
00099             integer *, char *, real *, integer *, real *, real *, integer *, 
00100             integer *, char *, complex *, integer *, complex *, integer *), cerrrq_(char *, integer *), 
00101             xlaenv_(integer *, integer *);
00102     real result[8];
00103 
00104     /* Fortran I/O blocks */
00105     static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
00106 
00107 
00108 
00109 /*  -- LAPACK test routine (version 3.1) -- */
00110 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00111 /*     November 2006 */
00112 
00113 /*     .. Scalar Arguments .. */
00114 /*     .. */
00115 /*     .. Array Arguments .. */
00116 /*     .. */
00117 
00118 /*  Purpose */
00119 /*  ======= */
00120 
00121 /*  CCHKRQ tests CGERQF, CUNGRQ and CUNMRQ. */
00122 
00123 /*  Arguments */
00124 /*  ========= */
00125 
00126 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00127 /*          The matrix types to be used for testing.  Matrices of type j */
00128 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00129 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00130 
00131 /*  NM      (input) INTEGER */
00132 /*          The number of values of M contained in the vector MVAL. */
00133 
00134 /*  MVAL    (input) INTEGER array, dimension (NM) */
00135 /*          The values of the matrix row dimension M. */
00136 
00137 /*  NN      (input) INTEGER */
00138 /*          The number of values of N contained in the vector NVAL. */
00139 
00140 /*  NVAL    (input) INTEGER array, dimension (NN) */
00141 /*          The values of the matrix column dimension N. */
00142 
00143 /*  NNB     (input) INTEGER */
00144 /*          The number of values of NB and NX contained in the */
00145 /*          vectors NBVAL and NXVAL.  The blocking parameters are used */
00146 /*          in pairs (NB,NX). */
00147 
00148 /*  NBVAL   (input) INTEGER array, dimension (NNB) */
00149 /*          The values of the blocksize NB. */
00150 
00151 /*  NXVAL   (input) INTEGER array, dimension (NNB) */
00152 /*          The values of the crossover point NX. */
00153 
00154 /*  NRHS    (input) INTEGER */
00155 /*          The number of right hand side vectors to be generated for */
00156 /*          each linear system. */
00157 
00158 /*  THRESH  (input) REAL */
00159 /*          The threshold value for the test ratios.  A result is */
00160 /*          included in the output file if RESULT >= THRESH.  To have */
00161 /*          every test ratio printed, use THRESH = 0. */
00162 
00163 /*  TSTERR  (input) LOGICAL */
00164 /*          Flag that indicates whether error exits are to be tested. */
00165 
00166 /*  NMAX    (input) INTEGER */
00167 /*          The maximum value permitted for M or N, used in dimensioning */
00168 /*          the work arrays. */
00169 
00170 /*  A       (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00171 
00172 /*  AF      (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00173 
00174 /*  AQ      (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00175 
00176 /*  AR      (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00177 
00178 /*  AC      (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00179 
00180 /*  B       (workspace) COMPLEX array, dimension (NMAX*NRHS) */
00181 
00182 /*  X       (workspace) COMPLEX array, dimension (NMAX*NRHS) */
00183 
00184 /*  XACT    (workspace) COMPLEX array, dimension (NMAX*NRHS) */
00185 
00186 /*  TAU     (workspace) COMPLEX array, dimension (NMAX) */
00187 
00188 /*  WORK    (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00189 
00190 /*  RWORK   (workspace) REAL array, dimension (NMAX) */
00191 
00192 /*  IWORK   (workspace) INTEGER array, dimension (NMAX) */
00193 
00194 /*  NOUT    (input) INTEGER */
00195 /*          The unit number for output. */
00196 
00197 /*  ===================================================================== */
00198 
00199 /*     .. Parameters .. */
00200 /*     .. */
00201 /*     .. Local Scalars .. */
00202 /*     .. */
00203 /*     .. Local Arrays .. */
00204 /*     .. */
00205 /*     .. External Functions .. */
00206 /*     .. */
00207 /*     .. External Subroutines .. */
00208 /*     .. */
00209 /*     .. Intrinsic Functions .. */
00210 /*     .. */
00211 /*     .. Scalars in Common .. */
00212 /*     .. */
00213 /*     .. Common blocks .. */
00214 /*     .. */
00215 /*     .. Data statements .. */
00216     /* Parameter adjustments */
00217     --iwork;
00218     --rwork;
00219     --work;
00220     --tau;
00221     --xact;
00222     --x;
00223     --b;
00224     --ac;
00225     --ar;
00226     --aq;
00227     --af;
00228     --a;
00229     --nxval;
00230     --nbval;
00231     --nval;
00232     --mval;
00233     --dotype;
00234 
00235     /* Function Body */
00236 /*     .. */
00237 /*     .. Executable Statements .. */
00238 
00239 /*     Initialize constants and the random number seed. */
00240 
00241     s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
00242     s_copy(path + 1, "RQ", (ftnlen)2, (ftnlen)2);
00243     nrun = 0;
00244     nfail = 0;
00245     nerrs = 0;
00246     for (i__ = 1; i__ <= 4; ++i__) {
00247         iseed[i__ - 1] = iseedy[i__ - 1];
00248 /* L10: */
00249     }
00250 
00251 /*     Test the error exits */
00252 
00253     if (*tsterr) {
00254         cerrrq_(path, nout);
00255     }
00256     infoc_1.infot = 0;
00257     xlaenv_(&c__2, &c__2);
00258 
00259     lda = *nmax;
00260     lwork = *nmax * max(*nmax,*nrhs);
00261 
00262 /*     Do for each value of M in MVAL. */
00263 
00264     i__1 = *nm;
00265     for (im = 1; im <= i__1; ++im) {
00266         m = mval[im];
00267 
00268 /*        Do for each value of N in NVAL. */
00269 
00270         i__2 = *nn;
00271         for (in = 1; in <= i__2; ++in) {
00272             n = nval[in];
00273             minmn = min(m,n);
00274             for (imat = 1; imat <= 8; ++imat) {
00275 
00276 /*              Do the tests only if DOTYPE( IMAT ) is true. */
00277 
00278                 if (! dotype[imat]) {
00279                     goto L50;
00280                 }
00281 
00282 /*              Set up parameters with CLATB4 and generate a test matrix */
00283 /*              with CLATMS. */
00284 
00285                 clatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode, 
00286                         &cndnum, dist);
00287 
00288                 s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
00289                 clatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
00290                         cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
00291                         work[1], &info);
00292 
00293 /*              Check error code from CLATMS. */
00294 
00295                 if (info != 0) {
00296                     alaerh_(path, "CLATMS", &info, &c__0, " ", &m, &n, &c_n1, 
00297                             &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
00298                     goto L50;
00299                 }
00300 
00301 /*              Set some values for K: the first value must be MINMN, */
00302 /*              corresponding to the call of CRQT01; other values are */
00303 /*              used in the calls of CRQT02, and must not exceed MINMN. */
00304 
00305                 kval[0] = minmn;
00306                 kval[1] = 0;
00307                 kval[2] = 1;
00308                 kval[3] = minmn / 2;
00309                 if (minmn == 0) {
00310                     nk = 1;
00311                 } else if (minmn == 1) {
00312                     nk = 2;
00313                 } else if (minmn <= 3) {
00314                     nk = 3;
00315                 } else {
00316                     nk = 4;
00317                 }
00318 
00319 /*              Do for each value of K in KVAL */
00320 
00321                 i__3 = nk;
00322                 for (ik = 1; ik <= i__3; ++ik) {
00323                     k = kval[ik - 1];
00324 
00325 /*                 Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
00326 
00327                     i__4 = *nnb;
00328                     for (inb = 1; inb <= i__4; ++inb) {
00329                         nb = nbval[inb];
00330                         xlaenv_(&c__1, &nb);
00331                         nx = nxval[inb];
00332                         xlaenv_(&c__3, &nx);
00333                         for (i__ = 1; i__ <= 8; ++i__) {
00334                             result[i__ - 1] = 0.f;
00335                         }
00336                         nt = 2;
00337                         if (ik == 1) {
00338 
00339 /*                       Test CGERQF */
00340 
00341                             crqt01_(&m, &n, &a[1], &af[1], &aq[1], &ar[1], &
00342                                     lda, &tau[1], &work[1], &lwork, &rwork[1], 
00343                                      result);
00344                             if (m <= n) {
00345 /*                          Check the upper-right m-by-m corner */
00346                                 if (! cgennd_(&m, &m, &af[lda * (n - m) + 1], 
00347                                         &lda)) {
00348                                     result[7] = *thresh * 2;
00349                                 }
00350                             } else {
00351 /*                          Check the (m-n)th subdiagonal */
00352                                 i__ = m - n;
00353                                 if (! cgennd_(&n, &n, &af[i__ + 1], &lda)) {
00354                                     result[7] = *thresh * 2;
00355                                 }
00356                             }
00357                         } else if (m <= n) {
00358 
00359 /*                       Test CUNGRQ, using factorization */
00360 /*                       returned by CRQT01 */
00361 
00362                             crqt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &ar[1], 
00363                                      &lda, &tau[1], &work[1], &lwork, &rwork[
00364                                     1], result);
00365                         } else {
00366                             result[0] = 0.f;
00367                             result[1] = 0.f;
00368                         }
00369                         if (m >= k) {
00370 
00371 /*                       Test CUNMRQ, using factorization returned */
00372 /*                       by CRQT01 */
00373 
00374                             crqt03_(&m, &n, &k, &af[1], &ac[1], &ar[1], &aq[1]
00375 , &lda, &tau[1], &work[1], &lwork, &rwork[
00376                                     1], &result[2]);
00377                             nt += 4;
00378 
00379 /*                       If M>=N and K=N, call CGERQS to solve a system */
00380 /*                       with NRHS right hand sides and compute the */
00381 /*                       residual. */
00382 
00383                             if (k == m && inb == 1) {
00384 
00385 /*                          Generate a solution and set the right */
00386 /*                          hand side. */
00387 
00388                                 s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, 
00389                                         (ftnlen)6);
00390                                 clarhs_(path, "New", "Full", "No transpose", &
00391                                         m, &n, &c__0, &c__0, nrhs, &a[1], &
00392                                         lda, &xact[1], &lda, &b[1], &lda, 
00393                                         iseed, &info);
00394 
00395                                 clacpy_("Full", &m, nrhs, &b[1], &lda, &x[n - 
00396                                         m + 1], &lda);
00397                                 s_copy(srnamc_1.srnamt, "CGERQS", (ftnlen)32, 
00398                                         (ftnlen)6);
00399                                 cgerqs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
00400                                         x[1], &lda, &work[1], &lwork, &info);
00401 
00402 /*                          Check error code from CGERQS. */
00403 
00404                                 if (info != 0) {
00405                                     alaerh_(path, "CGERQS", &info, &c__0, 
00406                                             " ", &m, &n, nrhs, &c_n1, &nb, &
00407                                             imat, &nfail, &nerrs, nout);
00408                                 }
00409 
00410                                 cget02_("No transpose", &m, &n, nrhs, &a[1], &
00411                                         lda, &x[1], &lda, &b[1], &lda, &rwork[
00412                                         1], &result[6]);
00413                                 ++nt;
00414                             } else {
00415                                 result[6] = 0.f;
00416                             }
00417                         } else {
00418                             result[2] = 0.f;
00419                             result[3] = 0.f;
00420                             result[4] = 0.f;
00421                             result[5] = 0.f;
00422                         }
00423 
00424 /*                    Print information about the tests that did not */
00425 /*                    pass the threshold. */
00426 
00427                         i__5 = nt;
00428                         for (i__ = 1; i__ <= i__5; ++i__) {
00429                             if (result[i__ - 1] >= *thresh) {
00430                                 if (nfail == 0 && nerrs == 0) {
00431                                     alahd_(nout, path);
00432                                 }
00433                                 io___33.ciunit = *nout;
00434                                 s_wsfe(&io___33);
00435                                 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
00436                                         integer));
00437                                 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00438                                         integer));
00439                                 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00440                                         integer));
00441                                 do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
00442                                         integer));
00443                                 do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
00444                                         integer));
00445                                 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00446                                         integer));
00447                                 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
00448                                         integer));
00449                                 do_fio(&c__1, (char *)&result[i__ - 1], (
00450                                         ftnlen)sizeof(real));
00451                                 e_wsfe();
00452                                 ++nfail;
00453                             }
00454 /* L20: */
00455                         }
00456                         nrun += nt;
00457 /* L30: */
00458                     }
00459 /* L40: */
00460                 }
00461 L50:
00462                 ;
00463             }
00464 /* L60: */
00465         }
00466 /* L70: */
00467     }
00468 
00469 /*     Print a summary of the results. */
00470 
00471     alasum_(path, nout, &nfail, &nrun, &nerrs);
00472 
00473     return 0;
00474 
00475 /*     End of CCHKRQ */
00476 
00477 } /* cchkrq_ */

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