dckgqr.c
Go to the documentation of this file.
00001 /* dckgqr.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 /* Table of constant values */
00017 
00018 static integer c__8 = 8;
00019 static integer c__1 = 1;
00020 static integer c__0 = 0;
00021 
00022 /* Subroutine */ int dckgqr_(integer *nm, integer *mval, integer *np, integer 
00023         *pval, integer *nn, integer *nval, integer *nmats, integer *iseed, 
00024         doublereal *thresh, integer *nmax, doublereal *a, doublereal *af, 
00025         doublereal *aq, doublereal *ar, doublereal *taua, doublereal *b, 
00026         doublereal *bf, doublereal *bz, doublereal *bt, doublereal *bwk, 
00027         doublereal *taub, doublereal *work, doublereal *rwork, integer *nin, 
00028         integer *nout, integer *info)
00029 {
00030     /* Format strings */
00031     static char fmt_9999[] = "(\002 DLATMS in DCKGQR:    INFO = \002,i5)";
00032     static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
00033             "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
00034     static char fmt_9997[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002,"
00035             "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
00036 
00037     /* System generated locals */
00038     integer i__1, i__2, i__3, i__4;
00039 
00040     /* Builtin functions */
00041     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00042     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00043 
00044     /* Local variables */
00045     integer i__, m, n, p, im, in, ip, nt, lda, ldb, kla, klb, kua, kub;
00046     char path[3];
00047     integer imat;
00048     char type__[1];
00049     integer nrun, modea, modeb, nfail;
00050     char dista[1], distb[1];
00051     integer iinfo;
00052     doublereal anorm, bnorm;
00053     integer lwork;
00054     extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer 
00055             *, integer *, char *, integer *, integer *, integer *, integer *, 
00056             doublereal *, doublereal *, integer *, integer *, doublereal *, 
00057             doublereal *, char *, char *), 
00058             alahdg_(integer *, char *);
00059     doublereal cndnma, cndnmb;
00060     extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer 
00061             *, integer *, integer *), alasum_(char *, integer *, 
00062             integer *, integer *, integer *), dlatms_(integer *, 
00063             integer *, char *, integer *, char *, doublereal *, integer *, 
00064             doublereal *, doublereal *, integer *, integer *, char *, 
00065             doublereal *, integer *, doublereal *, integer *);
00066     logical dotype[8];
00067     extern /* Subroutine */ int dgqrts_(integer *, integer *, integer *, 
00068             doublereal *, doublereal *, doublereal *, doublereal *, integer *, 
00069              doublereal *, doublereal *, doublereal *, doublereal *, 
00070             doublereal *, doublereal *, integer *, doublereal *, doublereal *, 
00071              integer *, doublereal *, doublereal *), dgrqts_(integer *, 
00072             integer *, integer *, doublereal *, doublereal *, doublereal *, 
00073             doublereal *, integer *, doublereal *, doublereal *, doublereal *, 
00074              doublereal *, doublereal *, doublereal *, integer *, doublereal *
00075 , doublereal *, integer *, doublereal *, doublereal *);
00076     logical firstt;
00077     doublereal result[7];
00078 
00079     /* Fortran I/O blocks */
00080     static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
00081     static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
00082     static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
00083     static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
00084     static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
00085     static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
00086 
00087 
00088 
00089 /*  -- LAPACK test routine (version 3.1) -- */
00090 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00091 /*     November 2006 */
00092 
00093 /*     .. Scalar Arguments .. */
00094 /*     .. */
00095 /*     .. Array Arguments .. */
00096 /*     .. */
00097 
00098 /*  Purpose */
00099 /*  ======= */
00100 
00101 /*  DCKGQR tests */
00102 /*  DGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B, */
00103 /*  DGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B. */
00104 
00105 /*  Arguments */
00106 /*  ========= */
00107 
00108 /*  NM      (input) INTEGER */
00109 /*          The number of values of M contained in the vector MVAL. */
00110 
00111 /*  MVAL    (input) INTEGER array, dimension (NM) */
00112 /*          The values of the matrix row(column) dimension M. */
00113 
00114 /*  NP      (input) INTEGER */
00115 /*          The number of values of P contained in the vector PVAL. */
00116 
00117 /*  PVAL    (input) INTEGER array, dimension (NP) */
00118 /*          The values of the matrix row(column) dimension P. */
00119 
00120 /*  NN      (input) INTEGER */
00121 /*          The number of values of N contained in the vector NVAL. */
00122 
00123 /*  NVAL    (input) INTEGER array, dimension (NN) */
00124 /*          The values of the matrix column(row) dimension N. */
00125 
00126 /*  NMATS   (input) INTEGER */
00127 /*          The number of matrix types to be tested for each combination */
00128 /*          of matrix dimensions.  If NMATS >= NTYPES (the maximum */
00129 /*          number of matrix types), then all the different types are */
00130 /*          generated for testing.  If NMATS < NTYPES, another input line */
00131 /*          is read to get the numbers of the matrix types to be used. */
00132 
00133 /*  ISEED   (input/output) INTEGER array, dimension (4) */
00134 /*          On entry, the seed of the random number generator.  The array */
00135 /*          elements should be between 0 and 4095, otherwise they will be */
00136 /*          reduced mod 4096, and ISEED(4) must be odd. */
00137 /*          On exit, the next seed in the random number sequence after */
00138 /*          all the test matrices have been generated. */
00139 
00140 /*  THRESH  (input) DOUBLE PRECISION */
00141 /*          The threshold value for the test ratios.  A result is */
00142 /*          included in the output file if RESULT >= THRESH.  To have */
00143 /*          every test ratio printed, use THRESH = 0. */
00144 
00145 /*  NMAX    (input) INTEGER */
00146 /*          The maximum value permitted for M or N, used in dimensioning */
00147 /*          the work arrays. */
00148 
00149 /*  A       (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00150 
00151 /*  AF      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00152 
00153 /*  AQ      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00154 
00155 /*  AR      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00156 
00157 /*  TAUA    (workspace) DOUBLE PRECISION array, dimension (NMAX) */
00158 
00159 /*  B       (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00160 
00161 /*  BF      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00162 
00163 /*  BZ      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00164 
00165 /*  BT      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00166 
00167 /*  BWK     (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00168 
00169 /*  TAUB    (workspace) DOUBLE PRECISION array, dimension (NMAX) */
00170 
00171 /*  WORK    (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00172 
00173 /*  RWORK   (workspace) DOUBLE PRECISION array, dimension (NMAX) */
00174 
00175 /*  NIN     (input) INTEGER */
00176 /*          The unit number for input. */
00177 
00178 /*  NOUT    (input) INTEGER */
00179 /*          The unit number for output. */
00180 
00181 /*  INFO    (output) INTEGER */
00182 /*          = 0 :  successful exit */
00183 /*          > 0 :  If DLATMS returns an error code, the absolute value */
00184 /*                 of it is returned. */
00185 
00186 /*  ===================================================================== */
00187 
00188 /*     .. Parameters .. */
00189 /*     .. */
00190 /*     .. Local Scalars .. */
00191 /*     .. */
00192 /*     .. Local Arrays .. */
00193 /*     .. */
00194 /*     .. External Subroutines .. */
00195 /*     .. */
00196 /*     .. Intrinsic Functions .. */
00197 /*     .. */
00198 /*     .. Executable Statements .. */
00199 
00200 /*     Initialize constants. */
00201 
00202     /* Parameter adjustments */
00203     --rwork;
00204     --work;
00205     --taub;
00206     --bwk;
00207     --bt;
00208     --bz;
00209     --bf;
00210     --b;
00211     --taua;
00212     --ar;
00213     --aq;
00214     --af;
00215     --a;
00216     --iseed;
00217     --nval;
00218     --pval;
00219     --mval;
00220 
00221     /* Function Body */
00222     s_copy(path, "GQR", (ftnlen)3, (ftnlen)3);
00223     *info = 0;
00224     nrun = 0;
00225     nfail = 0;
00226     firstt = TRUE_;
00227     alareq_(path, nmats, dotype, &c__8, nin, nout);
00228     lda = *nmax;
00229     ldb = *nmax;
00230     lwork = *nmax * *nmax;
00231 
00232 /*     Do for each value of M in MVAL. */
00233 
00234     i__1 = *nm;
00235     for (im = 1; im <= i__1; ++im) {
00236         m = mval[im];
00237 
00238 /*        Do for each value of P in PVAL. */
00239 
00240         i__2 = *np;
00241         for (ip = 1; ip <= i__2; ++ip) {
00242             p = pval[ip];
00243 
00244 /*           Do for each value of N in NVAL. */
00245 
00246             i__3 = *nn;
00247             for (in = 1; in <= i__3; ++in) {
00248                 n = nval[in];
00249 
00250                 for (imat = 1; imat <= 8; ++imat) {
00251 
00252 /*                 Do the tests only if DOTYPE( IMAT ) is true. */
00253 
00254                     if (! dotype[imat - 1]) {
00255                         goto L30;
00256                     }
00257 
00258 /*                 Test DGGRQF */
00259 
00260 /*                 Set up parameters with DLATB9 and generate test */
00261 /*                 matrices A and B with DLATMS. */
00262 
00263                     dlatb9_("GRQ", &imat, &m, &p, &n, type__, &kla, &kua, &
00264                             klb, &kub, &anorm, &bnorm, &modea, &modeb, &
00265                             cndnma, &cndnmb, dista, distb);
00266 
00267 /*                 Generate M by N matrix A */
00268 
00269                     dlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &
00270                             modea, &cndnma, &anorm, &kla, &kua, "No packing", 
00271                             &a[1], &lda, &work[1], &iinfo);
00272                     if (iinfo != 0) {
00273                         io___30.ciunit = *nout;
00274                         s_wsfe(&io___30);
00275                         do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
00276                                 ;
00277                         e_wsfe();
00278                         *info = abs(iinfo);
00279                         goto L30;
00280                     }
00281 
00282 /*                 Generate P by N matrix B */
00283 
00284                     dlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &
00285                             modeb, &cndnmb, &bnorm, &klb, &kub, "No packing", 
00286                             &b[1], &ldb, &work[1], &iinfo);
00287                     if (iinfo != 0) {
00288                         io___31.ciunit = *nout;
00289                         s_wsfe(&io___31);
00290                         do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
00291                                 ;
00292                         e_wsfe();
00293                         *info = abs(iinfo);
00294                         goto L30;
00295                     }
00296 
00297                     nt = 4;
00298 
00299                     dgrqts_(&m, &p, &n, &a[1], &af[1], &aq[1], &ar[1], &lda, &
00300                             taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
00301                             ldb, &taub[1], &work[1], &lwork, &rwork[1], 
00302                             result);
00303 
00304 /*                 Print information about the tests that did not */
00305 /*                 pass the threshold. */
00306 
00307                     i__4 = nt;
00308                     for (i__ = 1; i__ <= i__4; ++i__) {
00309                         if (result[i__ - 1] >= *thresh) {
00310                             if (nfail == 0 && firstt) {
00311                                 firstt = FALSE_;
00312                                 alahdg_(nout, "GRQ");
00313                             }
00314                             io___35.ciunit = *nout;
00315                             s_wsfe(&io___35);
00316                             do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
00317                                     ;
00318                             do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
00319                                     ;
00320                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00321                                     ;
00322                             do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00323                                     integer));
00324                             do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
00325                                     integer));
00326                             do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
00327                                     sizeof(doublereal));
00328                             e_wsfe();
00329                             ++nfail;
00330                         }
00331 /* L10: */
00332                     }
00333                     nrun += nt;
00334 
00335 /*                 Test DGGQRF */
00336 
00337 /*                 Set up parameters with DLATB9 and generate test */
00338 /*                 matrices A and B with DLATMS. */
00339 
00340                     dlatb9_("GQR", &imat, &m, &p, &n, type__, &kla, &kua, &
00341                             klb, &kub, &anorm, &bnorm, &modea, &modeb, &
00342                             cndnma, &cndnmb, dista, distb);
00343 
00344 /*                 Generate N-by-M matrix  A */
00345 
00346                     dlatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], &
00347                             modea, &cndnma, &anorm, &kla, &kua, "No packing", 
00348                             &a[1], &lda, &work[1], &iinfo);
00349                     if (iinfo != 0) {
00350                         io___36.ciunit = *nout;
00351                         s_wsfe(&io___36);
00352                         do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
00353                                 ;
00354                         e_wsfe();
00355                         *info = abs(iinfo);
00356                         goto L30;
00357                     }
00358 
00359 /*                 Generate N-by-P matrix  B */
00360 
00361                     dlatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], &
00362                             modea, &cndnma, &bnorm, &klb, &kub, "No packing", 
00363                             &b[1], &ldb, &work[1], &iinfo);
00364                     if (iinfo != 0) {
00365                         io___37.ciunit = *nout;
00366                         s_wsfe(&io___37);
00367                         do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
00368                                 ;
00369                         e_wsfe();
00370                         *info = abs(iinfo);
00371                         goto L30;
00372                     }
00373 
00374                     nt = 4;
00375 
00376                     dgqrts_(&n, &m, &p, &a[1], &af[1], &aq[1], &ar[1], &lda, &
00377                             taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
00378                             ldb, &taub[1], &work[1], &lwork, &rwork[1], 
00379                             result);
00380 
00381 /*                 Print information about the tests that did not */
00382 /*                 pass the threshold. */
00383 
00384                     i__4 = nt;
00385                     for (i__ = 1; i__ <= i__4; ++i__) {
00386                         if (result[i__ - 1] >= *thresh) {
00387                             if (nfail == 0 && firstt) {
00388                                 firstt = FALSE_;
00389                                 alahdg_(nout, path);
00390                             }
00391                             io___38.ciunit = *nout;
00392                             s_wsfe(&io___38);
00393                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00394                                     ;
00395                             do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
00396                                     ;
00397                             do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
00398                                     ;
00399                             do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00400                                     integer));
00401                             do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
00402                                     integer));
00403                             do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
00404                                     sizeof(doublereal));
00405                             e_wsfe();
00406                             ++nfail;
00407                         }
00408 /* L20: */
00409                     }
00410                     nrun += nt;
00411 
00412 L30:
00413                     ;
00414                 }
00415 /* L40: */
00416             }
00417 /* L50: */
00418         }
00419 /* L60: */
00420     }
00421 
00422 /*     Print a summary of the results. */
00423 
00424     alasum_(path, nout, &nfail, &nrun, &c__0);
00425 
00426     return 0;
00427 
00428 /*     End of DCKGQR */
00429 
00430 } /* dckgqr_ */

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