1 /* ./src_f77/sormtr.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
sormtr_(char * side,char * uplo,char * trans,integer * m,integer * n,real * a,integer * lda,real * tau,real * c__,integer * ldc,real * work,integer * lwork,integer * info,ftnlen side_len,ftnlen uplo_len,ftnlen trans_len)14 /* Subroutine */ int sormtr_(char *side, char *uplo, char *trans, integer *m,
15 integer *n, real *a, integer *lda, real *tau, real *c__, integer *ldc,
16 real *work, integer *lwork, integer *info, ftnlen side_len, ftnlen
17 uplo_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, i__3;
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, ni, nq, nw;
29 static logical left;
30 extern logical lsame_(char *, char *, ftnlen, ftnlen);
31 static integer iinfo;
32 static logical upper;
33 extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
34 extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
35 integer *, integer *, ftnlen, ftnlen);
36 extern /* Subroutine */ int sormql_(char *, char *, integer *, integer *,
37 integer *, real *, integer *, real *, real *, integer *, real *,
38 integer *, integer *, ftnlen, ftnlen);
39 static integer lwkopt;
40 static logical lquery;
41 extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
42 integer *, real *, integer *, real *, real *, integer *, real *,
43 integer *, integer *, ftnlen, ftnlen);
44
45
46 /* -- LAPACK routine (version 3.0) -- */
47 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
48 /* Courant Institute, Argonne National Lab, and Rice University */
49 /* June 30, 1999 */
50
51 /* .. Scalar Arguments .. */
52 /* .. */
53 /* .. Array Arguments .. */
54 /* .. */
55
56 /* Purpose */
57 /* ======= */
58
59 /* SORMTR overwrites the general real M-by-N matrix C with */
60
61 /* SIDE = 'L' SIDE = 'R' */
62 /* TRANS = 'N': Q * C C * Q */
63 /* TRANS = 'T': Q**T * C C * Q**T */
64
65 /* where Q is a real orthogonal matrix of order nq, with nq = m if */
66 /* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
67 /* nq-1 elementary reflectors, as returned by SSYTRD: */
68
69 /* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
70
71 /* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
72
73 /* Arguments */
74 /* ========= */
75
76 /* SIDE (input) CHARACTER*1 */
77 /* = 'L': apply Q or Q**T from the Left; */
78 /* = 'R': apply Q or Q**T from the Right. */
79
80 /* UPLO (input) CHARACTER*1 */
81 /* = 'U': Upper triangle of A contains elementary reflectors */
82 /* from SSYTRD; */
83 /* = 'L': Lower triangle of A contains elementary reflectors */
84 /* from SSYTRD. */
85
86 /* TRANS (input) CHARACTER*1 */
87 /* = 'N': No transpose, apply Q; */
88 /* = 'T': Transpose, apply Q**T. */
89
90 /* M (input) INTEGER */
91 /* The number of rows of the matrix C. M >= 0. */
92
93 /* N (input) INTEGER */
94 /* The number of columns of the matrix C. N >= 0. */
95
96 /* A (input) REAL array, dimension */
97 /* (LDA,M) if SIDE = 'L' */
98 /* (LDA,N) if SIDE = 'R' */
99 /* The vectors which define the elementary reflectors, as */
100 /* returned by SSYTRD. */
101
102 /* LDA (input) INTEGER */
103 /* The leading dimension of the array A. */
104 /* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
105
106 /* TAU (input) REAL array, dimension */
107 /* (M-1) if SIDE = 'L' */
108 /* (N-1) if SIDE = 'R' */
109 /* TAU(i) must contain the scalar factor of the elementary */
110 /* reflector H(i), as returned by SSYTRD. */
111
112 /* C (input/output) REAL array, dimension (LDC,N) */
113 /* On entry, the M-by-N matrix C. */
114 /* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
115
116 /* LDC (input) INTEGER */
117 /* The leading dimension of the array C. LDC >= max(1,M). */
118
119 /* WORK (workspace/output) REAL array, dimension (LWORK) */
120 /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
121
122 /* LWORK (input) INTEGER */
123 /* The dimension of the array WORK. */
124 /* If SIDE = 'L', LWORK >= max(1,N); */
125 /* if SIDE = 'R', LWORK >= max(1,M). */
126 /* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
127 /* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
128 /* blocksize. */
129
130 /* If LWORK = -1, then a workspace query is assumed; the routine */
131 /* only calculates the optimal size of the WORK array, returns */
132 /* this value as the first entry of the WORK array, and no error */
133 /* message related to LWORK is issued by XERBLA. */
134
135 /* INFO (output) INTEGER */
136 /* = 0: successful exit */
137 /* < 0: if INFO = -i, the i-th argument had an illegal value */
138
139 /* ===================================================================== */
140
141 /* .. Local Scalars .. */
142 /* .. */
143 /* .. External Functions .. */
144 /* .. */
145 /* .. External Subroutines .. */
146 /* .. */
147 /* .. Intrinsic Functions .. */
148 /* .. */
149 /* .. Executable Statements .. */
150
151 /* Test the input arguments */
152
153 /* Parameter adjustments */
154 a_dim1 = *lda;
155 a_offset = 1 + a_dim1;
156 a -= a_offset;
157 --tau;
158 c_dim1 = *ldc;
159 c_offset = 1 + c_dim1;
160 c__ -= c_offset;
161 --work;
162
163 /* Function Body */
164 *info = 0;
165 left = lsame_(side, "L", (ftnlen)1, (ftnlen)1);
166 upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
167 lquery = *lwork == -1;
168
169 /* NQ is the order of Q and NW is the minimum dimension of WORK */
170
171 if (left) {
172 nq = *m;
173 nw = *n;
174 } else {
175 nq = *n;
176 nw = *m;
177 }
178 if (! left && ! lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
179 *info = -1;
180 } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
181 *info = -2;
182 } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
183 "T", (ftnlen)1, (ftnlen)1)) {
184 *info = -3;
185 } else if (*m < 0) {
186 *info = -4;
187 } else if (*n < 0) {
188 *info = -5;
189 } else if (*lda < max(1,nq)) {
190 *info = -7;
191 } else if (*ldc < max(1,*m)) {
192 *info = -10;
193 } else if (*lwork < max(1,nw) && ! lquery) {
194 *info = -12;
195 }
196
197 if (*info == 0) {
198 if (upper) {
199 if (left) {
200 /* Writing concatenation */
201 i__1[0] = 1, a__1[0] = side;
202 i__1[1] = 1, a__1[1] = trans;
203 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
204 i__2 = *m - 1;
205 i__3 = *m - 1;
206 nb = ilaenv_(&c__1, "SORMQL", ch__1, &i__2, n, &i__3, &c_n1, (
207 ftnlen)6, (ftnlen)2);
208 } else {
209 /* Writing concatenation */
210 i__1[0] = 1, a__1[0] = side;
211 i__1[1] = 1, a__1[1] = trans;
212 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
213 i__2 = *n - 1;
214 i__3 = *n - 1;
215 nb = ilaenv_(&c__1, "SORMQL", ch__1, m, &i__2, &i__3, &c_n1, (
216 ftnlen)6, (ftnlen)2);
217 }
218 } else {
219 if (left) {
220 /* Writing concatenation */
221 i__1[0] = 1, a__1[0] = side;
222 i__1[1] = 1, a__1[1] = trans;
223 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
224 i__2 = *m - 1;
225 i__3 = *m - 1;
226 nb = ilaenv_(&c__1, "SORMQR", ch__1, &i__2, n, &i__3, &c_n1, (
227 ftnlen)6, (ftnlen)2);
228 } else {
229 /* Writing concatenation */
230 i__1[0] = 1, a__1[0] = side;
231 i__1[1] = 1, a__1[1] = trans;
232 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
233 i__2 = *n - 1;
234 i__3 = *n - 1;
235 nb = ilaenv_(&c__1, "SORMQR", ch__1, m, &i__2, &i__3, &c_n1, (
236 ftnlen)6, (ftnlen)2);
237 }
238 }
239 lwkopt = max(1,nw) * nb;
240 work[1] = (real) lwkopt;
241 }
242
243 if (*info != 0) {
244 i__2 = -(*info);
245 xerbla_("SORMTR", &i__2, (ftnlen)6);
246 return 0;
247 } else if (lquery) {
248 return 0;
249 }
250
251 /* Quick return if possible */
252
253 if (*m == 0 || *n == 0 || nq == 1) {
254 work[1] = 1.f;
255 return 0;
256 }
257
258 if (left) {
259 mi = *m - 1;
260 ni = *n;
261 } else {
262 mi = *m;
263 ni = *n - 1;
264 }
265
266 if (upper) {
267
268 /* Q was determined by a call to SSYTRD with UPLO = 'U' */
269
270 i__2 = nq - 1;
271 sormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, &
272 tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)
273 1, (ftnlen)1);
274 } else {
275
276 /* Q was determined by a call to SSYTRD with UPLO = 'L' */
277
278 if (left) {
279 i1 = 2;
280 i2 = 1;
281 } else {
282 i1 = 1;
283 i2 = 2;
284 }
285 i__2 = nq - 1;
286 sormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], &
287 c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (ftnlen)
288 1, (ftnlen)1);
289 }
290 work[1] = (real) lwkopt;
291 return 0;
292
293 /* End of SORMTR */
294
295 } /* sormtr_ */
296
297