libflame  revision_anchor
Functions
dorgqr.c File Reference

(r)

Functions

int dorgqr_fla (integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
 

Function Documentation

◆ dorgqr_fla()

int dorgqr_fla ( integer m,
integer n,
integer k,
doublereal a,
integer lda,
doublereal tau,
doublereal work,
integer lwork,
integer info 
)

References dorg2r_fla().

Referenced by dorcsd2by1_(), dorcsd_(), dorghr_(), and dorgtr_fla().

124 {
125  /* System generated locals */
126  integer a_dim1, a_offset, i__1, i__2, i__3;
127  /* Local variables */
128  integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
129  extern /* Subroutine */
130  int dorg2r_fla(integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, 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, "DORGQR", " ", m, n, k, &c_n1);
164  lwkopt = max(1,*n) * nb;
165  work[1] = (doublereal) lwkopt;
166  lquery = *lwork == -1;
167  if (*m < 0)
168  {
169  *info = -1;
170  }
171  else if (*n < 0 || *n > *m)
172  {
173  *info = -2;
174  }
175  else if (*k < 0 || *k > *n)
176  {
177  *info = -3;
178  }
179  else if (*lda < max(1,*m))
180  {
181  *info = -5;
182  }
183  else if (*lwork < max(1,*n) && ! lquery)
184  {
185  *info = -8;
186  }
187  if (*info != 0)
188  {
189  i__1 = -(*info);
190  xerbla_("DORGQR", &i__1);
191  return 0;
192  }
193  else if (lquery)
194  {
195  return 0;
196  }
197  /* Quick return if possible */
198  if (*n <= 0)
199  {
200  work[1] = 1.;
201  return 0;
202  }
203  nbmin = 2;
204  nx = 0;
205  iws = *n;
206  if (nb > 1 && nb < *k)
207  {
208  /* Determine when to cross over from blocked to unblocked code. */
209  /* Computing MAX */
210  i__1 = 0;
211  i__2 = ilaenv_(&c__3, "DORGQR", " ", m, n, k, &c_n1); // , expr subst
212  nx = max(i__1,i__2);
213  if (nx < *k)
214  {
215  /* Determine if workspace is large enough for blocked code. */
216  ldwork = *n;
217  iws = ldwork * nb;
218  if (*lwork < iws)
219  {
220  /* Not enough workspace to use optimal NB: reduce NB and */
221  /* determine the minimum value of NB. */
222  nb = *lwork / ldwork;
223  /* Computing MAX */
224  i__1 = 2;
225  i__2 = ilaenv_(&c__2, "DORGQR", " ", m, n, k, &c_n1); // , expr subst
226  nbmin = max(i__1,i__2);
227  }
228  }
229  }
230  if (nb >= nbmin && nb < *k && nx < *k)
231  {
232  /* Use blocked code after the last block. */
233  /* The first kk columns are handled by the block method. */
234  ki = (*k - nx - 1) / nb * nb;
235  /* Computing MIN */
236  i__1 = *k;
237  i__2 = ki + nb; // , expr subst
238  kk = min(i__1,i__2);
239  /* Set A(1:kk,kk+1:n) to zero. */
240  i__1 = *n;
241  for (j = kk + 1;
242  j <= i__1;
243  ++j)
244  {
245  i__2 = kk;
246  for (i__ = 1;
247  i__ <= i__2;
248  ++i__)
249  {
250  a[i__ + j * a_dim1] = 0.;
251  /* L10: */
252  }
253  /* L20: */
254  }
255  }
256  else
257  {
258  kk = 0;
259  }
260  /* Use unblocked code for the last or only block. */
261  if (kk < *n)
262  {
263  i__1 = *m - kk;
264  i__2 = *n - kk;
265  i__3 = *k - kk;
266  dorg2r_fla(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & tau[kk + 1], &work[1], &iinfo);
267  }
268  if (kk > 0)
269  {
270  /* Use blocked code */
271  i__1 = -nb;
272  for (i__ = ki + 1;
273  i__1 < 0 ? i__ >= 1 : i__ <= 1;
274  i__ += i__1)
275  {
276  /* Computing MIN */
277  i__2 = nb;
278  i__3 = *k - i__ + 1; // , expr subst
279  ib = min(i__2,i__3);
280  if (i__ + ib <= *n)
281  {
282  /* Form the triangular factor of the block reflector */
283  /* H = H(i) H(i+1) . . . H(i+ib-1) */
284  i__2 = *m - i__ + 1;
285  dlarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &ldwork);
286  /* Apply H to A(i:m,i+ib:n) from the left */
287  i__2 = *m - i__ + 1;
288  i__3 = *n - i__ - ib + 1;
289  dlarfb_("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);
290  }
291  /* Apply H to rows i:m of current block */
292  i__2 = *m - i__ + 1;
293  dorg2r_fla(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & work[1], &iinfo);
294  /* Set rows 1:i-1 of current block to zero */
295  i__2 = i__ + ib - 1;
296  for (j = i__;
297  j <= i__2;
298  ++j)
299  {
300  i__3 = i__ - 1;
301  for (l = 1;
302  l <= i__3;
303  ++l)
304  {
305  a[l + j * a_dim1] = 0.;
306  /* L30: */
307  }
308  /* L40: */
309  }
310  /* L50: */
311  }
312  }
313  work[1] = (doublereal) iws;
314  return 0;
315  /* End of DORGQR */
316 }
int dorg2r_fla(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info)
Definition: dorg2r.c:105
double doublereal
Definition: FLA_f2c.h:31
int logical
Definition: FLA_f2c.h:36
int integer
Definition: FLA_f2c.h:25