libflame  revision_anchor
Functions
dopgtr.c File Reference

(r)

Functions

int dopgtr_ (char *uplo, integer *n, doublereal *ap, doublereal *tau, doublereal *q, integer *ldq, doublereal *work, integer *info)
 

Function Documentation

◆ dopgtr_()

int dopgtr_ ( char *  uplo,
integer n,
doublereal ap,
doublereal tau,
doublereal q,
integer ldq,
doublereal work,
integer info 
)

References dorg2r_fla().

105 {
106  /* System generated locals */
107  integer q_dim1, q_offset, i__1, i__2, i__3;
108  /* Local variables */
109  integer i__, j, ij;
110  extern logical lsame_(char *, char *);
111  integer iinfo;
112  logical upper;
113  extern /* Subroutine */
114  int dorg2l_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dorg2r_fla(integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
115  /* -- LAPACK computational routine (version 3.4.0) -- */
116  /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
117  /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
118  /* November 2011 */
119  /* .. Scalar Arguments .. */
120  /* .. */
121  /* .. Array Arguments .. */
122  /* .. */
123  /* ===================================================================== */
124  /* .. Parameters .. */
125  /* .. */
126  /* .. Local Scalars .. */
127  /* .. */
128  /* .. External Functions .. */
129  /* .. */
130  /* .. External Subroutines .. */
131  /* .. */
132  /* .. Intrinsic Functions .. */
133  /* .. */
134  /* .. Executable Statements .. */
135  /* Test the input arguments */
136  /* Parameter adjustments */
137  --ap;
138  --tau;
139  q_dim1 = *ldq;
140  q_offset = 1 + q_dim1;
141  q -= q_offset;
142  --work;
143  /* Function Body */
144  *info = 0;
145  upper = lsame_(uplo, "U");
146  if (! upper && ! lsame_(uplo, "L"))
147  {
148  *info = -1;
149  }
150  else if (*n < 0)
151  {
152  *info = -2;
153  }
154  else if (*ldq < max(1,*n))
155  {
156  *info = -6;
157  }
158  if (*info != 0)
159  {
160  i__1 = -(*info);
161  xerbla_("DOPGTR", &i__1);
162  return 0;
163  }
164  /* Quick return if possible */
165  if (*n == 0)
166  {
167  return 0;
168  }
169  if (upper)
170  {
171  /* Q was determined by a call to DSPTRD with UPLO = 'U' */
172  /* Unpack the vectors which define the elementary reflectors and */
173  /* set the last row and column of Q equal to those of the unit */
174  /* matrix */
175  ij = 2;
176  i__1 = *n - 1;
177  for (j = 1;
178  j <= i__1;
179  ++j)
180  {
181  i__2 = j - 1;
182  for (i__ = 1;
183  i__ <= i__2;
184  ++i__)
185  {
186  q[i__ + j * q_dim1] = ap[ij];
187  ++ij;
188  /* L10: */
189  }
190  ij += 2;
191  q[*n + j * q_dim1] = 0.;
192  /* L20: */
193  }
194  i__1 = *n - 1;
195  for (i__ = 1;
196  i__ <= i__1;
197  ++i__)
198  {
199  q[i__ + *n * q_dim1] = 0.;
200  /* L30: */
201  }
202  q[*n + *n * q_dim1] = 1.;
203  /* Generate Q(1:n-1,1:n-1) */
204  i__1 = *n - 1;
205  i__2 = *n - 1;
206  i__3 = *n - 1;
207  dorg2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], & iinfo);
208  }
209  else
210  {
211  /* Q was determined by a call to DSPTRD with UPLO = 'L'. */
212  /* Unpack the vectors which define the elementary reflectors and */
213  /* set the first row and column of Q equal to those of the unit */
214  /* matrix */
215  q[q_dim1 + 1] = 1.;
216  i__1 = *n;
217  for (i__ = 2;
218  i__ <= i__1;
219  ++i__)
220  {
221  q[i__ + q_dim1] = 0.;
222  /* L40: */
223  }
224  ij = 3;
225  i__1 = *n;
226  for (j = 2;
227  j <= i__1;
228  ++j)
229  {
230  q[j * q_dim1 + 1] = 0.;
231  i__2 = *n;
232  for (i__ = j + 1;
233  i__ <= i__2;
234  ++i__)
235  {
236  q[i__ + j * q_dim1] = ap[ij];
237  ++ij;
238  /* L50: */
239  }
240  ij += 2;
241  /* L60: */
242  }
243  if (*n > 1)
244  {
245  /* Generate Q(2:n,2:n) */
246  i__1 = *n - 1;
247  i__2 = *n - 1;
248  i__3 = *n - 1;
249  dorg2r_fla(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1], &work[1], &iinfo);
250  }
251  }
252  return 0;
253  /* End of DOPGTR */
254 }
int dorg2r_fla(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info)
Definition: dorg2r.c:105
double doublereal
Definition: FLA_f2c.h:31
int logical
Definition: FLA_f2c.h:36
int integer
Definition: FLA_f2c.h:25