1 /* ./src_f77/zunm2r.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
zunm2r_(char * side,char * trans,integer * m,integer * n,integer * k,doublecomplex * a,integer * lda,doublecomplex * tau,doublecomplex * c__,integer * ldc,doublecomplex * work,integer * info,ftnlen side_len,ftnlen trans_len)12 /* Subroutine */ int zunm2r_(char *side, char *trans, integer *m, integer *n,
13 integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
14 doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info,
15 ftnlen side_len, ftnlen trans_len)
16 {
17 /* System generated locals */
18 integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
19 doublecomplex z__1;
20
21 /* Builtin functions */
22 void d_cnjg(doublecomplex *, doublecomplex *);
23
24 /* Local variables */
25 static integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
26 static doublecomplex aii;
27 static logical left;
28 static doublecomplex taui;
29 extern logical lsame_(char *, char *, ftnlen, ftnlen);
30 extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
31 doublecomplex *, integer *, doublecomplex *, doublecomplex *,
32 integer *, doublecomplex *, ftnlen), xerbla_(char *, integer *,
33 ftnlen);
34 static logical notran;
35
36
37 /* -- LAPACK routine (version 3.0) -- */
38 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
39 /* Courant Institute, Argonne National Lab, and Rice University */
40 /* September 30, 1994 */
41
42 /* .. Scalar Arguments .. */
43 /* .. */
44 /* .. Array Arguments .. */
45 /* .. */
46
47 /* Purpose */
48 /* ======= */
49
50 /* ZUNM2R overwrites the general complex m-by-n matrix C with */
51
52 /* Q * C if SIDE = 'L' and TRANS = 'N', or */
53
54 /* Q'* C if SIDE = 'L' and TRANS = 'C', or */
55
56 /* C * Q if SIDE = 'R' and TRANS = 'N', or */
57
58 /* C * Q' if SIDE = 'R' and TRANS = 'C', */
59
60 /* where Q is a complex unitary matrix defined as the product of k */
61 /* elementary reflectors */
62
63 /* Q = H(1) H(2) . . . H(k) */
64
65 /* as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n */
66 /* if SIDE = 'R'. */
67
68 /* Arguments */
69 /* ========= */
70
71 /* SIDE (input) CHARACTER*1 */
72 /* = 'L': apply Q or Q' from the Left */
73 /* = 'R': apply Q or Q' from the Right */
74
75 /* TRANS (input) CHARACTER*1 */
76 /* = 'N': apply Q (No transpose) */
77 /* = 'C': apply Q' (Conjugate transpose) */
78
79 /* M (input) INTEGER */
80 /* The number of rows of the matrix C. M >= 0. */
81
82 /* N (input) INTEGER */
83 /* The number of columns of the matrix C. N >= 0. */
84
85 /* K (input) INTEGER */
86 /* The number of elementary reflectors whose product defines */
87 /* the matrix Q. */
88 /* If SIDE = 'L', M >= K >= 0; */
89 /* if SIDE = 'R', N >= K >= 0. */
90
91 /* A (input) COMPLEX*16 array, dimension (LDA,K) */
92 /* The i-th column must contain the vector which defines the */
93 /* elementary reflector H(i), for i = 1,2,...,k, as returned by */
94 /* ZGEQRF in the first k columns of its array argument A. */
95 /* A is modified by the routine but restored on exit. */
96
97 /* LDA (input) INTEGER */
98 /* The leading dimension of the array A. */
99 /* If SIDE = 'L', LDA >= max(1,M); */
100 /* if SIDE = 'R', LDA >= max(1,N). */
101
102 /* TAU (input) COMPLEX*16 array, dimension (K) */
103 /* TAU(i) must contain the scalar factor of the elementary */
104 /* reflector H(i), as returned by ZGEQRF. */
105
106 /* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
107 /* On entry, the m-by-n matrix C. */
108 /* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
109
110 /* LDC (input) INTEGER */
111 /* The leading dimension of the array C. LDC >= max(1,M). */
112
113 /* WORK (workspace) COMPLEX*16 array, dimension */
114 /* (N) if SIDE = 'L', */
115 /* (M) if SIDE = 'R' */
116
117 /* INFO (output) INTEGER */
118 /* = 0: successful exit */
119 /* < 0: if INFO = -i, the i-th argument had an illegal value */
120
121 /* ===================================================================== */
122
123 /* .. Parameters .. */
124 /* .. */
125 /* .. Local Scalars .. */
126 /* .. */
127 /* .. External Functions .. */
128 /* .. */
129 /* .. External Subroutines .. */
130 /* .. */
131 /* .. Intrinsic Functions .. */
132 /* .. */
133 /* .. Executable Statements .. */
134
135 /* Test the input arguments */
136
137 /* Parameter adjustments */
138 a_dim1 = *lda;
139 a_offset = 1 + a_dim1;
140 a -= a_offset;
141 --tau;
142 c_dim1 = *ldc;
143 c_offset = 1 + c_dim1;
144 c__ -= c_offset;
145 --work;
146
147 /* Function Body */
148 *info = 0;
149 left = lsame_(side, "L", (ftnlen)1, (ftnlen)1);
150 notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1);
151
152 /* NQ is the order of Q */
153
154 if (left) {
155 nq = *m;
156 } else {
157 nq = *n;
158 }
159 if (! left && ! lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
160 *info = -1;
161 } else if (! notran && ! lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) {
162 *info = -2;
163 } else if (*m < 0) {
164 *info = -3;
165 } else if (*n < 0) {
166 *info = -4;
167 } else if (*k < 0 || *k > nq) {
168 *info = -5;
169 } else if (*lda < max(1,nq)) {
170 *info = -7;
171 } else if (*ldc < max(1,*m)) {
172 *info = -10;
173 }
174 if (*info != 0) {
175 i__1 = -(*info);
176 xerbla_("ZUNM2R", &i__1, (ftnlen)6);
177 return 0;
178 }
179
180 /* Quick return if possible */
181
182 if (*m == 0 || *n == 0 || *k == 0) {
183 return 0;
184 }
185
186 if (left && ! notran || ! left && notran) {
187 i1 = 1;
188 i2 = *k;
189 i3 = 1;
190 } else {
191 i1 = *k;
192 i2 = 1;
193 i3 = -1;
194 }
195
196 if (left) {
197 ni = *n;
198 jc = 1;
199 } else {
200 mi = *m;
201 ic = 1;
202 }
203
204 i__1 = i2;
205 i__2 = i3;
206 for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
207 if (left) {
208
209 /* H(i) or H(i)' is applied to C(i:m,1:n) */
210
211 mi = *m - i__ + 1;
212 ic = i__;
213 } else {
214
215 /* H(i) or H(i)' is applied to C(1:m,i:n) */
216
217 ni = *n - i__ + 1;
218 jc = i__;
219 }
220
221 /* Apply H(i) or H(i)' */
222
223 if (notran) {
224 i__3 = i__;
225 taui.r = tau[i__3].r, taui.i = tau[i__3].i;
226 } else {
227 d_cnjg(&z__1, &tau[i__]);
228 taui.r = z__1.r, taui.i = z__1.i;
229 }
230 i__3 = i__ + i__ * a_dim1;
231 aii.r = a[i__3].r, aii.i = a[i__3].i;
232 i__3 = i__ + i__ * a_dim1;
233 a[i__3].r = 1., a[i__3].i = 0.;
234 zlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &taui, &c__[ic
235 + jc * c_dim1], ldc, &work[1], (ftnlen)1);
236 i__3 = i__ + i__ * a_dim1;
237 a[i__3].r = aii.r, a[i__3].i = aii.i;
238 /* L10: */
239 }
240 return 0;
241
242 /* End of ZUNM2R */
243
244 } /* zunm2r_ */
245
246