161
162
163
164
165
166
167 CHARACTER UPLO, VECT
168 INTEGER INFO, KD, LDAB, LDQ, N
169
170
171 DOUBLE PRECISION D( * ), E( * )
172 COMPLEX*16 AB( LDAB, * ), Q( LDQ, * ), WORK( * )
173
174
175
176
177
178 DOUBLE PRECISION ZERO
179 parameter( zero = 0.0d+0 )
180 COMPLEX*16 CZERO, CONE
181 parameter( czero = ( 0.0d+0, 0.0d+0 ),
182 $ cone = ( 1.0d+0, 0.0d+0 ) )
183
184
185 LOGICAL INITQ, UPPER, WANTQ
186 INTEGER I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
187 $ J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1,
188 $ KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
189 DOUBLE PRECISION ABST
190 COMPLEX*16 T, TEMP
191
192
196
197
198 INTRINSIC abs, dble, dconjg, max, min
199
200
201 LOGICAL LSAME
203
204
205
206
207
208 initq =
lsame( vect,
'V' )
209 wantq = initq .OR.
lsame( vect,
'U' )
210 upper =
lsame( uplo,
'U' )
211 kd1 = kd + 1
212 kdm1 = kd - 1
213 incx = ldab - 1
214 iqend = 1
215
216 info = 0
217 IF( .NOT.wantq .AND. .NOT.
lsame( vect,
'N' ) )
THEN
218 info = -1
219 ELSE IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
220 info = -2
221 ELSE IF( n.LT.0 ) THEN
222 info = -3
223 ELSE IF( kd.LT.0 ) THEN
224 info = -4
225 ELSE IF( ldab.LT.kd1 ) THEN
226 info = -6
227 ELSE IF( ldq.LT.max( 1, n ) .AND. wantq ) THEN
228 info = -10
229 END IF
230 IF( info.NE.0 ) THEN
231 CALL xerbla(
'ZHBTRD', -info )
232 RETURN
233 END IF
234
235
236
237 IF( n.EQ.0 )
238 $ RETURN
239
240
241
242 IF( initq )
243 $
CALL zlaset(
'Full', n, n, czero, cone, q, ldq )
244
245
246
247
248
249
250
251 inca = kd1*ldab
252 kdn = min( n-1, kd )
253 IF( upper ) THEN
254
255 IF( kd.GT.1 ) THEN
256
257
258
259
260 nr = 0
261 j1 = kdn + 2
262 j2 = 1
263
264 ab( kd1, 1 ) = dble( ab( kd1, 1 ) )
265 DO 90 i = 1, n - 2
266
267
268
269 DO 80 k = kdn + 1, 2, -1
270 j1 = j1 + kdn
271 j2 = j2 + kdn
272
273 IF( nr.GT.0 ) THEN
274
275
276
277
278 CALL zlargv( nr, ab( 1, j1-1 ), inca,
279 $ work( j1 ),
280 $ kd1, d( j1 ), kd1 )
281
282
283
284
285
286
287
288 IF( nr.GE.2*kd-1 ) THEN
289 DO 10 l = 1, kd - 1
290 CALL zlartv( nr, ab( l+1, j1-1 ), inca,
291 $ ab( l, j1 ), inca, d( j1 ),
292 $ work( j1 ), kd1 )
293 10 CONTINUE
294
295 ELSE
296 jend = j1 + ( nr-1 )*kd1
297 DO 20 jinc = j1, jend, kd1
298 CALL zrot( kdm1, ab( 2, jinc-1 ), 1,
299 $ ab( 1, jinc ), 1, d( jinc ),
300 $ work( jinc ) )
301 20 CONTINUE
302 END IF
303 END IF
304
305
306 IF( k.GT.2 ) THEN
307 IF( k.LE.n-i+1 ) THEN
308
309
310
311
312 CALL zlartg( ab( kd-k+3, i+k-2 ),
313 $ ab( kd-k+2, i+k-1 ), d( i+k-1 ),
314 $ work( i+k-1 ), temp )
315 ab( kd-k+3, i+k-2 ) = temp
316
317
318
319 CALL zrot( k-3, ab( kd-k+4, i+k-2 ), 1,
320 $ ab( kd-k+3, i+k-1 ), 1, d( i+k-1 ),
321 $ work( i+k-1 ) )
322 END IF
323 nr = nr + 1
324 j1 = j1 - kdn - 1
325 END IF
326
327
328
329
330 IF( nr.GT.0 )
331 $
CALL zlar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),
332 $ ab( kd, j1 ), inca, d( j1 ),
333 $ work( j1 ), kd1 )
334
335
336
337 IF( nr.GT.0 ) THEN
338 CALL zlacgv( nr, work( j1 ), kd1 )
339 IF( 2*kd-1.LT.nr ) THEN
340
341
342
343
344 DO 30 l = 1, kd - 1
345 IF( j2+l.GT.n ) THEN
346 nrt = nr - 1
347 ELSE
348 nrt = nr
349 END IF
350 IF( nrt.GT.0 )
351 $
CALL zlartv( nrt, ab( kd-l, j1+l ),
352 $ inca,
353 $ ab( kd-l+1, j1+l ), inca,
354 $ d( j1 ), work( j1 ), kd1 )
355 30 CONTINUE
356 ELSE
357 j1end = j1 + kd1*( nr-2 )
358 IF( j1end.GE.j1 ) THEN
359 DO 40 jin = j1, j1end, kd1
360 CALL zrot( kd-1, ab( kd-1, jin+1 ),
361 $ incx,
362 $ ab( kd, jin+1 ), incx,
363 $ d( jin ), work( jin ) )
364 40 CONTINUE
365 END IF
366 lend = min( kdm1, n-j2 )
367 last = j1end + kd1
368 IF( lend.GT.0 )
369 $
CALL zrot( lend, ab( kd-1, last+1 ), incx,
370 $ ab( kd, last+1 ), incx, d( last ),
371 $ work( last ) )
372 END IF
373 END IF
374
375 IF( wantq ) THEN
376
377
378
379 IF( initq ) THEN
380
381
382
383
384 iqend = max( iqend, j2 )
385 i2 = max( 0, k-3 )
386 iqaend = 1 + i*kd
387 IF( k.EQ.2 )
388 $ iqaend = iqaend + kd
389 iqaend = min( iqaend, iqend )
390 DO 50 j = j1, j2, kd1
391 ibl = i - i2 / kdm1
392 i2 = i2 + 1
393 iqb = max( 1, j-ibl )
394 nq = 1 + iqaend - iqb
395 iqaend = min( iqaend+kd, iqend )
396 CALL zrot( nq, q( iqb, j-1 ), 1, q( iqb,
397 $ j ),
398 $ 1, d( j ), dconjg( work( j ) ) )
399 50 CONTINUE
400 ELSE
401
402 DO 60 j = j1, j2, kd1
403 CALL zrot( n, q( 1, j-1 ), 1, q( 1, j ),
404 $ 1,
405 $ d( j ), dconjg( work( j ) ) )
406 60 CONTINUE
407 END IF
408
409 END IF
410
411 IF( j2+kdn.GT.n ) THEN
412
413
414
415 nr = nr - 1
416 j2 = j2 - kdn - 1
417 END IF
418
419 DO 70 j = j1, j2, kd1
420
421
422
423
424 work( j+kd ) = work( j )*ab( 1, j+kd )
425 ab( 1, j+kd ) = d( j )*ab( 1, j+kd )
426 70 CONTINUE
427 80 CONTINUE
428 90 CONTINUE
429 END IF
430
431 IF( kd.GT.0 ) THEN
432
433
434
435 DO 100 i = 1, n - 1
436 t = ab( kd, i+1 )
437 abst = abs( t )
438 ab( kd, i+1 ) = abst
439 e( i ) = abst
440 IF( abst.NE.zero ) THEN
441 t = t / abst
442 ELSE
443 t = cone
444 END IF
445 IF( i.LT.n-1 )
446 $ ab( kd, i+2 ) = ab( kd, i+2 )*t
447 IF( wantq ) THEN
448 CALL zscal( n, dconjg( t ), q( 1, i+1 ), 1 )
449 END IF
450 100 CONTINUE
451 ELSE
452
453
454
455 DO 110 i = 1, n - 1
456 e( i ) = zero
457 110 CONTINUE
458 END IF
459
460
461
462 DO 120 i = 1, n
463 d( i ) = dble( ab( kd1, i ) )
464 120 CONTINUE
465
466 ELSE
467
468 IF( kd.GT.1 ) THEN
469
470
471
472
473 nr = 0
474 j1 = kdn + 2
475 j2 = 1
476
477 ab( 1, 1 ) = dble( ab( 1, 1 ) )
478 DO 210 i = 1, n - 2
479
480
481
482 DO 200 k = kdn + 1, 2, -1
483 j1 = j1 + kdn
484 j2 = j2 + kdn
485
486 IF( nr.GT.0 ) THEN
487
488
489
490
491 CALL zlargv( nr, ab( kd1, j1-kd1 ), inca,
492 $ work( j1 ), kd1, d( j1 ), kd1 )
493
494
495
496
497
498
499
500 IF( nr.GT.2*kd-1 ) THEN
501 DO 130 l = 1, kd - 1
502 CALL zlartv( nr, ab( kd1-l, j1-kd1+l ),
503 $ inca,
504 $ ab( kd1-l+1, j1-kd1+l ), inca,
505 $ d( j1 ), work( j1 ), kd1 )
506 130 CONTINUE
507 ELSE
508 jend = j1 + kd1*( nr-1 )
509 DO 140 jinc = j1, jend, kd1
510 CALL zrot( kdm1, ab( kd, jinc-kd ), incx,
511 $ ab( kd1, jinc-kd ), incx,
512 $ d( jinc ), work( jinc ) )
513 140 CONTINUE
514 END IF
515
516 END IF
517
518 IF( k.GT.2 ) THEN
519 IF( k.LE.n-i+1 ) THEN
520
521
522
523
524 CALL zlartg( ab( k-1, i ), ab( k, i ),
525 $ d( i+k-1 ), work( i+k-1 ), temp )
526 ab( k-1, i ) = temp
527
528
529
530 CALL zrot( k-3, ab( k-2, i+1 ), ldab-1,
531 $ ab( k-1, i+1 ), ldab-1, d( i+k-1 ),
532 $ work( i+k-1 ) )
533 END IF
534 nr = nr + 1
535 j1 = j1 - kdn - 1
536 END IF
537
538
539
540
541 IF( nr.GT.0 )
542 $
CALL zlar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),
543 $ ab( 2, j1-1 ), inca, d( j1 ),
544 $ work( j1 ), kd1 )
545
546
547
548
549
550
551
552 IF( nr.GT.0 ) THEN
553 CALL zlacgv( nr, work( j1 ), kd1 )
554 IF( nr.GT.2*kd-1 ) THEN
555 DO 150 l = 1, kd - 1
556 IF( j2+l.GT.n ) THEN
557 nrt = nr - 1
558 ELSE
559 nrt = nr
560 END IF
561 IF( nrt.GT.0 )
562 $
CALL zlartv( nrt, ab( l+2, j1-1 ),
563 $ inca,
564 $ ab( l+1, j1 ), inca, d( j1 ),
565 $ work( j1 ), kd1 )
566 150 CONTINUE
567 ELSE
568 j1end = j1 + kd1*( nr-2 )
569 IF( j1end.GE.j1 ) THEN
570 DO 160 j1inc = j1, j1end, kd1
571 CALL zrot( kdm1, ab( 3, j1inc-1 ), 1,
572 $ ab( 2, j1inc ), 1, d( j1inc ),
573 $ work( j1inc ) )
574 160 CONTINUE
575 END IF
576 lend = min( kdm1, n-j2 )
577 last = j1end + kd1
578 IF( lend.GT.0 )
579 $
CALL zrot( lend, ab( 3, last-1 ), 1,
580 $ ab( 2, last ), 1, d( last ),
581 $ work( last ) )
582 END IF
583 END IF
584
585
586
587 IF( wantq ) THEN
588
589
590
591 IF( initq ) THEN
592
593
594
595
596 iqend = max( iqend, j2 )
597 i2 = max( 0, k-3 )
598 iqaend = 1 + i*kd
599 IF( k.EQ.2 )
600 $ iqaend = iqaend + kd
601 iqaend = min( iqaend, iqend )
602 DO 170 j = j1, j2, kd1
603 ibl = i - i2 / kdm1
604 i2 = i2 + 1
605 iqb = max( 1, j-ibl )
606 nq = 1 + iqaend - iqb
607 iqaend = min( iqaend+kd, iqend )
608 CALL zrot( nq, q( iqb, j-1 ), 1, q( iqb,
609 $ j ),
610 $ 1, d( j ), work( j ) )
611 170 CONTINUE
612 ELSE
613
614 DO 180 j = j1, j2, kd1
615 CALL zrot( n, q( 1, j-1 ), 1, q( 1, j ),
616 $ 1,
617 $ d( j ), work( j ) )
618 180 CONTINUE
619 END IF
620 END IF
621
622 IF( j2+kdn.GT.n ) THEN
623
624
625
626 nr = nr - 1
627 j2 = j2 - kdn - 1
628 END IF
629
630 DO 190 j = j1, j2, kd1
631
632
633
634
635 work( j+kd ) = work( j )*ab( kd1, j )
636 ab( kd1, j ) = d( j )*ab( kd1, j )
637 190 CONTINUE
638 200 CONTINUE
639 210 CONTINUE
640 END IF
641
642 IF( kd.GT.0 ) THEN
643
644
645
646 DO 220 i = 1, n - 1
647 t = ab( 2, i )
648 abst = abs( t )
649 ab( 2, i ) = abst
650 e( i ) = abst
651 IF( abst.NE.zero ) THEN
652 t = t / abst
653 ELSE
654 t = cone
655 END IF
656 IF( i.LT.n-1 )
657 $ ab( 2, i+1 ) = ab( 2, i+1 )*t
658 IF( wantq ) THEN
659 CALL zscal( n, t, q( 1, i+1 ), 1 )
660 END IF
661 220 CONTINUE
662 ELSE
663
664
665
666 DO 230 i = 1, n - 1
667 e( i ) = zero
668 230 CONTINUE
669 END IF
670
671
672
673 DO 240 i = 1, n
674 d( i ) = dble( ab( 1, i ) )
675 240 CONTINUE
676 END IF
677
678 RETURN
679
680
681
subroutine xerbla(srname, info)
subroutine zlacgv(n, x, incx)
ZLACGV conjugates a complex vector.
subroutine zlar2v(n, x, y, z, incx, c, s, incc)
ZLAR2V applies a vector of plane rotations with real cosines and complex sines from both sides to a s...
subroutine zlargv(n, x, incx, y, incy, c, incc)
ZLARGV generates a vector of plane rotations with real cosines and complex sines.
subroutine zlartg(f, g, c, s, r)
ZLARTG generates a plane rotation with real cosine and complex sine.
subroutine zlartv(n, x, incx, y, incy, c, s, incc)
ZLARTV applies a vector of plane rotations with real cosines and complex sines to the elements of a p...
subroutine zlaset(uplo, m, n, alpha, beta, a, lda)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
logical function lsame(ca, cb)
LSAME
subroutine zrot(n, cx, incx, cy, incy, c, s)
ZROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors.
subroutine zscal(n, za, zx, incx)
ZSCAL