1 /* ./src_f77/dormhr.f -- translated by f2c (version 20030320).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include <punc/vf2c.h>
7
8 /* Table of constant values */
9
10 static integer c__1 = 1;
11 static integer c_n1 = -1;
12 static integer c__2 = 2;
13
dormhr_(char * side,char * trans,integer * m,integer * n,integer * ilo,integer * ihi,doublereal * a,integer * lda,doublereal * tau,doublereal * c__,integer * ldc,doublereal * work,integer * lwork,integer * info,ftnlen side_len,ftnlen trans_len)14 /* Subroutine */ int dormhr_(char *side, char *trans, integer *m, integer *n,
15 integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *
16 tau, doublereal *c__, integer *ldc, doublereal *work, integer *lwork,
17 integer *info, ftnlen side_len, ftnlen trans_len)
18 {
19 /* System generated locals */
20 address a__1[2];
21 integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2;
22 char ch__1[2];
23
24 /* Builtin functions */
25 /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
26
27 /* Local variables */
28 static integer i1, i2, nb, mi, nh, ni, nq, nw;
29 static logical left;
30 extern logical lsame_(char *, char *, ftnlen, ftnlen);
31 static integer iinfo;
32 extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
33 extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
34 integer *, integer *, ftnlen, ftnlen);
35 extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
36 integer *, doublereal *, integer *, doublereal *, doublereal *,
37 integer *, doublereal *, integer *, integer *, ftnlen, ftnlen);
38 static integer lwkopt;
39 static logical lquery;
40
41
42 /* -- LAPACK routine (version 3.0) -- */
43 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
44 /* Courant Institute, Argonne National Lab, and Rice University */
45 /* June 30, 1999 */
46
47 /* .. Scalar Arguments .. */
48 /* .. */
49 /* .. Array Arguments .. */
50 /* .. */
51
52 /* Purpose */
53 /* ======= */
54
55 /* DORMHR overwrites the general real M-by-N matrix C with */
56
57 /* SIDE = 'L' SIDE = 'R' */
58 /* TRANS = 'N': Q * C C * Q */
59 /* TRANS = 'T': Q**T * C C * Q**T */
60
61 /* where Q is a real orthogonal matrix of order nq, with nq = m if */
62 /* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
63 /* IHI-ILO elementary reflectors, as returned by DGEHRD: */
64
65 /* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
66
67 /* Arguments */
68 /* ========= */
69
70 /* SIDE (input) CHARACTER*1 */
71 /* = 'L': apply Q or Q**T from the Left; */
72 /* = 'R': apply Q or Q**T from the Right. */
73
74 /* TRANS (input) CHARACTER*1 */
75 /* = 'N': No transpose, apply Q; */
76 /* = 'T': Transpose, apply Q**T. */
77
78 /* M (input) INTEGER */
79 /* The number of rows of the matrix C. M >= 0. */
80
81 /* N (input) INTEGER */
82 /* The number of columns of the matrix C. N >= 0. */
83
84 /* ILO (input) INTEGER */
85 /* IHI (input) INTEGER */
86 /* ILO and IHI must have the same values as in the previous call */
87 /* of DGEHRD. Q is equal to the unit matrix except in the */
88 /* submatrix Q(ilo+1:ihi,ilo+1:ihi). */
89 /* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and */
90 /* ILO = 1 and IHI = 0, if M = 0; */
91 /* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and */
92 /* ILO = 1 and IHI = 0, if N = 0. */
93
94 /* A (input) DOUBLE PRECISION array, dimension */
95 /* (LDA,M) if SIDE = 'L' */
96 /* (LDA,N) if SIDE = 'R' */
97 /* The vectors which define the elementary reflectors, as */
98 /* returned by DGEHRD. */
99
100 /* LDA (input) INTEGER */
101 /* The leading dimension of the array A. */
102 /* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
103
104 /* TAU (input) DOUBLE PRECISION array, dimension */
105 /* (M-1) if SIDE = 'L' */
106 /* (N-1) if SIDE = 'R' */
107 /* TAU(i) must contain the scalar factor of the elementary */
108 /* reflector H(i), as returned by DGEHRD. */
109
110 /* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
111 /* On entry, the M-by-N matrix C. */
112 /* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
113
114 /* LDC (input) INTEGER */
115 /* The leading dimension of the array C. LDC >= max(1,M). */
116
117 /* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
118 /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
119
120 /* LWORK (input) INTEGER */
121 /* The dimension of the array WORK. */
122 /* If SIDE = 'L', LWORK >= max(1,N); */
123 /* if SIDE = 'R', LWORK >= max(1,M). */
124 /* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
125 /* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
126 /* blocksize. */
127
128 /* If LWORK = -1, then a workspace query is assumed; the routine */
129 /* only calculates the optimal size of the WORK array, returns */
130 /* this value as the first entry of the WORK array, and no error */
131 /* message related to LWORK is issued by XERBLA. */
132
133 /* INFO (output) INTEGER */
134 /* = 0: successful exit */
135 /* < 0: if INFO = -i, the i-th argument had an illegal value */
136
137 /* ===================================================================== */
138
139 /* .. Local Scalars .. */
140 /* .. */
141 /* .. External Functions .. */
142 /* .. */
143 /* .. External Subroutines .. */
144 /* .. */
145 /* .. Intrinsic Functions .. */
146 /* .. */
147 /* .. Executable Statements .. */
148
149 /* Test the input arguments */
150
151 /* Parameter adjustments */
152 a_dim1 = *lda;
153 a_offset = 1 + a_dim1;
154 a -= a_offset;
155 --tau;
156 c_dim1 = *ldc;
157 c_offset = 1 + c_dim1;
158 c__ -= c_offset;
159 --work;
160
161 /* Function Body */
162 *info = 0;
163 nh = *ihi - *ilo;
164 left = lsame_(side, "L", (ftnlen)1, (ftnlen)1);
165 lquery = *lwork == -1;
166
167 /* NQ is the order of Q and NW is the minimum dimension of WORK */
168
169 if (left) {
170 nq = *m;
171 nw = *n;
172 } else {
173 nq = *n;
174 nw = *m;
175 }
176 if (! left && ! lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
177 *info = -1;
178 } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
179 "T", (ftnlen)1, (ftnlen)1)) {
180 *info = -2;
181 } else if (*m < 0) {
182 *info = -3;
183 } else if (*n < 0) {
184 *info = -4;
185 } else if (*ilo < 1 || *ilo > max(1,nq)) {
186 *info = -5;
187 } else if (*ihi < min(*ilo,nq) || *ihi > nq) {
188 *info = -6;
189 } else if (*lda < max(1,nq)) {
190 *info = -8;
191 } else if (*ldc < max(1,*m)) {
192 *info = -11;
193 } else if (*lwork < max(1,nw) && ! lquery) {
194 *info = -13;
195 }
196
197 if (*info == 0) {
198 if (left) {
199 /* Writing concatenation */
200 i__1[0] = 1, a__1[0] = side;
201 i__1[1] = 1, a__1[1] = trans;
202 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
203 nb = ilaenv_(&c__1, "DORMQR", ch__1, &nh, n, &nh, &c_n1, (ftnlen)
204 6, (ftnlen)2);
205 } else {
206 /* Writing concatenation */
207 i__1[0] = 1, a__1[0] = side;
208 i__1[1] = 1, a__1[1] = trans;
209 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
210 nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &nh, &nh, &c_n1, (ftnlen)
211 6, (ftnlen)2);
212 }
213 lwkopt = max(1,nw) * nb;
214 work[1] = (doublereal) lwkopt;
215 }
216
217 if (*info != 0) {
218 i__2 = -(*info);
219 xerbla_("DORMHR", &i__2, (ftnlen)6);
220 return 0;
221 } else if (lquery) {
222 return 0;
223 }
224
225 /* Quick return if possible */
226
227 if (*m == 0 || *n == 0 || nh == 0) {
228 work[1] = 1.;
229 return 0;
230 }
231
232 if (left) {
233 mi = nh;
234 ni = *n;
235 i1 = *ilo + 1;
236 i2 = 1;
237 } else {
238 mi = *m;
239 ni = nh;
240 i1 = 1;
241 i2 = *ilo + 1;
242 }
243
244 dormqr_(side, trans, &mi, &ni, &nh, &a[*ilo + 1 + *ilo * a_dim1], lda, &
245 tau[*ilo], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (
246 ftnlen)1, (ftnlen)1);
247
248 work[1] = (doublereal) lwkopt;
249 return 0;
250
251 /* End of DORMHR */
252
253 } /* dormhr_ */
254
255