libflame  revision_anchor
Functions
sorglq.c File Reference

(r)

Functions

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

Function Documentation

◆ sorglq_fla()

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

References sorgl2_fla().

Referenced by sorcsd2by1_(), and sorcsd_().