libflame  revision_anchor
Functions
zunmlq.c File Reference

(r)

Functions

int zunmlq_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

◆ zunmlq_fla()

int zunmlq_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 
)
168 {
169  /* System generated locals */
170  integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__4, i__5;
171  char ch__1[2];
172  /* Builtin functions */
173  /* Subroutine */
174 
175  /* Local variables */
176  integer i__;
177  doublecomplex t[4160] /* was [65][64] */
178  ;
179  integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
180  logical left;
181  extern logical lsame_(char *, char *);
182  integer nbmin, iinfo;
183  extern /* Subroutine */
184  int zunml2_fla(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
185  extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
186  extern /* Subroutine */
187  int zlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
188  logical notran;
189  integer ldwork;
190  extern /* Subroutine */
191  int zlarft_(char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *);
192  char transt[1];
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,*k))
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, "ZUNMLQ", 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_("ZUNMLQ", &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, "ZUNMLQ", 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  zunml2_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  if (notran)
353  {
354  *(unsigned char *)transt = 'C';
355  }
356  else
357  {
358  *(unsigned char *)transt = 'N';
359  }
360  i__1 = i2;
361  i__2 = i3;
362  for (i__ = i1;
363  i__2 < 0 ? i__ >= i__1 : i__ <= i__1;
364  i__ += i__2)
365  {
366  /* Computing MIN */
367  i__4 = nb;
368  i__5 = *k - i__ + 1; // , expr subst
369  ib = min(i__4,i__5);
370  /* Form the triangular factor of the block reflector */
371  /* H = H(i) H(i+1) . . . H(i+ib-1) */
372  i__4 = nq - i__ + 1;
373  zlarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], t, &c__65);
374  if (left)
375  {
376  /* H or H**H is applied to C(i:m,1:n) */
377  mi = *m - i__ + 1;
378  ic = i__;
379  }
380  else
381  {
382  /* H or H**H is applied to C(1:m,i:n) */
383  ni = *n - i__ + 1;
384  jc = i__;
385  }
386  /* Apply H or H**H */
387  zlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], ldc, &work[1], &ldwork);
388  /* L10: */
389  }
390  }
391  work[1].r = (doublereal) lwkopt;
392  work[1].i = 0.; // , expr subst
393  return 0;
394  /* End of ZUNMLQ */
395 }
double doublereal
Definition: FLA_f2c.h:31
int integer
Definition: FLA_f2c.h:25
int logical
Definition: FLA_f2c.h:36
Definition: FLA_f2c.h:33
doublereal i
Definition: FLA_f2c.h:33
doublereal r
Definition: FLA_f2c.h:33
int zunml2_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: zunml2.c:148

References zunml2_fla().