3 /* Table of constant values */
5 static integer c__1 = 1;
7 /* Subroutine */ int dorm2l_(char *side, char *trans, integer *m, integer *n,
8 integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
9 c__, integer *ldc, doublereal *work, integer *info)
11 /* System generated locals */
12 integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
15 integer i__, i1, i2, i3, mi, ni, nq;
18 extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
19 doublereal *, integer *, doublereal *, doublereal *, integer *,
21 extern logical lsame_(char *, char *);
22 extern /* Subroutine */ int xerbla_(char *, integer *);
26 /* -- LAPACK routine (version 3.1) -- */
27 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
30 /* .. Scalar Arguments .. */
32 /* .. Array Arguments .. */
38 /* DORM2L overwrites the general real m by n matrix C with */
40 /* Q * C if SIDE = 'L' and TRANS = 'N', or */
42 /* Q'* C if SIDE = 'L' and TRANS = 'T', or */
44 /* C * Q if SIDE = 'R' and TRANS = 'N', or */
46 /* C * Q' if SIDE = 'R' and TRANS = 'T', */
48 /* where Q is a real orthogonal matrix defined as the product of k */
49 /* elementary reflectors */
51 /* Q = H(k) . . . H(2) H(1) */
53 /* as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n */
59 /* SIDE (input) CHARACTER*1 */
60 /* = 'L': apply Q or Q' from the Left */
61 /* = 'R': apply Q or Q' from the Right */
63 /* TRANS (input) CHARACTER*1 */
64 /* = 'N': apply Q (No transpose) */
65 /* = 'T': apply Q' (Transpose) */
67 /* M (input) INTEGER */
68 /* The number of rows of the matrix C. M >= 0. */
70 /* N (input) INTEGER */
71 /* The number of columns of the matrix C. N >= 0. */
73 /* K (input) INTEGER */
74 /* The number of elementary reflectors whose product defines */
76 /* If SIDE = 'L', M >= K >= 0; */
77 /* if SIDE = 'R', N >= K >= 0. */
79 /* A (input) DOUBLE PRECISION array, dimension (LDA,K) */
80 /* The i-th column must contain the vector which defines the */
81 /* elementary reflector H(i), for i = 1,2,...,k, as returned by */
82 /* DGEQLF in the last k columns of its array argument A. */
83 /* A is modified by the routine but restored on exit. */
85 /* LDA (input) INTEGER */
86 /* The leading dimension of the array A. */
87 /* If SIDE = 'L', LDA >= max(1,M); */
88 /* if SIDE = 'R', LDA >= max(1,N). */
90 /* TAU (input) DOUBLE PRECISION array, dimension (K) */
91 /* TAU(i) must contain the scalar factor of the elementary */
92 /* reflector H(i), as returned by DGEQLF. */
94 /* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
95 /* On entry, the m by n matrix C. */
96 /* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
98 /* LDC (input) INTEGER */
99 /* The leading dimension of the array C. LDC >= max(1,M). */
101 /* WORK (workspace) DOUBLE PRECISION array, dimension */
102 /* (N) if SIDE = 'L', */
103 /* (M) if SIDE = 'R' */
105 /* INFO (output) INTEGER */
106 /* = 0: successful exit */
107 /* < 0: if INFO = -i, the i-th argument had an illegal value */
109 /* ===================================================================== */
111 /* .. Parameters .. */
113 /* .. Local Scalars .. */
115 /* .. External Functions .. */
117 /* .. External Subroutines .. */
119 /* .. Intrinsic Functions .. */
121 /* .. Executable Statements .. */
123 /* Test the input arguments */
125 /* Parameter adjustments */
127 a_offset = 1 + a_dim1;
131 c_offset = 1 + c_dim1;
137 left = lsame_(side, "L");
138 notran = lsame_(trans, "N");
140 /* NQ is the order of Q */
147 if (! left && ! lsame_(side, "R")) {
149 } else if (! notran && ! lsame_(trans, "T")) {
155 } else if (*k < 0 || *k > nq) {
157 } else if (*lda < max(1,nq)) {
159 } else if (*ldc < max(1,*m)) {
164 xerbla_("DORM2L", &i__1);
168 /* Quick return if possible */
170 if (*m == 0 || *n == 0 || *k == 0) {
174 if (left && notran || ! left && ! notran) {
192 for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
195 /* H(i) is applied to C(1:m-k+i,1:n) */
200 /* H(i) is applied to C(1:m,1:n-k+i) */
207 aii = a[nq - *k + i__ + i__ * a_dim1];
208 a[nq - *k + i__ + i__ * a_dim1] = 1.;
209 dlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[
210 c_offset], ldc, &work[1]);
211 a[nq - *k + i__ + i__ * a_dim1] = aii;