libflame revision_anchor
Functions
chetd2.c File Reference

(r)

Functions

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

Function Documentation

◆ chetd2_fla()

int chetd2_fla ( char uplo,
integer n,
complex a,
integer lda,
real d__,
real e,
complex tau,
integer info 
)
175{
176 /* System generated locals */
178 real r__1;
180 /* Local variables */
181 integer i__;
183 extern /* Subroutine */
184 int cher2_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, integer *);
186 extern /* Complex */
188 extern logical lsame_(char *, char *);
189 extern /* Subroutine */
190 int chemv_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, complex *, integer * ), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *);
192 extern /* Subroutine */
193 int clarfg_(integer *, complex *, complex *, integer *, complex *), xerbla_(char *, integer *);
194 /* -- LAPACK computational routine (version 3.4.2) -- */
195 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
196 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
197 /* September 2012 */
198 /* .. Scalar Arguments .. */
199 /* .. */
200 /* .. Array Arguments .. */
201 /* .. */
202 /* ===================================================================== */
203 /* .. Parameters .. */
204 /* .. */
205 /* .. Local Scalars .. */
206 /* .. */
207 /* .. External Subroutines .. */
208 /* .. */
209 /* .. External Functions .. */
210 /* .. */
211 /* .. Intrinsic Functions .. */
212 /* .. */
213 /* .. Executable Statements .. */
214 /* Test the input parameters */
215 /* Parameter adjustments */
216 a_dim1 = *lda;
217 a_offset = 1 + a_dim1;
218 a -= a_offset;
219 --d__;
220 --e;
221 --tau;
222 /* Function Body */
223 *info = 0;
224 upper = lsame_(uplo, "U");
225 if (! upper && ! lsame_(uplo, "L"))
226 {
227 *info = -1;
228 }
229 else if (*n < 0)
230 {
231 *info = -2;
232 }
233 else if (*lda < max(1,*n))
234 {
235 *info = -4;
236 }
237 if (*info != 0)
238 {
239 i__1 = -(*info);
240 xerbla_("CHETD2", &i__1);
241 return 0;
242 }
243 /* Quick return if possible */
244 if (*n <= 0)
245 {
246 return 0;
247 }
248 if (upper)
249 {
250 /* Reduce the upper triangle of A */
251 i__1 = *n + *n * a_dim1;
252 i__2 = *n + *n * a_dim1;
253 r__1 = a[i__2].r;
254 a[i__1].r = r__1;
255 a[i__1].i = 0.f; // , expr subst
256 for (i__ = *n - 1;
257 i__ >= 1;
258 --i__)
259 {
260 /* Generate elementary reflector H(i) = I - tau * v * v**H */
261 /* to annihilate A(1:i-1,i+1) */
262 i__1 = i__ + (i__ + 1) * a_dim1;
263 alpha.r = a[i__1].r;
264 alpha.i = a[i__1].i; // , expr subst
265 clarfg_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui);
266 i__1 = i__;
267 e[i__1] = alpha.r;
268 if (taui.r != 0.f || taui.i != 0.f)
269 {
270 /* Apply H(i) from both sides to A(1:i,1:i) */
271 i__1 = i__ + (i__ + 1) * a_dim1;
272 a[i__1].r = 1.f;
273 a[i__1].i = 0.f; // , expr subst
274 /* Compute x := tau * A * v storing x in TAU(1:i) */
275 chemv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * a_dim1 + 1], &c__1, &c_b2, &tau[1], &c__1);
276 /* Compute w := x - 1/2 * tau * (x**H * v) * v */
277 q__3.r = -.5f;
278 q__3.i = -0.f; // , expr subst
279 q__2.r = q__3.r * taui.r - q__3.i * taui.i;
280 q__2.i = q__3.r * taui.i + q__3.i * taui.r; // , expr subst
281 cdotc_f2c_(&q__4, &i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1] , &c__1);
282 q__1.r = q__2.r * q__4.r - q__2.i * q__4.i;
283 q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; // , expr subst
284 alpha.r = q__1.r;
285 alpha.i = q__1.i; // , expr subst
286 caxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ 1], &c__1);
287 /* Apply the transformation as a rank-2 update: */
288 /* A := A - v * w**H - w * v**H */
289 q__1.r = -1.f;
290 q__1.i = -0.f; // , expr subst
291 cher2_(uplo, &i__, &q__1, &a[(i__ + 1) * a_dim1 + 1], &c__1, & tau[1], &c__1, &a[a_offset], lda);
292 }
293 else
294 {
295 i__1 = i__ + i__ * a_dim1;
296 i__2 = i__ + i__ * a_dim1;
297 r__1 = a[i__2].r;
298 a[i__1].r = r__1;
299 a[i__1].i = 0.f; // , expr subst
300 }
301 i__1 = i__ + (i__ + 1) * a_dim1;
302 i__2 = i__;
303 a[i__1].r = e[i__2];
304 a[i__1].i = 0.f; // , expr subst
305 i__1 = i__ + 1;
306 i__2 = i__ + 1 + (i__ + 1) * a_dim1;
307 d__[i__1] = a[i__2].r;
308 i__1 = i__;
309 tau[i__1].r = taui.r;
310 tau[i__1].i = taui.i; // , expr subst
311 /* L10: */
312 }
313 i__1 = a_dim1 + 1;
314 d__[1] = a[i__1].r;
315 }
316 else
317 {
318 /* Reduce the lower triangle of A */
319 i__1 = a_dim1 + 1;
320 i__2 = a_dim1 + 1;
321 r__1 = a[i__2].r;
322 a[i__1].r = r__1;
323 a[i__1].i = 0.f; // , expr subst
324 i__1 = *n - 1;
325 for (i__ = 1;
326 i__ <= i__1;
327 ++i__)
328 {
329 /* Generate elementary reflector H(i) = I - tau * v * v**H */
330 /* to annihilate A(i+2:n,i) */
331 i__2 = i__ + 1 + i__ * a_dim1;
332 alpha.r = a[i__2].r;
333 alpha.i = a[i__2].i; // , expr subst
334 i__2 = *n - i__;
335 /* Computing MIN */
336 i__3 = i__ + 2;
337 clarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, & taui);
338 i__2 = i__;
339 e[i__2] = alpha.r;
340 if (taui.r != 0.f || taui.i != 0.f)
341 {
342 /* Apply H(i) from both sides to A(i+1:n,i+1:n) */
343 i__2 = i__ + 1 + i__ * a_dim1;
344 a[i__2].r = 1.f;
345 a[i__2].i = 0.f; // , expr subst
346 /* Compute x := tau * A * v storing y in TAU(i:n-1) */
347 i__2 = *n - i__;
348 chemv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b2, &tau[ i__], &c__1);
349 /* Compute w := x - 1/2 * tau * (x**H * v) * v */
350 q__3.r = -.5f;
351 q__3.i = -0.f; // , expr subst
352 q__2.r = q__3.r * taui.r - q__3.i * taui.i;
353 q__2.i = q__3.r * taui.i + q__3.i * taui.r; // , expr subst
354 i__2 = *n - i__;
355 cdotc_f2c_(&q__4, &i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
356 q__1.r = q__2.r * q__4.r - q__2.i * q__4.i;
357 q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; // , expr subst
358 alpha.r = q__1.r;
359 alpha.i = q__1.i; // , expr subst
360 i__2 = *n - i__;
361 caxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ i__], &c__1);
362 /* Apply the transformation as a rank-2 update: */
363 /* A := A - v * w**H - w * v**H */
364 i__2 = *n - i__;
365 q__1.r = -1.f;
366 q__1.i = -0.f; // , expr subst
367 cher2_(uplo, &i__2, &q__1, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda);
368 }
369 else
370 {
371 i__2 = i__ + 1 + (i__ + 1) * a_dim1;
372 i__3 = i__ + 1 + (i__ + 1) * a_dim1;
373 r__1 = a[i__3].r;
374 a[i__2].r = r__1;
375 a[i__2].i = 0.f; // , expr subst
376 }
377 i__2 = i__ + 1 + i__ * a_dim1;
378 i__3 = i__;
379 a[i__2].r = e[i__3];
380 a[i__2].i = 0.f; // , expr subst
381 i__2 = i__;
382 i__3 = i__ + i__ * a_dim1;
383 d__[i__2] = a[i__3].r;
384 i__2 = i__;
385 tau[i__2].r = taui.r;
386 tau[i__2].i = taui.i; // , expr subst
387 /* L20: */
388 }
389 i__1 = *n;
390 i__2 = *n + *n * a_dim1;
391 d__[i__1] = a[i__2].r;
392 }
393 return 0;
394 /* End of CHETD2 */
395}
int integer
Definition FLA_f2c.h:25
int logical
Definition FLA_f2c.h:36
float real
Definition FLA_f2c.h:30
int i
Definition bl1_axmyv2.c:145
Definition FLA_f2c.h:32

References i.

Referenced by chetrd_fla().