dormr3.c
Go to the documentation of this file.
00001 /* dormr3.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 /* Subroutine */ int dormr3_(char *side, char *trans, integer *m, integer *n, 
00017         integer *k, integer *l, doublereal *a, integer *lda, doublereal *tau, 
00018         doublereal *c__, integer *ldc, doublereal *work, integer *info)
00019 {
00020     /* System generated locals */
00021     integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
00022 
00023     /* Local variables */
00024     integer i__, i1, i2, i3, ja, ic, jc, mi, ni, nq;
00025     logical left;
00026     extern logical lsame_(char *, char *);
00027     extern /* Subroutine */ int dlarz_(char *, integer *, integer *, integer *
00028 , doublereal *, integer *, doublereal *, doublereal *, integer *, 
00029             doublereal *), xerbla_(char *, integer *);
00030     logical notran;
00031 
00032 
00033 /*  -- LAPACK routine (version 3.2) -- */
00034 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00035 /*     November 2006 */
00036 
00037 /*     .. Scalar Arguments .. */
00038 /*     .. */
00039 /*     .. Array Arguments .. */
00040 /*     .. */
00041 
00042 /*  Purpose */
00043 /*  ======= */
00044 
00045 /*  DORMR3 overwrites the general real m by n matrix C with */
00046 
00047 /*        Q * C  if SIDE = 'L' and TRANS = 'N', or */
00048 
00049 /*        Q'* C  if SIDE = 'L' and TRANS = 'T', or */
00050 
00051 /*        C * Q  if SIDE = 'R' and TRANS = 'N', or */
00052 
00053 /*        C * Q' if SIDE = 'R' and TRANS = 'T', */
00054 
00055 /*  where Q is a real orthogonal matrix defined as the product of k */
00056 /*  elementary reflectors */
00057 
00058 /*        Q = H(1) H(2) . . . H(k) */
00059 
00060 /*  as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n */
00061 /*  if SIDE = 'R'. */
00062 
00063 /*  Arguments */
00064 /*  ========= */
00065 
00066 /*  SIDE    (input) CHARACTER*1 */
00067 /*          = 'L': apply Q or Q' from the Left */
00068 /*          = 'R': apply Q or Q' from the Right */
00069 
00070 /*  TRANS   (input) CHARACTER*1 */
00071 /*          = 'N': apply Q  (No transpose) */
00072 /*          = 'T': apply Q' (Transpose) */
00073 
00074 /*  M       (input) INTEGER */
00075 /*          The number of rows of the matrix C. M >= 0. */
00076 
00077 /*  N       (input) INTEGER */
00078 /*          The number of columns of the matrix C. N >= 0. */
00079 
00080 /*  K       (input) INTEGER */
00081 /*          The number of elementary reflectors whose product defines */
00082 /*          the matrix Q. */
00083 /*          If SIDE = 'L', M >= K >= 0; */
00084 /*          if SIDE = 'R', N >= K >= 0. */
00085 
00086 /*  L       (input) INTEGER */
00087 /*          The number of columns of the matrix A containing */
00088 /*          the meaningful part of the Householder reflectors. */
00089 /*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
00090 
00091 /*  A       (input) DOUBLE PRECISION array, dimension */
00092 /*                               (LDA,M) if SIDE = 'L', */
00093 /*                               (LDA,N) if SIDE = 'R' */
00094 /*          The i-th row must contain the vector which defines the */
00095 /*          elementary reflector H(i), for i = 1,2,...,k, as returned by */
00096 /*          DTZRZF in the last k rows of its array argument A. */
00097 /*          A is modified by the routine but restored on exit. */
00098 
00099 /*  LDA     (input) INTEGER */
00100 /*          The leading dimension of the array A. LDA >= max(1,K). */
00101 
00102 /*  TAU     (input) DOUBLE PRECISION array, dimension (K) */
00103 /*          TAU(i) must contain the scalar factor of the elementary */
00104 /*          reflector H(i), as returned by DTZRZF. */
00105 
00106 /*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
00107 /*          On entry, the m-by-n matrix C. */
00108 /*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
00109 
00110 /*  LDC     (input) INTEGER */
00111 /*          The leading dimension of the array C. LDC >= max(1,M). */
00112 
00113 /*  WORK    (workspace) DOUBLE PRECISION array, dimension */
00114 /*                                   (N) if SIDE = 'L', */
00115 /*                                   (M) if SIDE = 'R' */
00116 
00117 /*  INFO    (output) INTEGER */
00118 /*          = 0: successful exit */
00119 /*          < 0: if INFO = -i, the i-th argument had an illegal value */
00120 
00121 /*  Further Details */
00122 /*  =============== */
00123 
00124 /*  Based on contributions by */
00125 /*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
00126 
00127 /*  ===================================================================== */
00128 
00129 /*     .. Local Scalars .. */
00130 /*     .. */
00131 /*     .. External Functions .. */
00132 /*     .. */
00133 /*     .. External Subroutines .. */
00134 /*     .. */
00135 /*     .. Intrinsic Functions .. */
00136 /*     .. */
00137 /*     .. Executable Statements .. */
00138 
00139 /*     Test the input arguments */
00140 
00141     /* Parameter adjustments */
00142     a_dim1 = *lda;
00143     a_offset = 1 + a_dim1;
00144     a -= a_offset;
00145     --tau;
00146     c_dim1 = *ldc;
00147     c_offset = 1 + c_dim1;
00148     c__ -= c_offset;
00149     --work;
00150 
00151     /* Function Body */
00152     *info = 0;
00153     left = lsame_(side, "L");
00154     notran = lsame_(trans, "N");
00155 
00156 /*     NQ is the order of Q */
00157 
00158     if (left) {
00159         nq = *m;
00160     } else {
00161         nq = *n;
00162     }
00163     if (! left && ! lsame_(side, "R")) {
00164         *info = -1;
00165     } else if (! notran && ! lsame_(trans, "T")) {
00166         *info = -2;
00167     } else if (*m < 0) {
00168         *info = -3;
00169     } else if (*n < 0) {
00170         *info = -4;
00171     } else if (*k < 0 || *k > nq) {
00172         *info = -5;
00173     } else if (*l < 0 || left && *l > *m || ! left && *l > *n) {
00174         *info = -6;
00175     } else if (*lda < max(1,*k)) {
00176         *info = -8;
00177     } else if (*ldc < max(1,*m)) {
00178         *info = -11;
00179     }
00180     if (*info != 0) {
00181         i__1 = -(*info);
00182         xerbla_("DORMR3", &i__1);
00183         return 0;
00184     }
00185 
00186 /*     Quick return if possible */
00187 
00188     if (*m == 0 || *n == 0 || *k == 0) {
00189         return 0;
00190     }
00191 
00192     if (left && ! notran || ! left && notran) {
00193         i1 = 1;
00194         i2 = *k;
00195         i3 = 1;
00196     } else {
00197         i1 = *k;
00198         i2 = 1;
00199         i3 = -1;
00200     }
00201 
00202     if (left) {
00203         ni = *n;
00204         ja = *m - *l + 1;
00205         jc = 1;
00206     } else {
00207         mi = *m;
00208         ja = *n - *l + 1;
00209         ic = 1;
00210     }
00211 
00212     i__1 = i2;
00213     i__2 = i3;
00214     for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
00215         if (left) {
00216 
00217 /*           H(i) or H(i)' is applied to C(i:m,1:n) */
00218 
00219             mi = *m - i__ + 1;
00220             ic = i__;
00221         } else {
00222 
00223 /*           H(i) or H(i)' is applied to C(1:m,i:n) */
00224 
00225             ni = *n - i__ + 1;
00226             jc = i__;
00227         }
00228 
00229 /*        Apply H(i) or H(i)' */
00230 
00231         dlarz_(side, &mi, &ni, l, &a[i__ + ja * a_dim1], lda, &tau[i__], &c__[
00232                 ic + jc * c_dim1], ldc, &work[1]);
00233 
00234 /* L10: */
00235     }
00236 
00237     return 0;
00238 
00239 /*     End of DORMR3 */
00240 
00241 } /* dormr3_ */


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