libflame  revision_anchor
Functions
dorglq.c File Reference

(r)

Functions

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

Function Documentation

◆ dorglq_fla()

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

References dorgl2_fla().

Referenced by dorcsd2by1_(), and dorcsd_().