243
244
245
246
247
248
249 CHARACTER DIAG, NORMIN, TRANS, UPLO
250 INTEGER INFO, KD, LDAB, N
251 REAL SCALE
252
253
254 REAL CNORM( * )
255 COMPLEX AB( LDAB, * ), X( * )
256
257
258
259
260
261 REAL ZERO, HALF, ONE, TWO
262 parameter( zero = 0.0e+0, half = 0.5e+0, one = 1.0e+0,
263 $ two = 2.0e+0 )
264
265
266 LOGICAL NOTRAN, NOUNIT, UPPER
267 INTEGER I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND
268 REAL BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
269 $ XBND, XJ, XMAX
270 COMPLEX CSUMJ, TJJS, USCAL, ZDUM
271
272
273 LOGICAL LSAME
274 INTEGER ICAMAX, ISAMAX
275 REAL SCASUM, SLAMCH
276 COMPLEX CDOTC, CDOTU, CLADIV
279
280
282
283
284 INTRINSIC abs, aimag, cmplx, conjg, max, min, real
285
286
287 REAL CABS1, CABS2
288
289
290 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
291 cabs2( zdum ) = abs( real( zdum ) / 2. ) +
292 $ abs( aimag( zdum ) / 2. )
293
294
295
296 info = 0
297 upper =
lsame( uplo,
'U' )
298 notran =
lsame( trans,
'N' )
299 nounit =
lsame( diag,
'N' )
300
301
302
303 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
304 info = -1
305 ELSE IF( .NOT.notran .AND. .NOT.
lsame( trans,
'T' ) .AND. .NOT.
306 $
lsame( trans,
'C' ) )
THEN
307 info = -2
308 ELSE IF( .NOT.nounit .AND. .NOT.
lsame( diag,
'U' ) )
THEN
309 info = -3
310 ELSE IF( .NOT.
lsame( normin,
'Y' ) .AND. .NOT.
311 $
lsame( normin,
'N' ) )
THEN
312 info = -4
313 ELSE IF( n.LT.0 ) THEN
314 info = -5
315 ELSE IF( kd.LT.0 ) THEN
316 info = -6
317 ELSE IF( ldab.LT.kd+1 ) THEN
318 info = -8
319 END IF
320 IF( info.NE.0 ) THEN
321 CALL xerbla(
'CLATBS', -info )
322 RETURN
323 END IF
324
325
326
327 scale = one
328 IF( n.EQ.0 )
329 $ RETURN
330
331
332
333 smlnum =
slamch(
'Safe minimum' ) /
slamch(
'Precision' )
334 bignum = one / smlnum
335
336 IF(
lsame( normin,
'N' ) )
THEN
337
338
339
340 IF( upper ) THEN
341
342
343
344 DO 10 j = 1, n
345 jlen = min( kd, j-1 )
346 cnorm( j ) =
scasum( jlen, ab( kd+1-jlen, j ), 1 )
347 10 CONTINUE
348 ELSE
349
350
351
352 DO 20 j = 1, n
353 jlen = min( kd, n-j )
354 IF( jlen.GT.0 ) THEN
355 cnorm( j ) =
scasum( jlen, ab( 2, j ), 1 )
356 ELSE
357 cnorm( j ) = zero
358 END IF
359 20 CONTINUE
360 END IF
361 END IF
362
363
364
365
366 imax =
isamax( n, cnorm, 1 )
367 tmax = cnorm( imax )
368 IF( tmax.LE.bignum*half ) THEN
369 tscal = one
370 ELSE
371 tscal = half / ( smlnum*tmax )
372 CALL sscal( n, tscal, cnorm, 1 )
373 END IF
374
375
376
377
378 xmax = zero
379 DO 30 j = 1, n
380 xmax = max( xmax, cabs2( x( j ) ) )
381 30 CONTINUE
382 xbnd = xmax
383 IF( notran ) THEN
384
385
386
387 IF( upper ) THEN
388 jfirst = n
389 jlast = 1
390 jinc = -1
391 maind = kd + 1
392 ELSE
393 jfirst = 1
394 jlast = n
395 jinc = 1
396 maind = 1
397 END IF
398
399 IF( tscal.NE.one ) THEN
400 grow = zero
401 GO TO 60
402 END IF
403
404 IF( nounit ) THEN
405
406
407
408
409
410
411 grow = half / max( xbnd, smlnum )
412 xbnd = grow
413 DO 40 j = jfirst, jlast, jinc
414
415
416
417 IF( grow.LE.smlnum )
418 $ GO TO 60
419
420 tjjs = ab( maind, j )
421 tjj = cabs1( tjjs )
422
423 IF( tjj.GE.smlnum ) THEN
424
425
426
427 xbnd = min( xbnd, min( one, tjj )*grow )
428 ELSE
429
430
431
432 xbnd = zero
433 END IF
434
435 IF( tjj+cnorm( j ).GE.smlnum ) THEN
436
437
438
439 grow = grow*( tjj / ( tjj+cnorm( j ) ) )
440 ELSE
441
442
443
444 grow = zero
445 END IF
446 40 CONTINUE
447 grow = xbnd
448 ELSE
449
450
451
452
453
454 grow = min( one, half / max( xbnd, smlnum ) )
455 DO 50 j = jfirst, jlast, jinc
456
457
458
459 IF( grow.LE.smlnum )
460 $ GO TO 60
461
462
463
464 grow = grow*( one / ( one+cnorm( j ) ) )
465 50 CONTINUE
466 END IF
467 60 CONTINUE
468
469 ELSE
470
471
472
473 IF( upper ) THEN
474 jfirst = 1
475 jlast = n
476 jinc = 1
477 maind = kd + 1
478 ELSE
479 jfirst = n
480 jlast = 1
481 jinc = -1
482 maind = 1
483 END IF
484
485 IF( tscal.NE.one ) THEN
486 grow = zero
487 GO TO 90
488 END IF
489
490 IF( nounit ) THEN
491
492
493
494
495
496
497 grow = half / max( xbnd, smlnum )
498 xbnd = grow
499 DO 70 j = jfirst, jlast, jinc
500
501
502
503 IF( grow.LE.smlnum )
504 $ GO TO 90
505
506
507
508 xj = one + cnorm( j )
509 grow = min( grow, xbnd / xj )
510
511 tjjs = ab( maind, j )
512 tjj = cabs1( tjjs )
513
514 IF( tjj.GE.smlnum ) THEN
515
516
517
518 IF( xj.GT.tjj )
519 $ xbnd = xbnd*( tjj / xj )
520 ELSE
521
522
523
524 xbnd = zero
525 END IF
526 70 CONTINUE
527 grow = min( grow, xbnd )
528 ELSE
529
530
531
532
533
534 grow = min( one, half / max( xbnd, smlnum ) )
535 DO 80 j = jfirst, jlast, jinc
536
537
538
539 IF( grow.LE.smlnum )
540 $ GO TO 90
541
542
543
544 xj = one + cnorm( j )
545 grow = grow / xj
546 80 CONTINUE
547 END IF
548 90 CONTINUE
549 END IF
550
551 IF( ( grow*tscal ).GT.smlnum ) THEN
552
553
554
555
556 CALL ctbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 )
557 ELSE
558
559
560
561 IF( xmax.GT.bignum*half ) THEN
562
563
564
565
566 scale = ( bignum*half ) / xmax
567 CALL csscal( n, scale, x, 1 )
568 xmax = bignum
569 ELSE
570 xmax = xmax*two
571 END IF
572
573 IF( notran ) THEN
574
575
576
577 DO 110 j = jfirst, jlast, jinc
578
579
580
581 xj = cabs1( x( j ) )
582 IF( nounit ) THEN
583 tjjs = ab( maind, j )*tscal
584 ELSE
585 tjjs = tscal
586 IF( tscal.EQ.one )
587 $ GO TO 105
588 END IF
589 tjj = cabs1( tjjs )
590 IF( tjj.GT.smlnum ) THEN
591
592
593
594 IF( tjj.LT.one ) THEN
595 IF( xj.GT.tjj*bignum ) THEN
596
597
598
599 rec = one / xj
600 CALL csscal( n, rec, x, 1 )
601 scale = scale*rec
602 xmax = xmax*rec
603 END IF
604 END IF
605 x( j ) =
cladiv( x( j ), tjjs )
606 xj = cabs1( x( j ) )
607 ELSE IF( tjj.GT.zero ) THEN
608
609
610
611 IF( xj.GT.tjj*bignum ) THEN
612
613
614
615
616 rec = ( tjj*bignum ) / xj
617 IF( cnorm( j ).GT.one ) THEN
618
619
620
621
622 rec = rec / cnorm( j )
623 END IF
624 CALL csscal( n, rec, x, 1 )
625 scale = scale*rec
626 xmax = xmax*rec
627 END IF
628 x( j ) =
cladiv( x( j ), tjjs )
629 xj = cabs1( x( j ) )
630 ELSE
631
632
633
634
635 DO 100 i = 1, n
636 x( i ) = zero
637 100 CONTINUE
638 x( j ) = one
639 xj = one
640 scale = zero
641 xmax = zero
642 END IF
643 105 CONTINUE
644
645
646
647
648 IF( xj.GT.one ) THEN
649 rec = one / xj
650 IF( cnorm( j ).GT.( bignum-xmax )*rec ) THEN
651
652
653
654 rec = rec*half
655 CALL csscal( n, rec, x, 1 )
656 scale = scale*rec
657 END IF
658 ELSE IF( xj*cnorm( j ).GT.( bignum-xmax ) ) THEN
659
660
661
662 CALL csscal( n, half, x, 1 )
663 scale = scale*half
664 END IF
665
666 IF( upper ) THEN
667 IF( j.GT.1 ) THEN
668
669
670
671
672
673 jlen = min( kd, j-1 )
674 CALL caxpy( jlen, -x( j )*tscal,
675 $ ab( kd+1-jlen, j ), 1, x( j-jlen ), 1 )
677 xmax = cabs1( x( i ) )
678 END IF
679 ELSE IF( j.LT.n ) THEN
680
681
682
683
684
685 jlen = min( kd, n-j )
686 IF( jlen.GT.0 )
687 $
CALL caxpy( jlen, -x( j )*tscal, ab( 2, j ), 1,
688 $ x( j+1 ), 1 )
689 i = j +
icamax( n-j, x( j+1 ), 1 )
690 xmax = cabs1( x( i ) )
691 END IF
692 110 CONTINUE
693
694 ELSE IF(
lsame( trans,
'T' ) )
THEN
695
696
697
698 DO 150 j = jfirst, jlast, jinc
699
700
701
702
703 xj = cabs1( x( j ) )
704 uscal = tscal
705 rec = one / max( xmax, one )
706 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
707
708
709
710 rec = rec*half
711 IF( nounit ) THEN
712 tjjs = ab( maind, j )*tscal
713 ELSE
714 tjjs = tscal
715 END IF
716 tjj = cabs1( tjjs )
717 IF( tjj.GT.one ) THEN
718
719
720
721 rec = min( one, rec*tjj )
722 uscal =
cladiv( uscal, tjjs )
723 END IF
724 IF( rec.LT.one ) THEN
725 CALL csscal( n, rec, x, 1 )
726 scale = scale*rec
727 xmax = xmax*rec
728 END IF
729 END IF
730
731 csumj = zero
732 IF( uscal.EQ.cmplx( one ) ) THEN
733
734
735
736
737 IF( upper ) THEN
738 jlen = min( kd, j-1 )
739 csumj =
cdotu( jlen, ab( kd+1-jlen, j ), 1,
740 $ x( j-jlen ), 1 )
741 ELSE
742 jlen = min( kd, n-j )
743 IF( jlen.GT.1 )
744 $ csumj =
cdotu( jlen, ab( 2, j ), 1, x( j+1 ),
745 $ 1 )
746 END IF
747 ELSE
748
749
750
751 IF( upper ) THEN
752 jlen = min( kd, j-1 )
753 DO 120 i = 1, jlen
754 csumj = csumj + ( ab( kd+i-jlen, j )*uscal )*
755 $ x( j-jlen-1+i )
756 120 CONTINUE
757 ELSE
758 jlen = min( kd, n-j )
759 DO 130 i = 1, jlen
760 csumj = csumj + ( ab( i+1, j )*uscal )*x( j+i )
761 130 CONTINUE
762 END IF
763 END IF
764
765 IF( uscal.EQ.cmplx( tscal ) ) THEN
766
767
768
769
770 x( j ) = x( j ) - csumj
771 xj = cabs1( x( j ) )
772 IF( nounit ) THEN
773
774
775
776 tjjs = ab( maind, j )*tscal
777 ELSE
778 tjjs = tscal
779 IF( tscal.EQ.one )
780 $ GO TO 145
781 END IF
782 tjj = cabs1( tjjs )
783 IF( tjj.GT.smlnum ) THEN
784
785
786
787 IF( tjj.LT.one ) THEN
788 IF( xj.GT.tjj*bignum ) THEN
789
790
791
792 rec = one / xj
793 CALL csscal( n, rec, x, 1 )
794 scale = scale*rec
795 xmax = xmax*rec
796 END IF
797 END IF
798 x( j ) =
cladiv( x( j ), tjjs )
799 ELSE IF( tjj.GT.zero ) THEN
800
801
802
803 IF( xj.GT.tjj*bignum ) THEN
804
805
806
807 rec = ( tjj*bignum ) / xj
808 CALL csscal( n, rec, x, 1 )
809 scale = scale*rec
810 xmax = xmax*rec
811 END IF
812 x( j ) =
cladiv( x( j ), tjjs )
813 ELSE
814
815
816
817
818 DO 140 i = 1, n
819 x( i ) = zero
820 140 CONTINUE
821 x( j ) = one
822 scale = zero
823 xmax = zero
824 END IF
825 145 CONTINUE
826 ELSE
827
828
829
830
831 x( j ) =
cladiv( x( j ), tjjs ) - csumj
832 END IF
833 xmax = max( xmax, cabs1( x( j ) ) )
834 150 CONTINUE
835
836 ELSE
837
838
839
840 DO 190 j = jfirst, jlast, jinc
841
842
843
844
845 xj = cabs1( x( j ) )
846 uscal = tscal
847 rec = one / max( xmax, one )
848 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
849
850
851
852 rec = rec*half
853 IF( nounit ) THEN
854 tjjs = conjg( ab( maind, j ) )*tscal
855 ELSE
856 tjjs = tscal
857 END IF
858 tjj = cabs1( tjjs )
859 IF( tjj.GT.one ) THEN
860
861
862
863 rec = min( one, rec*tjj )
864 uscal =
cladiv( uscal, tjjs )
865 END IF
866 IF( rec.LT.one ) THEN
867 CALL csscal( n, rec, x, 1 )
868 scale = scale*rec
869 xmax = xmax*rec
870 END IF
871 END IF
872
873 csumj = zero
874 IF( uscal.EQ.cmplx( one ) ) THEN
875
876
877
878
879 IF( upper ) THEN
880 jlen = min( kd, j-1 )
881 csumj =
cdotc( jlen, ab( kd+1-jlen, j ), 1,
882 $ x( j-jlen ), 1 )
883 ELSE
884 jlen = min( kd, n-j )
885 IF( jlen.GT.1 )
886 $ csumj =
cdotc( jlen, ab( 2, j ), 1, x( j+1 ),
887 $ 1 )
888 END IF
889 ELSE
890
891
892
893 IF( upper ) THEN
894 jlen = min( kd, j-1 )
895 DO 160 i = 1, jlen
896 csumj = csumj + ( conjg( ab( kd+i-jlen, j ) )*
897 $ uscal )*x( j-jlen-1+i )
898 160 CONTINUE
899 ELSE
900 jlen = min( kd, n-j )
901 DO 170 i = 1, jlen
902 csumj = csumj + ( conjg( ab( i+1, j ) )*uscal )*
903 $ x( j+i )
904 170 CONTINUE
905 END IF
906 END IF
907
908 IF( uscal.EQ.cmplx( tscal ) ) THEN
909
910
911
912
913 x( j ) = x( j ) - csumj
914 xj = cabs1( x( j ) )
915 IF( nounit ) THEN
916
917
918
919 tjjs = conjg( ab( maind, j ) )*tscal
920 ELSE
921 tjjs = tscal
922 IF( tscal.EQ.one )
923 $ GO TO 185
924 END IF
925 tjj = cabs1( tjjs )
926 IF( tjj.GT.smlnum ) THEN
927
928
929
930 IF( tjj.LT.one ) THEN
931 IF( xj.GT.tjj*bignum ) THEN
932
933
934
935 rec = one / xj
936 CALL csscal( n, rec, x, 1 )
937 scale = scale*rec
938 xmax = xmax*rec
939 END IF
940 END IF
941 x( j ) =
cladiv( x( j ), tjjs )
942 ELSE IF( tjj.GT.zero ) THEN
943
944
945
946 IF( xj.GT.tjj*bignum ) THEN
947
948
949
950 rec = ( tjj*bignum ) / xj
951 CALL csscal( n, rec, x, 1 )
952 scale = scale*rec
953 xmax = xmax*rec
954 END IF
955 x( j ) =
cladiv( x( j ), tjjs )
956 ELSE
957
958
959
960
961 DO 180 i = 1, n
962 x( i ) = zero
963 180 CONTINUE
964 x( j ) = one
965 scale = zero
966 xmax = zero
967 END IF
968 185 CONTINUE
969 ELSE
970
971
972
973
974 x( j ) =
cladiv( x( j ), tjjs ) - csumj
975 END IF
976 xmax = max( xmax, cabs1( x( j ) ) )
977 190 CONTINUE
978 END IF
979 scale = scale / tscal
980 END IF
981
982
983
984 IF( tscal.NE.one ) THEN
985 CALL sscal( n, one / tscal, cnorm, 1 )
986 END IF
987
988 RETURN
989
990
991
subroutine xerbla(srname, info)
real function scasum(n, cx, incx)
SCASUM
subroutine caxpy(n, ca, cx, incx, cy, incy)
CAXPY
complex function cdotu(n, cx, incx, cy, incy)
CDOTU
complex function cdotc(n, cx, incx, cy, incy)
CDOTC
integer function isamax(n, sx, incx)
ISAMAX
integer function icamax(n, cx, incx)
ICAMAX
complex function cladiv(x, y)
CLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
real function slamch(cmach)
SLAMCH
logical function lsame(ca, cb)
LSAME
subroutine csscal(n, sa, cx, incx)
CSSCAL
subroutine sscal(n, sa, sx, incx)
SSCAL
subroutine ctbsv(uplo, trans, diag, n, k, a, lda, x, incx)
CTBSV