zckgsv.c
Go to the documentation of this file.
00001 /* zckgsv.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 zckgsv_(integer *nm, integer *mval, integer *pval, 
00023         integer *nval, integer *nmats, integer *iseed, doublereal *thresh, 
00024         integer *nmax, doublecomplex *a, doublecomplex *af, doublecomplex *b, 
00025         doublecomplex *bf, doublecomplex *u, doublecomplex *v, doublecomplex *
00026         q, doublereal *alpha, doublereal *beta, doublecomplex *r__, integer *
00027         iwork, doublecomplex *work, doublereal *rwork, integer *nin, integer *
00028         nout, integer *info)
00029 {
00030     /* Format strings */
00031     static char fmt_9999[] = "(\002 ZLATMS in ZCKGSV   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 
00035     /* System generated locals */
00036     integer i__1, i__2;
00037 
00038     /* Builtin functions */
00039     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00040     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00041 
00042     /* Local variables */
00043     integer i__, m, n, p, im, nt, lda, ldb, kla, klb, kua, kub, ldq, ldr, ldu,
00044              ldv, imat;
00045     char path[3], type__[1];
00046     integer nrun, modea, modeb, nfail;
00047     char dista[1], distb[1];
00048     integer iinfo;
00049     doublereal anorm, bnorm;
00050     integer lwork;
00051     extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer 
00052             *, integer *, char *, integer *, integer *, integer *, integer *, 
00053             doublereal *, doublereal *, integer *, integer *, doublereal *, 
00054             doublereal *, char *, char *), 
00055             alahdg_(integer *, char *);
00056     doublereal cndnma, cndnmb;
00057     extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer 
00058             *, integer *, integer *), alasum_(char *, integer *, 
00059             integer *, integer *, integer *);
00060     logical dotype[8];
00061     extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer 
00062             *, char *, doublereal *, integer *, doublereal *, doublereal *, 
00063             integer *, integer *, char *, doublecomplex *, integer *, 
00064             doublecomplex *, integer *);
00065     logical firstt;
00066     doublereal result[7];
00067     extern /* Subroutine */ int zgsvts_(integer *, integer *, integer *, 
00068             doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
00069             doublecomplex *, integer *, doublecomplex *, integer *, 
00070             doublecomplex *, integer *, doublecomplex *, integer *, 
00071             doublereal *, doublereal *, doublecomplex *, integer *, integer *, 
00072              doublecomplex *, integer *, doublereal *, doublereal *);
00073 
00074     /* Fortran I/O blocks */
00075     static cilist io___32 = { 0, 0, 0, fmt_9999, 0 };
00076     static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
00077     static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
00078 
00079 
00080 
00081 /*  -- LAPACK test routine (version 3.1) -- */
00082 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00083 /*     November 2006 */
00084 
00085 /*     .. Scalar Arguments .. */
00086 /*     .. */
00087 /*     .. Array Arguments .. */
00088 /*     .. */
00089 
00090 /*  Purpose */
00091 /*  ======= */
00092 
00093 /*  ZCKGSV tests ZGGSVD: */
00094 /*         the GSVD for M-by-N matrix A and P-by-N matrix B. */
00095 
00096 /*  Arguments */
00097 /*  ========= */
00098 
00099 /*  NM      (input) INTEGER */
00100 /*          The number of values of M contained in the vector MVAL. */
00101 
00102 /*  MVAL    (input) INTEGER array, dimension (NM) */
00103 /*          The values of the matrix row dimension M. */
00104 
00105 /*  PVAL    (input) INTEGER array, dimension (NP) */
00106 /*          The values of the matrix row dimension P. */
00107 
00108 /*  NVAL    (input) INTEGER array, dimension (NN) */
00109 /*          The values of the matrix column dimension N. */
00110 
00111 /*  NMATS   (input) INTEGER */
00112 /*          The number of matrix types to be tested for each combination */
00113 /*          of matrix dimensions.  If NMATS >= NTYPES (the maximum */
00114 /*          number of matrix types), then all the different types are */
00115 /*          generated for testing.  If NMATS < NTYPES, another input line */
00116 /*          is read to get the numbers of the matrix types to be used. */
00117 
00118 /*  ISEED   (input/output) INTEGER array, dimension (4) */
00119 /*          On entry, the seed of the random number generator.  The array */
00120 /*          elements should be between 0 and 4095, otherwise they will be */
00121 /*          reduced mod 4096, and ISEED(4) must be odd. */
00122 /*          On exit, the next seed in the random number sequence after */
00123 /*          all the test matrices have been generated. */
00124 
00125 /*  THRESH  (input) DOUBLE PRECISION */
00126 /*          The threshold value for the test ratios.  A result is */
00127 /*          included in the output file if RESULT >= THRESH.  To have */
00128 /*          every test ratio printed, use THRESH = 0. */
00129 
00130 /*  NMAX    (input) INTEGER */
00131 /*          The maximum value permitted for M or N, used in dimensioning */
00132 /*          the work arrays. */
00133 
00134 /*  A       (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
00135 
00136 /*  AF      (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
00137 
00138 /*  B       (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
00139 
00140 /*  BF      (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
00141 
00142 /*  U       (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
00143 
00144 /*  V       (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
00145 
00146 /*  Q       (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
00147 
00148 /*  ALPHA   (workspace) DOUBLE PRECISION array, dimension (NMAX) */
00149 
00150 /*  BETA    (workspace) DOUBLE PRECISION array, dimension (NMAX) */
00151 
00152 /*  R       (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
00153 
00154 /*  IWORK   (workspace) INTEGER array, dimension (NMAX) */
00155 
00156 /*  WORK    (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
00157 
00158 /*  RWORK   (workspace) DOUBLE PRECISION array, dimension (NMAX) */
00159 
00160 /*  NIN     (input) INTEGER */
00161 /*          The unit number for input. */
00162 
00163 /*  NOUT    (input) INTEGER */
00164 /*          The unit number for output. */
00165 
00166 /*  INFO    (output) INTEGER */
00167 /*          = 0 :  successful exit */
00168 /*          > 0 :  If ZLATMS returns an error code, the absolute value */
00169 /*                 of it is returned. */
00170 
00171 /*  ===================================================================== */
00172 
00173 /*     .. Parameters .. */
00174 /*     .. */
00175 /*     .. Local Scalars .. */
00176 /*     .. */
00177 /*     .. Local Arrays .. */
00178 /*     .. */
00179 /*     .. External Subroutines .. */
00180 /*     .. */
00181 /*     .. Intrinsic Functions .. */
00182 /*     .. */
00183 /*     .. Executable Statements .. */
00184 
00185 /*     Initialize constants and the random number seed. */
00186 
00187     /* Parameter adjustments */
00188     --rwork;
00189     --work;
00190     --iwork;
00191     --r__;
00192     --beta;
00193     --alpha;
00194     --q;
00195     --v;
00196     --u;
00197     --bf;
00198     --b;
00199     --af;
00200     --a;
00201     --iseed;
00202     --nval;
00203     --pval;
00204     --mval;
00205 
00206     /* Function Body */
00207     s_copy(path, "GSV", (ftnlen)3, (ftnlen)3);
00208     *info = 0;
00209     nrun = 0;
00210     nfail = 0;
00211     firstt = TRUE_;
00212     alareq_(path, nmats, dotype, &c__8, nin, nout);
00213     lda = *nmax;
00214     ldb = *nmax;
00215     ldu = *nmax;
00216     ldv = *nmax;
00217     ldq = *nmax;
00218     ldr = *nmax;
00219     lwork = *nmax * *nmax;
00220 
00221 /*     Do for each value of M in MVAL. */
00222 
00223     i__1 = *nm;
00224     for (im = 1; im <= i__1; ++im) {
00225         m = mval[im];
00226         p = pval[im];
00227         n = nval[im];
00228 
00229         for (imat = 1; imat <= 8; ++imat) {
00230 
00231 /*           Do the tests only if DOTYPE( IMAT ) is true. */
00232 
00233             if (! dotype[imat - 1]) {
00234                 goto L20;
00235             }
00236 
00237 /*           Set up parameters with DLATB9 and generate test */
00238 /*           matrices A and B with ZLATMS. */
00239 
00240             dlatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
00241                     anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista, 
00242                     distb);
00243 
00244 /*           Generate M by N matrix A */
00245 
00246             zlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
00247                     cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
00248                     work[1], &iinfo);
00249             if (iinfo != 0) {
00250                 io___32.ciunit = *nout;
00251                 s_wsfe(&io___32);
00252                 do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
00253                 e_wsfe();
00254                 *info = abs(iinfo);
00255                 goto L20;
00256             }
00257 
00258 /*           Generate P by N matrix B */
00259 
00260             zlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
00261                     cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
00262                     work[1], &iinfo);
00263             if (iinfo != 0) {
00264                 io___33.ciunit = *nout;
00265                 s_wsfe(&io___33);
00266                 do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
00267                 e_wsfe();
00268                 *info = abs(iinfo);
00269                 goto L20;
00270             }
00271 
00272             nt = 6;
00273 
00274             zgsvts_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &u[
00275                     1], &ldu, &v[1], &ldv, &q[1], &ldq, &alpha[1], &beta[1], &
00276                     r__[1], &ldr, &iwork[1], &work[1], &lwork, &rwork[1], 
00277                     result);
00278 
00279 /*           Print information about the tests that did not */
00280 /*           pass the threshold. */
00281 
00282             i__2 = nt;
00283             for (i__ = 1; i__ <= i__2; ++i__) {
00284                 if (result[i__ - 1] >= *thresh) {
00285                     if (nfail == 0 && firstt) {
00286                         firstt = FALSE_;
00287                         alahdg_(nout, path);
00288                     }
00289                     io___37.ciunit = *nout;
00290                     s_wsfe(&io___37);
00291                     do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
00292                     do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
00293                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00294                     do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00295                     do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
00296                     do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
00297                             doublereal));
00298                     e_wsfe();
00299                     ++nfail;
00300                 }
00301 /* L10: */
00302             }
00303             nrun += nt;
00304 
00305 L20:
00306             ;
00307         }
00308 /* L30: */
00309     }
00310 
00311 /*     Print a summary of the results. */
00312 
00313     alasum_(path, nout, &nfail, &nrun, &c__0);
00314 
00315     return 0;
00316 
00317 /*     End of ZCKGSV */
00318 
00319 } /* zckgsv_ */

swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:56:21