libflame  revision_anchor
Functions
dsytd2.c File Reference

(r)

Functions

int dsytd2_fla (char *uplo, integer *n, doublereal *a, integer *lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info)
 

Function Documentation

◆ dsytd2_fla()

int dsytd2_fla ( char *  uplo,
integer n,
doublereal a,
integer lda,
doublereal d__,
doublereal e,
doublereal tau,
integer info 
)
170 {
171  /* System generated locals */
172  integer a_dim1, a_offset, i__1, i__2, i__3;
173  /* Local variables */
174  integer i__;
175  extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
176  doublereal taui;
177  extern /* Subroutine */
178  int dsyr2_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *);
179  doublereal alpha;
180  extern logical lsame_(char *, char *);
181  extern /* Subroutine */
182  int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *);
183  logical upper;
184  extern /* Subroutine */
185  int dsymv_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer * );
186  /* -- LAPACK computational routine (version 3.4.2) -- */
187  /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
188  /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
189  /* September 2012 */
190  /* .. Scalar Arguments .. */
191  /* .. */
192  /* .. Array Arguments .. */
193  /* .. */
194  /* ===================================================================== */
195  /* .. Parameters .. */
196  /* .. */
197  /* .. Local Scalars .. */
198  /* .. */
199  /* .. External Subroutines .. */
200  /* .. */
201  /* .. External Functions .. */
202  /* .. */
203  /* .. Intrinsic Functions .. */
204  /* .. */
205  /* .. Executable Statements .. */
206  /* Test the input parameters */
207  /* Parameter adjustments */
208  a_dim1 = *lda;
209  a_offset = 1 + a_dim1;
210  a -= a_offset;
211  --d__;
212  --e;
213  --tau;
214  /* Function Body */
215  *info = 0;
216  upper = lsame_(uplo, "U");
217  if (! upper && ! lsame_(uplo, "L"))
218  {
219  *info = -1;
220  }
221  else if (*n < 0)
222  {
223  *info = -2;
224  }
225  else if (*lda < max(1,*n))
226  {
227  *info = -4;
228  }
229  if (*info != 0)
230  {
231  i__1 = -(*info);
232  xerbla_("DSYTD2", &i__1);
233  return 0;
234  }
235  /* Quick return if possible */
236  if (*n <= 0)
237  {
238  return 0;
239  }
240  if (upper)
241  {
242  /* Reduce the upper triangle of A */
243  for (i__ = *n - 1;
244  i__ >= 1;
245  --i__)
246  {
247  /* Generate elementary reflector H(i) = I - tau * v * v**T */
248  /* to annihilate A(1:i-1,i+1) */
249  dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui);
250  e[i__] = a[i__ + (i__ + 1) * a_dim1];
251  if (taui != 0.)
252  {
253  /* Apply H(i) from both sides to A(1:i,1:i) */
254  a[i__ + (i__ + 1) * a_dim1] = 1.;
255  /* Compute x := tau * A * v storing x in TAU(1:i) */
256  dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1);
257  /* Compute w := x - 1/2 * tau * (x**T * v) * v */
258  alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1], &c__1);
259  daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ 1], &c__1);
260  /* Apply the transformation as a rank-2 update: */
261  /* A := A - v * w**T - w * v**T */
262  dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[1], &c__1, &a[a_offset], lda);
263  a[i__ + (i__ + 1) * a_dim1] = e[i__];
264  }
265  d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1];
266  tau[i__] = taui;
267  /* L10: */
268  }
269  d__[1] = a[a_dim1 + 1];
270  }
271  else
272  {
273  /* Reduce the lower triangle of A */
274  i__1 = *n - 1;
275  for (i__ = 1;
276  i__ <= i__1;
277  ++i__)
278  {
279  /* Generate elementary reflector H(i) = I - tau * v * v**T */
280  /* to annihilate A(i+2:n,i) */
281  i__2 = *n - i__;
282  /* Computing MIN */
283  i__3 = i__ + 2;
284  dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*n) + i__ * a_dim1], &c__1, &taui);
285  e[i__] = a[i__ + 1 + i__ * a_dim1];
286  if (taui != 0.)
287  {
288  /* Apply H(i) from both sides to A(i+1:n,i+1:n) */
289  a[i__ + 1 + i__ * a_dim1] = 1.;
290  /* Compute x := tau * A * v storing y in TAU(i:n-1) */
291  i__2 = *n - i__;
292  dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[ i__], &c__1);
293  /* Compute w := x - 1/2 * tau * (x**T * v) * v */
294  i__2 = *n - i__;
295  alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
296  i__2 = *n - i__;
297  daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ i__], &c__1);
298  /* Apply the transformation as a rank-2 update: */
299  /* A := A - v * w**T - w * v**T */
300  i__2 = *n - i__;
301  dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda);
302  a[i__ + 1 + i__ * a_dim1] = e[i__];
303  }
304  d__[i__] = a[i__ + i__ * a_dim1];
305  tau[i__] = taui;
306  /* L20: */
307  }
308  d__[*n] = a[*n + *n * a_dim1];
309  }
310  return 0;
311  /* End of DSYTD2 */
312 }
double doublereal
Definition: FLA_f2c.h:31
int integer
Definition: FLA_f2c.h:25
int logical
Definition: FLA_f2c.h:36

Referenced by dsytrd_fla().