001:       REAL FUNCTION CLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB,
002:      $                             LDAFB, IPIV, X, INFO, WORK, RWORK )
003: *
004: *     -- LAPACK routine (version 3.2)                                 --
005: *     -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and --
006: *     -- Jason Riedy of Univ. of California Berkeley.                 --
007: *     -- November 2008                                                --
008: *
009: *     -- LAPACK is a software package provided by Univ. of Tennessee, --
010: *     -- Univ. of California Berkeley and NAG Ltd.                    --
011: *
012:       IMPLICIT NONE
013: *     ..
014: *     .. Scalar Arguments ..
015:       CHARACTER          TRANS
016:       INTEGER            N, KL, KU, KD, LDAB, LDAFB, INFO
017: *     ..
018: *     .. Array Arguments ..
019:       INTEGER            IPIV( * )
020:       COMPLEX            AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ),
021:      $                   X( * )
022:       REAL               RWORK( * )
023: *
024: *     CLA_GBRCOND_X Computes the infinity norm condition number of
025: *     op(A) * diag(X) where X is a COMPLEX vector.
026: *     WORK is a COMPLEX workspace of size 2*N, and
027: *     RWORK is a REAL workspace of size 3*N.
028: *     ..
029: *     .. Local Scalars ..
030:       LOGICAL            NOTRANS
031:       INTEGER            KASE, I, J
032:       REAL               AINVNM, ANORM, TMP
033:       COMPLEX            ZDUM
034: *     ..
035: *     .. Local Arrays ..
036:       INTEGER            ISAVE( 3 )
037: *     ..
038: *     .. External Functions ..
039:       LOGICAL            LSAME
040:       EXTERNAL           LSAME
041: *     ..
042: *     .. External Subroutines ..
043:       EXTERNAL           CLACN2, CGBTRS, XERBLA
044: *     ..
045: *     .. Intrinsic Functions ..
046:       INTRINSIC          ABS, MAX
047: *     ..
048: *     .. Statement Functions ..
049:       REAL               CABS1
050: *     ..
051: *     .. Statement Function Definitions ..
052:       CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
053: *     ..
054: *     .. Executable Statements ..
055: *
056:       CLA_GBRCOND_X = 0.0E+0
057: *
058:       INFO = 0
059:       NOTRANS = LSAME( TRANS, 'N' )
060:       IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') .AND. .NOT.
061:      $     LSAME( TRANS, 'C' ) ) THEN
062:          INFO = -1
063:       ELSE IF( N.LT.0 ) THEN
064:          INFO = -2
065:       END IF
066:       IF( INFO.NE.0 ) THEN
067:          CALL XERBLA( 'CLA_GBRCOND_X', -INFO )
068:          RETURN
069:       END IF
070: *
071: *     Compute norm of op(A)*op2(C).
072: *
073:       KD = KU + 1
074:       ANORM = 0.0
075:       IF ( NOTRANS ) THEN
076:          DO I = 1, N
077:             TMP = 0.0E+0
078:             DO J = 1, N
079:                IF ( I.GE.MAX( 1, J-KU ) .AND. I.LE.MIN( N, J+KL ) ) THEN
080:                   TMP = TMP + CABS1( AB( KD+I-J, J) * X( J ) )
081:                END IF
082:             END DO
083:             RWORK( 2*N+I ) = TMP
084:             ANORM = MAX( ANORM, TMP )
085:          END DO
086:       ELSE
087:          DO I = 1, N
088:             TMP = 0.0E+0
089:             DO J = 1, N
090:                IF ( I.GE.MAX( 1, J-KU ) .AND. I.LE.MIN( N, J+KL ) ) THEN
091:                   TMP = TMP + CABS1( AB( J, KD+I-J ) * X( J ) )
092:                END IF
093:             END DO
094:             RWORK( 2*N+I ) = TMP
095:             ANORM = MAX( ANORM, TMP )
096:          END DO
097:       END IF
098: *
099: *     Quick return if possible.
100: *
101:       IF( N.EQ.0 ) THEN
102:          CLA_GBRCOND_X = 1.0E+0
103:          RETURN
104:       ELSE IF( ANORM .EQ. 0.0E+0 ) THEN
105:          RETURN
106:       END IF
107: *
108: *     Estimate the norm of inv(op(A)).
109: *
110:       AINVNM = 0.0E+0
111: *
112:       KASE = 0
113:    10 CONTINUE
114:       CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
115:       IF( KASE.NE.0 ) THEN
116:          IF( KASE.EQ.2 ) THEN
117: *
118: *           Multiply by R.
119: *
120:             DO I = 1, N
121:                WORK( I ) = WORK( I ) * RWORK( 2*N+I )
122:             END DO
123: *
124:             IF ( NOTRANS ) THEN
125:                CALL CGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB,
126:      $              IPIV, WORK, N, INFO )
127:             ELSE
128:                CALL CGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB,
129:      $              LDAFB, IPIV, WORK, N, INFO )
130:             ENDIF
131: *
132: *           Multiply by inv(X).
133: *
134:             DO I = 1, N
135:                WORK( I ) = WORK( I ) / X( I )
136:             END DO
137:          ELSE
138: *
139: *           Multiply by inv(X').
140: *
141:             DO I = 1, N
142:                WORK( I ) = WORK( I ) / X( I )
143:             END DO
144: *
145:             IF ( NOTRANS ) THEN
146:                CALL CGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB,
147:      $              LDAFB, IPIV, WORK, N, INFO )
148:             ELSE
149:                CALL CGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB,
150:      $              IPIV, WORK, N, INFO )
151:             END IF
152: *
153: *           Multiply by R.
154: *
155:             DO I = 1, N
156:                WORK( I ) = WORK( I ) * RWORK( 2*N+I )
157:             END DO
158:          END IF
159:          GO TO 10
160:       END IF
161: *
162: *     Compute the estimate of the reciprocal condition number.
163: *
164:       IF( AINVNM .NE. 0.0E+0 )
165:      $   CLA_GBRCOND_X = 1.0E+0 / AINVNM
166: *
167:       RETURN
168: *
169:       END
170: