001:       REAL FUNCTION CLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X,
002:      $                             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, LDA, LDAF, INFO
017: *     ..
018: *     .. Array Arguments ..
019:       INTEGER            IPIV( * )
020:       COMPLEX            A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
021:       REAL               RWORK( * )
022: *
023: *     CLA_GERCOND_X computes the infinity norm condition number of
024: *     op(A) * diag(X) where X is a COMPLEX vector.
025: *     WORK is a COMPLEX workspace of size 2*N, and
026: *     RWORK is a REAL workspace of size 3*N.
027: *     ..
028: *     .. Local Scalars ..
029:       LOGICAL            NOTRANS
030:       INTEGER            KASE
031:       REAL               AINVNM, ANORM, TMP
032:       INTEGER            I, J
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, CGETRS, XERBLA
044: *     ..
045: *     .. Intrinsic Functions ..
046:       INTRINSIC          ABS, MAX, REAL, AIMAG
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_GERCOND_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_GERCOND_X', -INFO )
068:          RETURN
069:       END IF
070: *
071: *     Compute norm of op(A)*op2(C).
072: *
073:       ANORM = 0.0
074:       IF ( NOTRANS ) THEN
075:          DO I = 1, N
076:             TMP = 0.0E+0
077:             DO J = 1, N
078:                TMP = TMP + CABS1( A( I, J ) * X( J ) )
079:             END DO
080:             RWORK( 2*N+I ) = TMP
081:             ANORM = MAX( ANORM, TMP )
082:          END DO
083:       ELSE
084:          DO I = 1, N
085:             TMP = 0.0E+0
086:             DO J = 1, N
087:                TMP = TMP + CABS1( A( J, I ) * X( J ) )
088:             END DO
089:             RWORK( 2*N+I ) = TMP
090:             ANORM = MAX( ANORM, TMP )
091:          END DO
092:       END IF
093: *
094: *     Quick return if possible.
095: *
096:       IF( N.EQ.0 ) THEN
097:          CLA_GERCOND_X = 1.0E+0
098:          RETURN
099:       ELSE IF( ANORM .EQ. 0.0E+0 ) THEN
100:          RETURN
101:       END IF
102: *
103: *     Estimate the norm of inv(op(A)).
104: *
105:       AINVNM = 0.0E+0
106: *
107:       KASE = 0
108:    10 CONTINUE
109:       CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
110:       IF( KASE.NE.0 ) THEN
111:          IF( KASE.EQ.2 ) THEN
112: *           Multiply by R.
113:             DO I = 1, N
114:                WORK( I ) = WORK( I ) * RWORK( 2*N+I )
115:             END DO
116: *
117:             IF ( NOTRANS ) THEN
118:                CALL CGETRS( 'No transpose', N, 1, AF, LDAF, IPIV,
119:      $            WORK, N, INFO )
120:             ELSE
121:                CALL CGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV,
122:      $            WORK, N, INFO )
123:             ENDIF
124: *
125: *           Multiply by inv(X).
126: *
127:             DO I = 1, N
128:                WORK( I ) = WORK( I ) / X( I )
129:             END DO
130:          ELSE
131: *
132: *           Multiply by inv(X').
133: *
134:             DO I = 1, N
135:                WORK( I ) = WORK( I ) / X( I )
136:             END DO
137: *
138:             IF ( NOTRANS ) THEN
139:                CALL CGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV,
140:      $            WORK, N, INFO )
141:             ELSE
142:                CALL CGETRS( 'No transpose', N, 1, AF, LDAF, IPIV,
143:      $            WORK, N, INFO )
144:             END IF
145: *
146: *           Multiply by R.
147: *
148:             DO I = 1, N
149:                WORK( I ) = WORK( I ) * RWORK( 2*N+I )
150:             END DO
151:          END IF
152:          GO TO 10
153:       END IF
154: *
155: *     Compute the estimate of the reciprocal condition number.
156: *
157:       IF( AINVNM .NE. 0.0E+0 )
158:      $   CLA_GERCOND_X = 1.0E+0 / AINVNM
159: *
160:       RETURN
161: *
162:       END
163: