libflame  revision_anchor
Functions
sorgqr.c File Reference

(r)

Functions

int sorgqr_fla (integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info)
 

Function Documentation

◆ sorgqr_fla()

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

References sorg2r_fla().

Referenced by sorcsd2by1_(), sorcsd_(), sorghr_(), and sorgtr_fla().