libflame  revision_anchor
Functions
cungqr.c File Reference

(r)

Functions

int cungqr_fla (integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info)
 

Function Documentation

◆ cungqr_fla()

int cungqr_fla ( integer m,
integer n,
integer k,
complex a,
integer lda,
complex tau,
complex work,
integer lwork,
integer info 
)
124 {
125  /* System generated locals */
126  integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
127  /* Local variables */
128  integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
129  extern /* Subroutine */
130  int cung2r_fla(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *), clarfb_( char *, char *, char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *), clarft_( char *, char *, integer *, integer *, complex *, integer *, complex *, complex *, integer *), xerbla_(char *, integer *);
131  extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
132  integer ldwork, lwkopt;
133  logical lquery;
134  /* -- LAPACK computational routine (version 3.4.0) -- */
135  /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
136  /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
137  /* November 2011 */
138  /* .. Scalar Arguments .. */
139  /* .. */
140  /* .. Array Arguments .. */
141  /* .. */
142  /* ===================================================================== */
143  /* .. Parameters .. */
144  /* .. */
145  /* .. Local Scalars .. */
146  /* .. */
147  /* .. External Subroutines .. */
148  /* .. */
149  /* .. Intrinsic Functions .. */
150  /* .. */
151  /* .. External Functions .. */
152  /* .. */
153  /* .. Executable Statements .. */
154  /* Test the input arguments */
155  /* Parameter adjustments */
156  a_dim1 = *lda;
157  a_offset = 1 + a_dim1;
158  a -= a_offset;
159  --tau;
160  --work;
161  /* Function Body */
162  *info = 0;
163  nb = ilaenv_(&c__1, "CUNGQR", " ", m, n, k, &c_n1);
164  lwkopt = max(1,*n) * nb;
165  work[1].r = (real) lwkopt;
166  work[1].i = 0.f; // , expr subst
167  lquery = *lwork == -1;
168  if (*m < 0)
169  {
170  *info = -1;
171  }
172  else if (*n < 0 || *n > *m)
173  {
174  *info = -2;
175  }
176  else if (*k < 0 || *k > *n)
177  {
178  *info = -3;
179  }
180  else if (*lda < max(1,*m))
181  {
182  *info = -5;
183  }
184  else if (*lwork < max(1,*n) && ! lquery)
185  {
186  *info = -8;
187  }
188  if (*info != 0)
189  {
190  i__1 = -(*info);
191  xerbla_("CUNGQR", &i__1);
192  return 0;
193  }
194  else if (lquery)
195  {
196  return 0;
197  }
198  /* Quick return if possible */
199  if (*n <= 0)
200  {
201  work[1].r = 1.f;
202  work[1].i = 0.f; // , expr subst
203  return 0;
204  }
205  nbmin = 2;
206  nx = 0;
207  iws = *n;
208  if (nb > 1 && nb < *k)
209  {
210  /* Determine when to cross over from blocked to unblocked code. */
211  /* Computing MAX */
212  i__1 = 0;
213  i__2 = ilaenv_(&c__3, "CUNGQR", " ", m, n, k, &c_n1); // , expr subst
214  nx = max(i__1,i__2);
215  if (nx < *k)
216  {
217  /* Determine if workspace is large enough for blocked code. */
218  ldwork = *n;
219  iws = ldwork * nb;
220  if (*lwork < iws)
221  {
222  /* Not enough workspace to use optimal NB: reduce NB and */
223  /* determine the minimum value of NB. */
224  nb = *lwork / ldwork;
225  /* Computing MAX */
226  i__1 = 2;
227  i__2 = ilaenv_(&c__2, "CUNGQR", " ", m, n, k, &c_n1); // , expr subst
228  nbmin = max(i__1,i__2);
229  }
230  }
231  }
232  if (nb >= nbmin && nb < *k && nx < *k)
233  {
234  /* Use blocked code after the last block. */
235  /* The first kk columns are handled by the block method. */
236  ki = (*k - nx - 1) / nb * nb;
237  /* Computing MIN */
238  i__1 = *k;
239  i__2 = ki + nb; // , expr subst
240  kk = min(i__1,i__2);
241  /* Set A(1:kk,kk+1:n) to zero. */
242  i__1 = *n;
243  for (j = kk + 1;
244  j <= i__1;
245  ++j)
246  {
247  i__2 = kk;
248  for (i__ = 1;
249  i__ <= i__2;
250  ++i__)
251  {
252  i__3 = i__ + j * a_dim1;
253  a[i__3].r = 0.f;
254  a[i__3].i = 0.f; // , expr subst
255  /* L10: */
256  }
257  /* L20: */
258  }
259  }
260  else
261  {
262  kk = 0;
263  }
264  /* Use unblocked code for the last or only block. */
265  if (kk < *n)
266  {
267  i__1 = *m - kk;
268  i__2 = *n - kk;
269  i__3 = *k - kk;
270  cung2r_fla(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & tau[kk + 1], &work[1], &iinfo);
271  }
272  if (kk > 0)
273  {
274  /* Use blocked code */
275  i__1 = -nb;
276  for (i__ = ki + 1;
277  i__1 < 0 ? i__ >= 1 : i__ <= 1;
278  i__ += i__1)
279  {
280  /* Computing MIN */
281  i__2 = nb;
282  i__3 = *k - i__ + 1; // , expr subst
283  ib = min(i__2,i__3);
284  if (i__ + ib <= *n)
285  {
286  /* Form the triangular factor of the block reflector */
287  /* H = H(i) H(i+1) . . . H(i+ib-1) */
288  i__2 = *m - i__ + 1;
289  clarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &ldwork);
290  /* Apply H to A(i:m,i+ib:n) from the left */
291  i__2 = *m - i__ + 1;
292  i__3 = *n - i__ - ib + 1;
293  clarfb_("Left", "No transpose", "Forward", "Columnwise", & i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & work[ib + 1], &ldwork);
294  }
295  /* Apply H to rows i:m of current block */
296  i__2 = *m - i__ + 1;
297  cung2r_fla(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & work[1], &iinfo);
298  /* Set rows 1:i-1 of current block to zero */
299  i__2 = i__ + ib - 1;
300  for (j = i__;
301  j <= i__2;
302  ++j)
303  {
304  i__3 = i__ - 1;
305  for (l = 1;
306  l <= i__3;
307  ++l)
308  {
309  i__4 = l + j * a_dim1;
310  a[i__4].r = 0.f;
311  a[i__4].i = 0.f; // , expr subst
312  /* L30: */
313  }
314  /* L40: */
315  }
316  /* L50: */
317  }
318  }
319  work[1].r = (real) iws;
320  work[1].i = 0.f; // , expr subst
321  return 0;
322  /* End of CUNGQR */
323 }
int integer
Definition: FLA_f2c.h:25
int logical
Definition: FLA_f2c.h:36
float real
Definition: FLA_f2c.h:30
int cung2r_fla(integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *info)
Definition: cung2r.c:105
Definition: FLA_f2c.h:32
real r
Definition: FLA_f2c.h:32
real i
Definition: FLA_f2c.h:32

References cung2r_fla().

Referenced by cungtr_fla().