libflame revision_anchor
Functions
zhetd2.c File Reference

(r)

Functions

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

Function Documentation

◆ zhetd2_fla()

int zhetd2_fla ( char *  uplo,
integer *  n,
doublecomplex *  a,
integer *  lda,
doublereal *  d__,
doublereal *  e,
doublecomplex *  tau,
integer *  info 
)
175{
176 /* System generated locals */
177 integer a_dim1, a_offset, i__1, i__2, i__3;
178 doublereal d__1;
179 doublecomplex z__1, z__2, z__3, z__4;
180 /* Local variables */
181 integer i__;
182 doublecomplex taui;
183 extern /* Subroutine */
184 int zher2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
185 doublecomplex alpha;
186 extern logical lsame_(char *, char *);
187 extern /* Double Complex */
188 VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
189 extern /* Subroutine */
190 int zhemv_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *);
191 logical upper;
192 extern /* Subroutine */
193 int zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_( char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *);
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_("ZHETD2", &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 d__1 = a[i__2].r;
254 a[i__1].r = d__1;
255 a[i__1].i = 0.; // , 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 zlarfg_(&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. || taui.i != 0.)
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.;
273 a[i__1].i = 0.; // , expr subst
274 /* Compute x := tau * A * v storing x in TAU(1:i) */
275 zhemv_(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 z__3.r = -.5;
278 z__3.i = -0.; // , expr subst
279 z__2.r = z__3.r * taui.r - z__3.i * taui.i;
280 z__2.i = z__3.r * taui.i + z__3.i * taui.r; // , expr subst
281 zdotc_f2c_(&z__4, &i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1] , &c__1);
282 z__1.r = z__2.r * z__4.r - z__2.i * z__4.i;
283 z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; // , expr subst
284 alpha.r = z__1.r;
285 alpha.i = z__1.i; // , expr subst
286 zaxpy_(&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 z__1.r = -1.;
290 z__1.i = -0.; // , expr subst
291 zher2_(uplo, &i__, &z__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 d__1 = a[i__2].r;
298 a[i__1].r = d__1;
299 a[i__1].i = 0.; // , 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.; // , 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 d__1 = a[i__2].r;
322 a[i__1].r = d__1;
323 a[i__1].i = 0.; // , 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 zlarfg_(&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. || taui.i != 0.)
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.;
345 a[i__2].i = 0.; // , expr subst
346 /* Compute x := tau * A * v storing y in TAU(i:n-1) */
347 i__2 = *n - i__;
348 zhemv_(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 z__3.r = -.5;
351 z__3.i = -0.; // , expr subst
352 z__2.r = z__3.r * taui.r - z__3.i * taui.i;
353 z__2.i = z__3.r * taui.i + z__3.i * taui.r; // , expr subst
354 i__2 = *n - i__;
355 zdotc_f2c_(&z__4, &i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
356 z__1.r = z__2.r * z__4.r - z__2.i * z__4.i;
357 z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; // , expr subst
358 alpha.r = z__1.r;
359 alpha.i = z__1.i; // , expr subst
360 i__2 = *n - i__;
361 zaxpy_(&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 z__1.r = -1.;
366 z__1.i = -0.; // , expr subst
367 zher2_(uplo, &i__2, &z__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 d__1 = a[i__3].r;
374 a[i__2].r = d__1;
375 a[i__2].i = 0.; // , 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.; // , 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 ZHETD2 */
395}
doublereal
double doublereal
Definition FLA_f2c.h:31
integer
int integer
Definition FLA_f2c.h:25
logical
int logical
Definition FLA_f2c.h:36
i
int i
Definition bl1_axmyv2.c:145
doublecomplex
Definition FLA_f2c.h:33

References i.

Referenced by zhetrd_fla().

Generated on Thu Sep 23 2021 17:46:17 for libflame by doxygen 1.9.8