libflame  revision_anchor
Functions
zunmqr.c File Reference

(r)

Functions

int zunmqr_fla (char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork, integer *info)
 

Function Documentation

◆ zunmqr_fla()

int zunmqr_fla ( char *  side,
char *  trans,
integer m,
integer n,
integer k,
doublecomplex a,
integer lda,
doublecomplex tau,
doublecomplex c__,
integer ldc,
doublecomplex work,
integer lwork,
integer info 
)

References zunm2r_fla().

Referenced by zunmtr_fla().

169 {
170  /* System generated locals */
171  integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__4, i__5;
172  char ch__1[2];
173  /* Builtin functions */
174  /* Subroutine */
175 
176  /* Local variables */
177  integer i__;
178  doublecomplex t[4160] /* was [65][64] */
179  ;
180  integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
181  logical left;
182  extern logical lsame_(char *, char *);
183  integer nbmin, iinfo;
184  extern /* Subroutine */
185  int zunm2r_fla(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
186  extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
187  extern /* Subroutine */
188  int zlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
189  logical notran;
190  integer ldwork;
191  extern /* Subroutine */
192  int zlarft_(char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *);
193  integer lwkopt;
194  logical lquery;
195  /* -- LAPACK computational routine (version 3.4.0) -- */
196  /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
197  /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
198  /* November 2011 */
199  /* .. Scalar Arguments .. */
200  /* .. */
201  /* .. Array Arguments .. */
202  /* .. */
203  /* ===================================================================== */
204  /* .. Parameters .. */
205  /* .. */
206  /* .. Local Scalars .. */
207  /* .. */
208  /* .. Local Arrays .. */
209  /* .. */
210  /* .. External Functions .. */
211  /* .. */
212  /* .. External Subroutines .. */
213  /* .. */
214  /* .. Intrinsic Functions .. */
215  /* .. */
216  /* .. Executable Statements .. */
217  /* Test the input arguments */
218  /* Parameter adjustments */
219  a_dim1 = *lda;
220  a_offset = 1 + a_dim1;
221  a -= a_offset;
222  --tau;
223  c_dim1 = *ldc;
224  c_offset = 1 + c_dim1;
225  c__ -= c_offset;
226  --work;
227  /* Function Body */
228  *info = 0;
229  left = lsame_(side, "L");
230  notran = lsame_(trans, "N");
231  lquery = *lwork == -1;
232  /* NQ is the order of Q and NW is the minimum dimension of WORK */
233  if (left)
234  {
235  nq = *m;
236  nw = *n;
237  }
238  else
239  {
240  nq = *n;
241  nw = *m;
242  }
243  if (! left && ! lsame_(side, "R"))
244  {
245  *info = -1;
246  }
247  else if (! notran && ! lsame_(trans, "C"))
248  {
249  *info = -2;
250  }
251  else if (*m < 0)
252  {
253  *info = -3;
254  }
255  else if (*n < 0)
256  {
257  *info = -4;
258  }
259  else if (*k < 0 || *k > nq)
260  {
261  *info = -5;
262  }
263  else if (*lda < max(1,nq))
264  {
265  *info = -7;
266  }
267  else if (*ldc < max(1,*m))
268  {
269  *info = -10;
270  }
271  else if (*lwork < max(1,nw) && ! lquery)
272  {
273  *info = -12;
274  }
275  if (*info == 0)
276  {
277  /* Determine the block size. NB may be at most NBMAX, where NBMAX */
278  /* is used to define the local array T. */
279  /* Computing MIN */
280  i__1 = 64;
281  i__2 = ilaenv_(&c__1, "ZUNMQR", ch__1, m, n, k, &c_n1); // , expr subst
282  nb = min(i__1,i__2);
283  lwkopt = max(1,nw) * nb;
284  work[1].r = (doublereal) lwkopt;
285  work[1].i = 0.; // , expr subst
286  }
287  if (*info != 0)
288  {
289  i__1 = -(*info);
290  xerbla_("ZUNMQR", &i__1);
291  return 0;
292  }
293  else if (lquery)
294  {
295  return 0;
296  }
297  /* Quick return if possible */
298  if (*m == 0 || *n == 0 || *k == 0)
299  {
300  work[1].r = 1.;
301  work[1].i = 0.; // , expr subst
302  return 0;
303  }
304  nbmin = 2;
305  ldwork = nw;
306  if (nb > 1 && nb < *k)
307  {
308  iws = nw * nb;
309  if (*lwork < iws)
310  {
311  nb = *lwork / ldwork;
312  /* Computing MAX */
313  i__1 = 2;
314  i__2 = ilaenv_(&c__2, "ZUNMQR", ch__1, m, n, k, &c_n1); // , expr subst
315  nbmin = max(i__1,i__2);
316  }
317  }
318  else
319  {
320  iws = nw;
321  }
322  if (nb < nbmin || nb >= *k)
323  {
324  /* Use unblocked code */
325  zunm2r_fla(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ c_offset], ldc, &work[1], &iinfo);
326  }
327  else
328  {
329  /* Use blocked code */
330  if (left && ! notran || ! left && notran)
331  {
332  i1 = 1;
333  i2 = *k;
334  i3 = nb;
335  }
336  else
337  {
338  i1 = (*k - 1) / nb * nb + 1;
339  i2 = 1;
340  i3 = -nb;
341  }
342  if (left)
343  {
344  ni = *n;
345  jc = 1;
346  }
347  else
348  {
349  mi = *m;
350  ic = 1;
351  }
352  i__1 = i2;
353  i__2 = i3;
354  for (i__ = i1;
355  i__2 < 0 ? i__ >= i__1 : i__ <= i__1;
356  i__ += i__2)
357  {
358  /* Computing MIN */
359  i__4 = nb;
360  i__5 = *k - i__ + 1; // , expr subst
361  ib = min(i__4,i__5);
362  /* Form the triangular factor of the block reflector */
363  /* H = H(i) H(i+1) . . . H(i+ib-1) */
364  i__4 = nq - i__ + 1;
365  zlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], t, &c__65) ;
366  if (left)
367  {
368  /* H or H**H is applied to C(i:m,1:n) */
369  mi = *m - i__ + 1;
370  ic = i__;
371  }
372  else
373  {
374  /* H or H**H is applied to C(1:m,i:n) */
375  ni = *n - i__ + 1;
376  jc = i__;
377  }
378  /* Apply H or H**H */
379  zlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[ i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], ldc, &work[1], &ldwork);
380  /* L10: */
381  }
382  }
383  work[1].r = (doublereal) lwkopt;
384  work[1].i = 0.; // , expr subst
385  return 0;
386  /* End of ZUNMQR */
387 }
doublereal r
Definition: FLA_f2c.h:33
int zunm2r_fla(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info)
Definition: zunm2r.c:151
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