libflame  revision_anchor
Functions
cunmlq.c File Reference

(r)

Functions

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

Function Documentation

◆ cunmlq_fla()

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

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