libflame  revision_anchor
Functions
sormtr.c File Reference

(r)

Functions

int sormtr_fla (char *side, char *uplo, char *trans, integer *m, integer *n, real *a, integer *lda, real *tau, real *c__, integer *ldc, real *work, integer *lwork, integer *info)
 

Function Documentation

◆ sormtr_fla()

int sormtr_fla ( char *  side,
char *  uplo,
char *  trans,
integer m,
integer n,
real a,
integer lda,
real tau,
real c__,
integer ldc,
real work,
integer lwork,
integer info 
)

References sormqr_fla().

171 {
172  /* System generated locals */
173  integer a_dim1, a_offset, c_dim1, c_offset, i__2, i__3;
174  char ch__1[2];
175  /* Builtin functions */
176  /* Subroutine */
177 
178  /* Local variables */
179  integer i1, i2, nb, mi, ni, nq, nw;
180  logical left;
181  extern logical lsame_(char *, char *);
182  integer iinfo;
183  logical upper;
184  extern /* Subroutine */
185  int xerbla_(char *, integer *);
186  extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
187  extern /* Subroutine */
188  int sormql_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, integer *);
189  integer lwkopt;
190  logical lquery;
191  extern /* Subroutine */
192  int sormqr_fla(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, integer *);
193  /* -- LAPACK computational routine (version 3.4.0) -- */
194  /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
195  /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
196  /* November 2011 */
197  /* .. Scalar Arguments .. */
198  /* .. */
199  /* .. Array Arguments .. */
200  /* .. */
201  /* ===================================================================== */
202  /* .. Local Scalars .. */
203  /* .. */
204  /* .. External Functions .. */
205  /* .. */
206  /* .. External Subroutines .. */
207  /* .. */
208  /* .. Intrinsic Functions .. */
209  /* .. */
210  /* .. Executable Statements .. */
211  /* Test the input arguments */
212  /* Parameter adjustments */
213  a_dim1 = *lda;
214  a_offset = 1 + a_dim1;
215  a -= a_offset;
216  --tau;
217  c_dim1 = *ldc;
218  c_offset = 1 + c_dim1;
219  c__ -= c_offset;
220  --work;
221  /* Function Body */
222  *info = 0;
223  left = lsame_(side, "L");
224  upper = lsame_(uplo, "U");
225  lquery = *lwork == -1;
226  /* NQ is the order of Q and NW is the minimum dimension of WORK */
227  if (left)
228  {
229  nq = *m;
230  nw = *n;
231  }
232  else
233  {
234  nq = *n;
235  nw = *m;
236  }
237  if (! left && ! lsame_(side, "R"))
238  {
239  *info = -1;
240  }
241  else if (! upper && ! lsame_(uplo, "L"))
242  {
243  *info = -2;
244  }
245  else if (! lsame_(trans, "N") && ! lsame_(trans, "T"))
246  {
247  *info = -3;
248  }
249  else if (*m < 0)
250  {
251  *info = -4;
252  }
253  else if (*n < 0)
254  {
255  *info = -5;
256  }
257  else if (*lda < max(1,nq))
258  {
259  *info = -7;
260  }
261  else if (*ldc < max(1,*m))
262  {
263  *info = -10;
264  }
265  else if (*lwork < max(1,nw) && ! lquery)
266  {
267  *info = -12;
268  }
269  if (*info == 0)
270  {
271  if (upper)
272  {
273  if (left)
274  {
275  i__2 = *m - 1;
276  i__3 = *m - 1;
277  nb = ilaenv_(&c__1, "SORMQL", ch__1, &i__2, n, &i__3, &c_n1);
278  }
279  else
280  {
281  i__2 = *n - 1;
282  i__3 = *n - 1;
283  nb = ilaenv_(&c__1, "SORMQL", ch__1, m, &i__2, &i__3, &c_n1);
284  }
285  }
286  else
287  {
288  if (left)
289  {
290  i__2 = *m - 1;
291  i__3 = *m - 1;
292  nb = ilaenv_(&c__1, "SORMQR", ch__1, &i__2, n, &i__3, &c_n1);
293  }
294  else
295  {
296  i__2 = *n - 1;
297  i__3 = *n - 1;
298  nb = ilaenv_(&c__1, "SORMQR", ch__1, m, &i__2, &i__3, &c_n1);
299  }
300  }
301  lwkopt = max(1,nw) * nb;
302  work[1] = (real) lwkopt;
303  }
304  if (*info != 0)
305  {
306  i__2 = -(*info);
307  xerbla_("SORMTR", &i__2);
308  return 0;
309  }
310  else if (lquery)
311  {
312  return 0;
313  }
314  /* Quick return if possible */
315  if (*m == 0 || *n == 0 || nq == 1)
316  {
317  work[1] = 1.f;
318  return 0;
319  }
320  if (left)
321  {
322  mi = *m - 1;
323  ni = *n;
324  }
325  else
326  {
327  mi = *m;
328  ni = *n - 1;
329  }
330  if (upper)
331  {
332  /* Q was determined by a call to SSYTRD with UPLO = 'U' */
333  i__2 = nq - 1;
334  sormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, & tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo);
335  }
336  else
337  {
338  /* Q was determined by a call to SSYTRD with UPLO = 'L' */
339  if (left)
340  {
341  i1 = 2;
342  i2 = 1;
343  }
344  else
345  {
346  i1 = 1;
347  i2 = 2;
348  }
349  i__2 = nq - 1;
350  sormqr_fla(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], & c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
351  }
352  work[1] = (real) lwkopt;
353  return 0;
354  /* End of SORMTR */
355 }
float real
Definition: FLA_f2c.h:30
int logical
Definition: FLA_f2c.h:36
int integer
Definition: FLA_f2c.h:25
int sormqr_fla(char *side, char *trans, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, real *work, integer *lwork, integer *info)
Definition: sormqr.c:169