001:       DOUBLE PRECISION FUNCTION ZLA_HERCOND_X( UPLO, N, A, LDA, AF, 
002:      $                             LDAF, 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          UPLO
016:       INTEGER            N, LDA, LDAF, INFO
017: *     ..
018: *     .. Array Arguments ..
019:       INTEGER            IPIV( * )
020:       COMPLEX*16         A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
021:       DOUBLE PRECISION   RWORK( * )
022: *
023: *     ZLA_HERCOND_X computes the infinity norm condition number of
024: *     op(A) * diag(X) where X is a COMPLEX*16 vector.
025: *     WORK is a COMPLEX*16 workspace of size 2*N, and
026: *     RWORK is a DOUBLE PRECISION workspace of size 3*N.
027: *     ..
028: *     .. Local Scalars ..
029:       INTEGER            KASE, I, J
030:       DOUBLE PRECISION   AINVNM, ANORM, TMP
031:       LOGICAL            UP
032:       COMPLEX*16         ZDUM
033: *     ..
034: *     .. Local Arrays ..
035:       INTEGER            ISAVE( 3 )
036: *     ..
037: *     .. External Functions ..
038:       LOGICAL            LSAME
039:       EXTERNAL           LSAME
040: *     ..
041: *     .. External Subroutines ..
042:       EXTERNAL           ZLACN2, ZHETRS, XERBLA
043: *     ..
044: *     .. Intrinsic Functions ..
045:       INTRINSIC          ABS, MAX
046: *     ..
047: *     .. Statement Functions ..
048:       DOUBLE PRECISION CABS1
049: *     ..
050: *     .. Statement Function Definitions ..
051:       CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
052: *     ..
053: *     .. Executable Statements ..
054: *
055:       ZLA_HERCOND_X = 0.0D+0
056: *
057:       INFO = 0
058:       IF( N.LT.0 ) THEN
059:          INFO = -2
060:       END IF
061:       IF( INFO.NE.0 ) THEN
062:          CALL XERBLA( 'ZLA_HERCOND_X', -INFO )
063:          RETURN
064:       END IF
065:       UP = .FALSE.
066:       IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE.
067: *
068: *     Compute norm of op(A)*op2(C).
069: *
070:       ANORM = 0.0D+0
071:       IF ( UP ) THEN
072:          DO I = 1, N
073:             TMP = 0.0D+0
074:             DO J = 1, N
075:                IF ( I.GT.J ) THEN
076:                   TMP = TMP + CABS1( A( J, I ) * X( J ) )
077:                ELSE
078:                   TMP = TMP + CABS1( A( I, J ) * X( J ) )
079:                END IF
080:             END DO
081:             RWORK( 2*N+I ) = TMP
082:             ANORM = MAX( ANORM, TMP )
083:          END DO
084:       ELSE
085:          DO I = 1, N
086:             TMP = 0.0D+0
087:             DO J = 1, N
088:                IF ( I.LT.J ) THEN
089:                   TMP = TMP + CABS1( A( J, I ) * X( J ) )
090:                ELSE
091:                   TMP = TMP + CABS1( A( 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:          ZLA_HERCOND_X = 1.0D+0
103:          RETURN
104:       ELSE IF( ANORM .EQ. 0.0D+0 ) THEN
105:          RETURN
106:       END IF
107: *
108: *     Estimate the norm of inv(op(A)).
109: *
110:       AINVNM = 0.0D+0
111: *
112:       KASE = 0
113:    10 CONTINUE
114:       CALL ZLACN2( 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 ( UP ) THEN
125:                CALL ZHETRS( 'U', N, 1, AF, LDAF, IPIV,
126:      $            WORK, N, INFO )
127:             ELSE
128:                CALL ZHETRS( 'L', N, 1, AF, LDAF, IPIV,
129:      $            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 ( UP ) THEN
146:                CALL ZHETRS( 'U', N, 1, AF, LDAF, IPIV,
147:      $            WORK, N, INFO )
148:             ELSE
149:                CALL ZHETRS( 'L', N, 1, AF, LDAF, IPIV,
150:      $            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.0D+0 )
165:      $   ZLA_HERCOND_X = 1.0D+0 / AINVNM
166: *
167:       RETURN
168: *
169:       END
170: