libflame  revision_anchor
Functions
zungqr.c File Reference

(r)

Functions

int zungqr_fla (integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info)
 

Function Documentation

◆ zungqr_fla()

int zungqr_fla ( integer m,
integer n,
integer k,
doublecomplex a,
integer lda,
doublecomplex tau,
doublecomplex work,
integer lwork,
integer info 
)

References zung2r_fla().

Referenced by zungtr_fla().

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