libflame revision_anchor
Functions
cungtr.c File Reference

(r)

Functions

int cungtr_fla (char *uplo, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info)
 

Function Documentation

◆ cungtr_fla()

int cungtr_fla ( char uplo,
integer n,
complex a,
integer lda,
complex tau,
complex work,
integer lwork,
integer info 
)
118{
119 /* System generated locals */
121 /* Local variables */
122 integer i__, j, nb;
123 extern logical lsame_(char *, char *);
126 extern /* Subroutine */
127 int xerbla_(char *, integer *);
128 extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
129 extern /* Subroutine */
133 /* -- LAPACK computational routine (version 3.4.0) -- */
134 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
135 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
136 /* November 2011 */
137 /* .. Scalar Arguments .. */
138 /* .. */
139 /* .. Array Arguments .. */
140 /* .. */
141 /* ===================================================================== */
142 /* .. Parameters .. */
143 /* .. */
144 /* .. Local Scalars .. */
145 /* .. */
146 /* .. External Functions .. */
147 /* .. */
148 /* .. External Subroutines .. */
149 /* .. */
150 /* .. Intrinsic Functions .. */
151 /* .. */
152 /* .. Executable Statements .. */
153 /* Test the input arguments */
154 /* Parameter adjustments */
155 a_dim1 = *lda;
156 a_offset = 1 + a_dim1;
157 a -= a_offset;
158 --tau;
159 --work;
160 /* Function Body */
161 *info = 0;
162 lquery = *lwork == -1;
163 upper = lsame_(uplo, "U");
164 if (! upper && ! lsame_(uplo, "L"))
165 {
166 *info = -1;
167 }
168 else if (*n < 0)
169 {
170 *info = -2;
171 }
172 else if (*lda < max(1,*n))
173 {
174 *info = -4;
175 }
176 else /* if(complicated condition) */
177 {
178 /* Computing MAX */
179 i__1 = 1;
180 i__2 = *n - 1; // , expr subst
181 if (*lwork < max(i__1,i__2) && ! lquery)
182 {
183 *info = -7;
184 }
185 }
186 if (*info == 0)
187 {
188 if (upper)
189 {
190 i__1 = *n - 1;
191 i__2 = *n - 1;
192 i__3 = *n - 1;
193 nb = ilaenv_(&c__1, "CUNGQL", " ", &i__1, &i__2, &i__3, &c_n1);
194 }
195 else
196 {
197 i__1 = *n - 1;
198 i__2 = *n - 1;
199 i__3 = *n - 1;
200 nb = ilaenv_(&c__1, "CUNGQR", " ", &i__1, &i__2, &i__3, &c_n1);
201 }
202 /* Computing MAX */
203 i__1 = 1;
204 i__2 = *n - 1; // , expr subst
205 lwkopt = max(i__1,i__2) * nb;
206 work[1].r = (real) lwkopt;
207 work[1].i = 0.f; // , expr subst
208 }
209 if (*info != 0)
210 {
211 i__1 = -(*info);
212 xerbla_("CUNGTR", &i__1);
213 return 0;
214 }
215 else if (lquery)
216 {
217 return 0;
218 }
219 /* Quick return if possible */
220 if (*n == 0)
221 {
222 work[1].r = 1.f;
223 work[1].i = 0.f; // , expr subst
224 return 0;
225 }
226 if (upper)
227 {
228 /* Q was determined by a call to CHETRD with UPLO = 'U' */
229 /* Shift the vectors which define the elementary reflectors one */
230 /* column to the left, and set the last row and column of Q to */
231 /* those of the unit matrix */
232 i__1 = *n - 1;
233 for (j = 1;
234 j <= i__1;
235 ++j)
236 {
237 i__2 = j - 1;
238 for (i__ = 1;
239 i__ <= i__2;
240 ++i__)
241 {
242 i__3 = i__ + j * a_dim1;
243 i__4 = i__ + (j + 1) * a_dim1;
244 a[i__3].r = a[i__4].r;
245 a[i__3].i = a[i__4].i; // , expr subst
246 /* L10: */
247 }
248 i__2 = *n + j * a_dim1;
249 a[i__2].r = 0.f;
250 a[i__2].i = 0.f; // , expr subst
251 /* L20: */
252 }
253 i__1 = *n - 1;
254 for (i__ = 1;
255 i__ <= i__1;
256 ++i__)
257 {
258 i__2 = i__ + *n * a_dim1;
259 a[i__2].r = 0.f;
260 a[i__2].i = 0.f; // , expr subst
261 /* L30: */
262 }
263 i__1 = *n + *n * a_dim1;
264 a[i__1].r = 1.f;
265 a[i__1].i = 0.f; // , expr subst
266 /* Generate Q(1:n-1,1:n-1) */
267 i__1 = *n - 1;
268 i__2 = *n - 1;
269 i__3 = *n - 1;
270 cungql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], lwork, &iinfo);
271 }
272 else
273 {
274 /* Q was determined by a call to CHETRD with UPLO = 'L'. */
275 /* Shift the vectors which define the elementary reflectors one */
276 /* column to the right, and set the first row and column of Q to */
277 /* those of the unit matrix */
278 for (j = *n;
279 j >= 2;
280 --j)
281 {
282 i__1 = j * a_dim1 + 1;
283 a[i__1].r = 0.f;
284 a[i__1].i = 0.f; // , expr subst
285 i__1 = *n;
286 for (i__ = j + 1;
287 i__ <= i__1;
288 ++i__)
289 {
290 i__2 = i__ + j * a_dim1;
291 i__3 = i__ + (j - 1) * a_dim1;
292 a[i__2].r = a[i__3].r;
293 a[i__2].i = a[i__3].i; // , expr subst
294 /* L40: */
295 }
296 /* L50: */
297 }
298 i__1 = a_dim1 + 1;
299 a[i__1].r = 1.f;
300 a[i__1].i = 0.f; // , expr subst
301 i__1 = *n;
302 for (i__ = 2;
303 i__ <= i__1;
304 ++i__)
305 {
306 i__2 = i__ + a_dim1;
307 a[i__2].r = 0.f;
308 a[i__2].i = 0.f; // , expr subst
309 /* L60: */
310 }
311 if (*n > 1)
312 {
313 /* Generate Q(2:n,2:n) */
314 i__1 = *n - 1;
315 i__2 = *n - 1;
316 i__3 = *n - 1;
317 cungqr_fla(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], &work[1], lwork, &iinfo);
318 }
319 }
320 work[1].r = (real) lwkopt;
321 work[1].i = 0.f; // , expr subst
322 return 0;
323 /* End of CUNGTR */
324}
int integer
Definition FLA_f2c.h:25
int logical
Definition FLA_f2c.h:36
float real
Definition FLA_f2c.h:30
int i
Definition bl1_axmyv2.c:145
int cungqr_fla(integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info)
Definition cungqr.c:123
Definition FLA_f2c.h:32

References cungqr_fla(), and i.