3 /* Table of constant values */
5 static integer c__1 = 1;
6 static integer c_n1 = -1;
7 static integer c__2 = 2;
9 /* Subroutine */ int dormtr_(char *side, char *uplo, char *trans, integer *m,
10 integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *
11 c__, integer *ldc, doublereal *work, integer *lwork, integer *info)
13 /* System generated locals */
15 integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3;
18 /* Builtin functions */
19 /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
22 integer i1, i2, nb, mi, ni, nq, nw;
24 extern logical lsame_(char *, char *);
27 extern /* Subroutine */ int xerbla_(char *, integer *);
28 extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
29 integer *, integer *);
30 extern /* Subroutine */ int dormql_(char *, char *, integer *, integer *,
31 integer *, doublereal *, integer *, doublereal *, doublereal *,
32 integer *, doublereal *, integer *, integer *),
33 dormqr_(char *, char *, integer *, integer *, integer *,
34 doublereal *, integer *, doublereal *, doublereal *, integer *,
35 doublereal *, integer *, integer *);
40 /* -- LAPACK routine (version 3.1) -- */
41 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
44 /* .. Scalar Arguments .. */
46 /* .. Array Arguments .. */
52 /* DORMTR overwrites the general real M-by-N matrix C with */
54 /* SIDE = 'L' SIDE = 'R' */
55 /* TRANS = 'N': Q * C C * Q */
56 /* TRANS = 'T': Q**T * C C * Q**T */
58 /* where Q is a real orthogonal matrix of order nq, with nq = m if */
59 /* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
60 /* nq-1 elementary reflectors, as returned by DSYTRD: */
62 /* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
64 /* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
69 /* SIDE (input) CHARACTER*1 */
70 /* = 'L': apply Q or Q**T from the Left; */
71 /* = 'R': apply Q or Q**T from the Right. */
73 /* UPLO (input) CHARACTER*1 */
74 /* = 'U': Upper triangle of A contains elementary reflectors */
76 /* = 'L': Lower triangle of A contains elementary reflectors */
79 /* TRANS (input) CHARACTER*1 */
80 /* = 'N': No transpose, apply Q; */
81 /* = 'T': Transpose, apply Q**T. */
83 /* M (input) INTEGER */
84 /* The number of rows of the matrix C. M >= 0. */
86 /* N (input) INTEGER */
87 /* The number of columns of the matrix C. N >= 0. */
89 /* A (input) DOUBLE PRECISION array, dimension */
90 /* (LDA,M) if SIDE = 'L' */
91 /* (LDA,N) if SIDE = 'R' */
92 /* The vectors which define the elementary reflectors, as */
93 /* returned by DSYTRD. */
95 /* LDA (input) INTEGER */
96 /* The leading dimension of the array A. */
97 /* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
99 /* TAU (input) DOUBLE PRECISION array, dimension */
100 /* (M-1) if SIDE = 'L' */
101 /* (N-1) if SIDE = 'R' */
102 /* TAU(i) must contain the scalar factor of the elementary */
103 /* reflector H(i), as returned by DSYTRD. */
105 /* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
106 /* On entry, the M-by-N matrix C. */
107 /* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
109 /* LDC (input) INTEGER */
110 /* The leading dimension of the array C. LDC >= max(1,M). */
112 /* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
113 /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
115 /* LWORK (input) INTEGER */
116 /* The dimension of the array WORK. */
117 /* If SIDE = 'L', LWORK >= max(1,N); */
118 /* if SIDE = 'R', LWORK >= max(1,M). */
119 /* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
120 /* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
123 /* If LWORK = -1, then a workspace query is assumed; the routine */
124 /* only calculates the optimal size of the WORK array, returns */
125 /* this value as the first entry of the WORK array, and no error */
126 /* message related to LWORK is issued by XERBLA. */
128 /* INFO (output) INTEGER */
129 /* = 0: successful exit */
130 /* < 0: if INFO = -i, the i-th argument had an illegal value */
132 /* ===================================================================== */
134 /* .. Local Scalars .. */
136 /* .. External Functions .. */
138 /* .. External Subroutines .. */
140 /* .. Intrinsic Functions .. */
142 /* .. Executable Statements .. */
144 /* Test the input arguments */
146 /* Parameter adjustments */
148 a_offset = 1 + a_dim1;
152 c_offset = 1 + c_dim1;
158 left = lsame_(side, "L");
159 upper = lsame_(uplo, "U");
160 lquery = *lwork == -1;
162 /* NQ is the order of Q and NW is the minimum dimension of WORK */
171 if (! left && ! lsame_(side, "R")) {
173 } else if (! upper && ! lsame_(uplo, "L")) {
175 } else if (! lsame_(trans, "N") && ! lsame_(trans,
182 } else if (*lda < max(1,nq)) {
184 } else if (*ldc < max(1,*m)) {
186 } else if (*lwork < max(1,nw) && ! lquery) {
193 /* Writing concatenation */
194 i__1[0] = 1, a__1[0] = side;
195 i__1[1] = 1, a__1[1] = trans;
196 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
199 nb = ilaenv_(&c__1, "DORMQL", ch__1, &i__2, n, &i__3, &c_n1);
201 /* Writing concatenation */
202 i__1[0] = 1, a__1[0] = side;
203 i__1[1] = 1, a__1[1] = trans;
204 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
207 nb = ilaenv_(&c__1, "DORMQL", ch__1, m, &i__2, &i__3, &c_n1);
211 /* Writing concatenation */
212 i__1[0] = 1, a__1[0] = side;
213 i__1[1] = 1, a__1[1] = trans;
214 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
217 nb = ilaenv_(&c__1, "DORMQR", ch__1, &i__2, n, &i__3, &c_n1);
219 /* Writing concatenation */
220 i__1[0] = 1, a__1[0] = side;
221 i__1[1] = 1, a__1[1] = trans;
222 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
225 nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &i__2, &i__3, &c_n1);
228 lwkopt = max(1,nw) * nb;
229 work[1] = (doublereal) lwkopt;
234 xerbla_("DORMTR", &i__2);
240 /* Quick return if possible */
242 if (*m == 0 || *n == 0 || nq == 1) {
257 /* Q was determined by a call to DSYTRD with UPLO = 'U' */
260 dormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, &
261 tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo);
264 /* Q was determined by a call to DSYTRD with UPLO = 'L' */
274 dormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], &
275 c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
277 work[1] = (doublereal) lwkopt;