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 */
120  integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
121  /* Local variables */
122  integer i__, j, nb;
123  extern logical lsame_(char *, char *);
124  integer iinfo;
125  logical upper;
126  extern /* Subroutine */
127  int xerbla_(char *, integer *);
128  extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
129  extern /* Subroutine */
130  int cungql_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *), cungqr_fla(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *);
131  integer lwkopt;
132  logical lquery;
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 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
real r
Definition: FLA_f2c.h:32
real i
Definition: FLA_f2c.h:32

References cungqr_fla().