240 SUBROUTINE dlatbs( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X,
241 $ SCALE, CNORM, INFO )
248 CHARACTER DIAG, NORMIN, TRANS, UPLO
249 INTEGER INFO, KD, LDAB, N
250 DOUBLE PRECISION SCALE
253 DOUBLE PRECISION AB( LDAB, * ), CNORM( * ), X( * )
259 DOUBLE PRECISION ZERO, HALF, ONE
260 parameter( zero = 0.0d+0, half = 0.5d+0, one = 1.0d+0 )
263 LOGICAL NOTRAN, NOUNIT, UPPER
264 INTEGER I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND
265 DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
266 $ tmax, tscal, uscal, xbnd, xj, xmax
271 DOUBLE PRECISION DASUM, DDOT, DLAMCH
272 EXTERNAL lsame, idamax, dasum, ddot, dlamch
278 INTRINSIC abs, max, min
283 upper = lsame( uplo,
'U' )
284 notran = lsame( trans,
'N' )
285 nounit = lsame( diag,
'N' )
289 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
291 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans,
'T' ) .AND. .NOT.
292 $ lsame( trans,
'C' ) )
THEN
294 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag,
'U' ) )
THEN
296 ELSE IF( .NOT.lsame( normin,
'Y' ) .AND. .NOT.
297 $ lsame( normin,
'N' ) )
THEN
299 ELSE IF( n.LT.0 )
THEN
301 ELSE IF( kd.LT.0 )
THEN
303 ELSE IF( ldab.LT.kd+1 )
THEN
307 CALL xerbla(
'DLATBS', -info )
319 smlnum = dlamch(
'Safe minimum' ) / dlamch(
'Precision' )
320 bignum = one / smlnum
322 IF( lsame( normin,
'N' ) )
THEN
331 jlen = min( kd, j-1 )
332 cnorm( j ) = dasum( jlen, ab( kd+1-jlen, j ), 1 )
339 jlen = min( kd, n-j )
341 cnorm( j ) = dasum( jlen, ab( 2, j ), 1 )
352 imax = idamax( n, cnorm, 1 )
354 IF( tmax.LE.bignum )
THEN
357 tscal = one / ( smlnum*tmax )
358 CALL dscal( n, tscal, cnorm, 1 )
364 j = idamax( n, x, 1 )
383 IF( tscal.NE.one )
THEN
395 grow = one / max( xbnd, smlnum )
397 DO 30 j = jfirst, jlast, jinc
406 tjj = abs( ab( maind, j ) )
407 xbnd = min( xbnd, min( one, tjj )*grow )
408 IF( tjj+cnorm( j ).GE.smlnum )
THEN
412 grow = grow*( tjj / ( tjj+cnorm( j ) ) )
427 grow = min( one, one / max( xbnd, smlnum ) )
428 DO 40 j = jfirst, jlast, jinc
437 grow = grow*( one / ( one+cnorm( j ) ) )
458 IF( tscal.NE.one )
THEN
470 grow = one / max( xbnd, smlnum )
472 DO 60 j = jfirst, jlast, jinc
481 xj = one + cnorm( j )
482 grow = min( grow, xbnd / xj )
486 tjj = abs( ab( maind, j ) )
488 $ xbnd = xbnd*( tjj / xj )
490 grow = min( grow, xbnd )
497 grow = min( one, one / max( xbnd, smlnum ) )
498 DO 70 j = jfirst, jlast, jinc
507 xj = one + cnorm( j )
514 IF( ( grow*tscal ).GT.smlnum )
THEN
519 CALL dtbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 )
524 IF( xmax.GT.bignum )
THEN
529 scale = bignum / xmax
530 CALL dscal( n, scale, x, 1 )
538 DO 110 j = jfirst, jlast, jinc
544 tjjs = ab( maind, j )*tscal
551 IF( tjj.GT.smlnum )
THEN
555 IF( tjj.LT.one )
THEN
556 IF( xj.GT.tjj*bignum )
THEN
561 CALL dscal( n, rec, x, 1 )
566 x( j ) = x( j ) / tjjs
568 ELSE IF( tjj.GT.zero )
THEN
572 IF( xj.GT.tjj*bignum )
THEN
577 rec = ( tjj*bignum ) / xj
578 IF( cnorm( j ).GT.one )
THEN
583 rec = rec / cnorm( j )
585 CALL dscal( n, rec, x, 1 )
589 x( j ) = x( j ) / tjjs
611 IF( cnorm( j ).GT.( bignum-xmax )*rec )
THEN
616 CALL dscal( n, rec, x, 1 )
619 ELSE IF( xj*cnorm( j ).GT.( bignum-xmax ) )
THEN
623 CALL dscal( n, half, x, 1 )
634 jlen = min( kd, j-1 )
635 CALL daxpy( jlen, -x( j )*tscal,
636 $ ab( kd+1-jlen, j ), 1, x( j-jlen ), 1 )
637 i = idamax( j-1, x, 1 )
640 ELSE IF( j.LT.n )
THEN
646 jlen = min( kd, n-j )
648 $
CALL daxpy( jlen, -x( j )*tscal, ab( 2, j ), 1,
650 i = j + idamax( n-j, x( j+1 ), 1 )
659 DO 160 j = jfirst, jlast, jinc
666 rec = one / max( xmax, one )
667 IF( cnorm( j ).GT.( bignum-xj )*rec )
THEN
673 tjjs = ab( maind, j )*tscal
678 IF( tjj.GT.one )
THEN
682 rec = min( one, rec*tjj )
685 IF( rec.LT.one )
THEN
686 CALL dscal( n, rec, x, 1 )
693 IF( uscal.EQ.one )
THEN
699 jlen = min( kd, j-1 )
700 sumj = ddot( jlen, ab( kd+1-jlen, j ), 1,
703 jlen = min( kd, n-j )
705 $ sumj = ddot( jlen, ab( 2, j ), 1, x( j+1 ), 1 )
712 jlen = min( kd, j-1 )
714 sumj = sumj + ( ab( kd+i-jlen, j )*uscal )*
718 jlen = min( kd, n-j )
720 sumj = sumj + ( ab( i+1, j )*uscal )*x( j+i )
725 IF( uscal.EQ.tscal )
THEN
730 x( j ) = x( j ) - sumj
736 tjjs = ab( maind, j )*tscal
743 IF( tjj.GT.smlnum )
THEN
747 IF( tjj.LT.one )
THEN
748 IF( xj.GT.tjj*bignum )
THEN
753 CALL dscal( n, rec, x, 1 )
758 x( j ) = x( j ) / tjjs
759 ELSE IF( tjj.GT.zero )
THEN
763 IF( xj.GT.tjj*bignum )
THEN
767 rec = ( tjj*bignum ) / xj
768 CALL dscal( n, rec, x, 1 )
772 x( j ) = x( j ) / tjjs
791 x( j ) = x( j ) / tjjs - sumj
793 xmax = max( xmax, abs( x( j ) ) )
796 scale = scale / tscal
801 IF( tscal.NE.one )
THEN
802 CALL dscal( n, one / tscal, cnorm, 1 )
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
subroutine dtbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
DTBSV
subroutine dlatbs(UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO)
DLATBS solves a triangular banded system of equations.