libflame  revision_anchor
Functions
ssytd2.c File Reference

(r)

Functions

int ssytd2_fla (char *uplo, integer *n, real *a, integer *lda, real *d__, real *e, real *tau, integer *info)
 

Function Documentation

◆ ssytd2_fla()

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

Referenced by ssytrd_fla().