zqrt03.c
Go to the documentation of this file.
00001 /* zqrt03.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     char srnamt[32];
00020 } srnamc_;
00021 
00022 #define srnamc_1 srnamc_
00023 
00024 /* Table of constant values */
00025 
00026 static doublecomplex c_b1 = {-1e10,-1e10};
00027 static integer c__2 = 2;
00028 static doublecomplex c_b20 = {-1.,0.};
00029 static doublecomplex c_b21 = {1.,0.};
00030 
00031 /* Subroutine */ int zqrt03_(integer *m, integer *n, integer *k, 
00032         doublecomplex *af, doublecomplex *c__, doublecomplex *cc, 
00033         doublecomplex *q, integer *lda, doublecomplex *tau, doublecomplex *
00034         work, integer *lwork, doublereal *rwork, doublereal *result)
00035 {
00036     /* Initialized data */
00037 
00038     static integer iseed[4] = { 1988,1989,1990,1991 };
00039 
00040     /* System generated locals */
00041     integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1, 
00042             q_offset, i__1;
00043 
00044     /* Builtin functions */
00045     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00046 
00047     /* Local variables */
00048     integer j, mc, nc;
00049     doublereal eps;
00050     char side[1];
00051     integer info, iside;
00052     extern logical lsame_(char *, char *);
00053     doublereal resid, cnorm;
00054     extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, 
00055             integer *, doublecomplex *, doublecomplex *, integer *, 
00056             doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
00057             integer *);
00058     char trans[1];
00059     extern doublereal dlamch_(char *), zlange_(char *, integer *, 
00060             integer *, doublecomplex *, integer *, doublereal *);
00061     integer itrans;
00062     extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
00063             doublecomplex *, integer *, doublecomplex *, integer *), 
00064             zlaset_(char *, integer *, integer *, doublecomplex *, 
00065             doublecomplex *, doublecomplex *, integer *), zlarnv_(
00066             integer *, integer *, integer *, doublecomplex *), zungqr_(
00067             integer *, integer *, integer *, doublecomplex *, integer *, 
00068             doublecomplex *, doublecomplex *, integer *, integer *), zunmqr_(
00069             char *, char *, integer *, integer *, integer *, doublecomplex *, 
00070             integer *, doublecomplex *, doublecomplex *, integer *, 
00071             doublecomplex *, integer *, integer *);
00072 
00073 
00074 /*  -- LAPACK test routine (version 3.1) -- */
00075 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00076 /*     November 2006 */
00077 
00078 /*     .. Scalar Arguments .. */
00079 /*     .. */
00080 /*     .. Array Arguments .. */
00081 /*     .. */
00082 
00083 /*  Purpose */
00084 /*  ======= */
00085 
00086 /*  ZQRT03 tests ZUNMQR, which computes Q*C, Q'*C, C*Q or C*Q'. */
00087 
00088 /*  ZQRT03 compares the results of a call to ZUNMQR with the results of */
00089 /*  forming Q explicitly by a call to ZUNGQR and then performing matrix */
00090 /*  multiplication by a call to ZGEMM. */
00091 
00092 /*  Arguments */
00093 /*  ========= */
00094 
00095 /*  M       (input) INTEGER */
00096 /*          The order of the orthogonal matrix Q.  M >= 0. */
00097 
00098 /*  N       (input) INTEGER */
00099 /*          The number of rows or columns of the matrix C; C is m-by-n if */
00100 /*          Q is applied from the left, or n-by-m if Q is applied from */
00101 /*          the right.  N >= 0. */
00102 
00103 /*  K       (input) INTEGER */
00104 /*          The number of elementary reflectors whose product defines the */
00105 /*          orthogonal matrix Q.  M >= K >= 0. */
00106 
00107 /*  AF      (input) COMPLEX*16 array, dimension (LDA,N) */
00108 /*          Details of the QR factorization of an m-by-n matrix, as */
00109 /*          returnedby ZGEQRF. See CGEQRF for further details. */
00110 
00111 /*  C       (workspace) COMPLEX*16 array, dimension (LDA,N) */
00112 
00113 /*  CC      (workspace) COMPLEX*16 array, dimension (LDA,N) */
00114 
00115 /*  Q       (workspace) COMPLEX*16 array, dimension (LDA,M) */
00116 
00117 /*  LDA     (input) INTEGER */
00118 /*          The leading dimension of the arrays AF, C, CC, and Q. */
00119 
00120 /*  TAU     (input) COMPLEX*16 array, dimension (min(M,N)) */
00121 /*          The scalar factors of the elementary reflectors corresponding */
00122 /*          to the QR factorization in AF. */
00123 
00124 /*  WORK    (workspace) COMPLEX*16 array, dimension (LWORK) */
00125 
00126 /*  LWORK   (input) INTEGER */
00127 /*          The length of WORK.  LWORK must be at least M, and should be */
00128 /*          M*NB, where NB is the blocksize for this environment. */
00129 
00130 /*  RWORK   (workspace) DOUBLE PRECISION array, dimension (M) */
00131 
00132 /*  RESULT  (output) DOUBLE PRECISION array, dimension (4) */
00133 /*          The test ratios compare two techniques for multiplying a */
00134 /*          random matrix C by an m-by-m orthogonal matrix Q. */
00135 /*          RESULT(1) = norm( Q*C - Q*C )  / ( M * norm(C) * EPS ) */
00136 /*          RESULT(2) = norm( C*Q - C*Q )  / ( M * norm(C) * EPS ) */
00137 /*          RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) */
00138 /*          RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) */
00139 
00140 /*  ===================================================================== */
00141 
00142 /*     .. Parameters .. */
00143 /*     .. */
00144 /*     .. Local Scalars .. */
00145 /*     .. */
00146 /*     .. External Functions .. */
00147 /*     .. */
00148 /*     .. External Subroutines .. */
00149 /*     .. */
00150 /*     .. Local Arrays .. */
00151 /*     .. */
00152 /*     .. Intrinsic Functions .. */
00153 /*     .. */
00154 /*     .. Scalars in Common .. */
00155 /*     .. */
00156 /*     .. Common blocks .. */
00157 /*     .. */
00158 /*     .. Data statements .. */
00159     /* Parameter adjustments */
00160     q_dim1 = *lda;
00161     q_offset = 1 + q_dim1;
00162     q -= q_offset;
00163     cc_dim1 = *lda;
00164     cc_offset = 1 + cc_dim1;
00165     cc -= cc_offset;
00166     c_dim1 = *lda;
00167     c_offset = 1 + c_dim1;
00168     c__ -= c_offset;
00169     af_dim1 = *lda;
00170     af_offset = 1 + af_dim1;
00171     af -= af_offset;
00172     --tau;
00173     --work;
00174     --rwork;
00175     --result;
00176 
00177     /* Function Body */
00178 /*     .. */
00179 /*     .. Executable Statements .. */
00180 
00181     eps = dlamch_("Epsilon");
00182 
00183 /*     Copy the first k columns of the factorization to the array Q */
00184 
00185     zlaset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
00186     i__1 = *m - 1;
00187     zlacpy_("Lower", &i__1, k, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
00188 
00189 /*     Generate the m-by-m matrix Q */
00190 
00191     s_copy(srnamc_1.srnamt, "ZUNGQR", (ftnlen)32, (ftnlen)6);
00192     zungqr_(m, m, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
00193 
00194     for (iside = 1; iside <= 2; ++iside) {
00195         if (iside == 1) {
00196             *(unsigned char *)side = 'L';
00197             mc = *m;
00198             nc = *n;
00199         } else {
00200             *(unsigned char *)side = 'R';
00201             mc = *n;
00202             nc = *m;
00203         }
00204 
00205 /*        Generate MC by NC matrix C */
00206 
00207         i__1 = nc;
00208         for (j = 1; j <= i__1; ++j) {
00209             zlarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
00210 /* L10: */
00211         }
00212         cnorm = zlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
00213         if (cnorm == 0.) {
00214             cnorm = 1.;
00215         }
00216 
00217         for (itrans = 1; itrans <= 2; ++itrans) {
00218             if (itrans == 1) {
00219                 *(unsigned char *)trans = 'N';
00220             } else {
00221                 *(unsigned char *)trans = 'C';
00222             }
00223 
00224 /*           Copy C */
00225 
00226             zlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset], 
00227                     lda);
00228 
00229 /*           Apply Q or Q' to C */
00230 
00231             s_copy(srnamc_1.srnamt, "ZUNMQR", (ftnlen)32, (ftnlen)6);
00232             zunmqr_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
00233                     cc[cc_offset], lda, &work[1], lwork, &info);
00234 
00235 /*           Form explicit product and subtract */
00236 
00237             if (lsame_(side, "L")) {
00238                 zgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b20, &q[
00239                         q_offset], lda, &c__[c_offset], lda, &c_b21, &cc[
00240                         cc_offset], lda);
00241             } else {
00242                 zgemm_("No transpose", trans, &mc, &nc, &nc, &c_b20, &c__[
00243                         c_offset], lda, &q[q_offset], lda, &c_b21, &cc[
00244                         cc_offset], lda);
00245             }
00246 
00247 /*           Compute error in the difference */
00248 
00249             resid = zlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
00250             result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,*
00251                     m) * cnorm * eps);
00252 
00253 /* L20: */
00254         }
00255 /* L30: */
00256     }
00257 
00258     return 0;
00259 
00260 /*     End of ZQRT03 */
00261 
00262 } /* zqrt03_ */


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