libflame  revision_anchor
Functions
dorgtr.c File Reference

(r)

Functions

int dorgtr_fla (char *uplo, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
 

Function Documentation

◆ dorgtr_fla()

int dorgtr_fla ( char *  uplo,
integer n,
doublereal a,
integer lda,
doublereal tau,
doublereal work,
integer lwork,
integer info 
)
118 {
119  /* System generated locals */
120  integer a_dim1, a_offset, i__1, i__2, i__3;
121  /* Local variables */
122  integer i__, j, nb;
123  extern logical lsame_(char *, char *);
124  integer iinfo;
125  logical upper;
126  extern /* Subroutine */
127  int xerbla_(char *, integer *);
128  extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
129  extern /* Subroutine */
131  integer 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 Functions .. */
147  /* .. */
148  /* .. External Subroutines .. */
149  /* .. */
150  /* .. Intrinsic 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  lquery = *lwork == -1;
163  upper = lsame_(uplo, "U");
164  if (! upper && ! lsame_(uplo, "L"))
165  {
166  *info = -1;
167  }
168  else if (*n < 0)
169  {
170  *info = -2;
171  }
172  else if (*lda < max(1,*n))
173  {
174  *info = -4;
175  }
176  else /* if(complicated condition) */
177  {
178  /* Computing MAX */
179  i__1 = 1;
180  i__2 = *n - 1; // , expr subst
181  if (*lwork < max(i__1,i__2) && ! lquery)
182  {
183  *info = -7;
184  }
185  }
186  if (*info == 0)
187  {
188  if (upper)
189  {
190  i__1 = *n - 1;
191  i__2 = *n - 1;
192  i__3 = *n - 1;
193  nb = ilaenv_(&c__1, "DORGQL", " ", &i__1, &i__2, &i__3, &c_n1);
194  }
195  else
196  {
197  i__1 = *n - 1;
198  i__2 = *n - 1;
199  i__3 = *n - 1;
200  nb = ilaenv_(&c__1, "DORGQR", " ", &i__1, &i__2, &i__3, &c_n1);
201  }
202  /* Computing MAX */
203  i__1 = 1;
204  i__2 = *n - 1; // , expr subst
205  lwkopt = max(i__1,i__2) * nb;
206  work[1] = (doublereal) lwkopt;
207  }
208  if (*info != 0)
209  {
210  i__1 = -(*info);
211  xerbla_("DORGTR", &i__1);
212  return 0;
213  }
214  else if (lquery)
215  {
216  return 0;
217  }
218  /* Quick return if possible */
219  if (*n == 0)
220  {
221  work[1] = 1.;
222  return 0;
223  }
224  if (upper)
225  {
226  /* Q was determined by a call to DSYTRD with UPLO = 'U' */
227  /* Shift the vectors which define the elementary reflectors one */
228  /* column to the left, and set the last row and column of Q to */
229  /* those of the unit matrix */
230  i__1 = *n - 1;
231  for (j = 1;
232  j <= i__1;
233  ++j)
234  {
235  i__2 = j - 1;
236  for (i__ = 1;
237  i__ <= i__2;
238  ++i__)
239  {
240  a[i__ + j * a_dim1] = a[i__ + (j + 1) * a_dim1];
241  /* L10: */
242  }
243  a[*n + j * a_dim1] = 0.;
244  /* L20: */
245  }
246  i__1 = *n - 1;
247  for (i__ = 1;
248  i__ <= i__1;
249  ++i__)
250  {
251  a[i__ + *n * a_dim1] = 0.;
252  /* L30: */
253  }
254  a[*n + *n * a_dim1] = 1.;
255  /* Generate Q(1:n-1,1:n-1) */
256  i__1 = *n - 1;
257  i__2 = *n - 1;
258  i__3 = *n - 1;
259  dorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], lwork, &iinfo);
260  }
261  else
262  {
263  /* Q was determined by a call to DSYTRD with UPLO = 'L'. */
264  /* Shift the vectors which define the elementary reflectors one */
265  /* column to the right, and set the first row and column of Q to */
266  /* those of the unit matrix */
267  for (j = *n;
268  j >= 2;
269  --j)
270  {
271  a[j * a_dim1 + 1] = 0.;
272  i__1 = *n;
273  for (i__ = j + 1;
274  i__ <= i__1;
275  ++i__)
276  {
277  a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
278  /* L40: */
279  }
280  /* L50: */
281  }
282  a[a_dim1 + 1] = 1.;
283  i__1 = *n;
284  for (i__ = 2;
285  i__ <= i__1;
286  ++i__)
287  {
288  a[i__ + a_dim1] = 0.;
289  /* L60: */
290  }
291  if (*n > 1)
292  {
293  /* Generate Q(2:n,2:n) */
294  i__1 = *n - 1;
295  i__2 = *n - 1;
296  i__3 = *n - 1;
297  dorgqr_fla(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], &work[1], lwork, &iinfo);
298  }
299  }
300  work[1] = (doublereal) lwkopt;
301  return 0;
302  /* End of DORGTR */
303 }
double doublereal
Definition: FLA_f2c.h:31
int integer
Definition: FLA_f2c.h:25
int logical
Definition: FLA_f2c.h:36
int dorgqr_fla(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
Definition: dorgqr.c:123

References dorgqr_fla().