001:       REAL FUNCTION CLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO,
002:      $                             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:       COMPLEX            A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
020:       REAL               RWORK( * )
021: *
022: *     CLA_PORCOND_X Computes the infinity norm condition number of
023: *     op(A) * diag(X) where X is a COMPLEX vector.
024: *     WORK is a COMPLEX workspace of size 2*N, and
025: *     RWORK is a REAL workspace of size 3*N.
026: *     ..
027: *     .. Local Scalars ..
028:       INTEGER            KASE, I, J
029:       REAL               AINVNM, ANORM, TMP
030:       LOGICAL            UP
031:       COMPLEX            ZDUM
032: *     ..
033: *     .. Local Arrays ..
034:       INTEGER            ISAVE( 3 )
035: *     ..
036: *     .. External Functions ..
037:       LOGICAL            LSAME
038:       EXTERNAL           LSAME
039: *     ..
040: *     .. External Subroutines ..
041:       EXTERNAL           CLACN2, CPOTRS, XERBLA
042: *     ..
043: *     .. Intrinsic Functions ..
044:       INTRINSIC          ABS, MAX, REAL, AIMAG
045: *     ..
046: *     .. Statement Functions ..
047:       REAL CABS1
048: *     ..
049: *     .. Statement Function Definitions ..
050:       CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
051: *     ..
052: *     .. Executable Statements ..
053: *
054:       CLA_PORCOND_X = 0.0E+0
055: *
056:       INFO = 0
057:       IF( N.LT.0 ) THEN
058:          INFO = -2
059:       END IF
060:       IF( INFO.NE.0 ) THEN
061:          CALL XERBLA( 'CLA_PORCOND_X', -INFO )
062:          RETURN
063:       END IF
064:       UP = .FALSE.
065:       IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE.
066: *
067: *     Compute norm of op(A)*op2(C).
068: *
069:       ANORM = 0.0
070:       IF ( UP ) THEN
071:          DO I = 1, N
072:             TMP = 0.0E+0
073:             DO J = 1, N
074:                IF ( I.GT.J ) THEN
075:                   TMP = TMP + CABS1( A( J, I ) * X( J ) )
076:                ELSE
077:                   TMP = TMP + CABS1( A( I, J ) * X( J ) )
078:                END IF
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:                IF ( I.LT.J ) THEN
088:                   TMP = TMP + CABS1( A( J, I ) * X( J ) )
089:                ELSE
090:                   TMP = TMP + CABS1( A( I, J ) * X( J ) )
091:                END IF
092:             END DO
093:             RWORK( 2*N+I ) = TMP
094:             ANORM = MAX( ANORM, TMP )
095:          END DO
096:       END IF
097: *
098: *     Quick return if possible.
099: *
100:       IF( N.EQ.0 ) THEN
101:          CLA_PORCOND_X = 1.0E+0
102:          RETURN
103:       ELSE IF( ANORM .EQ. 0.0E+0 ) THEN
104:          RETURN
105:       END IF
106: *
107: *     Estimate the norm of inv(op(A)).
108: *
109:       AINVNM = 0.0E+0
110: *
111:       KASE = 0
112:    10 CONTINUE
113:       CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
114:       IF( KASE.NE.0 ) THEN
115:          IF( KASE.EQ.2 ) THEN
116: *
117: *           Multiply by R.
118: *
119:             DO I = 1, N
120:                WORK( I ) = WORK( I ) * RWORK( 2*N+I )
121:             END DO
122: *
123:             IF ( UP ) THEN
124:                CALL CPOTRS( 'U', N, 1, AF, LDAF,
125:      $            WORK, N, INFO )
126:             ELSE
127:                CALL CPOTRS( 'L', N, 1, AF, LDAF,
128:      $            WORK, N, INFO )
129:             ENDIF
130: *
131: *           Multiply by inv(X).
132: *
133:             DO I = 1, N
134:                WORK( I ) = WORK( I ) / X( I )
135:             END DO
136:          ELSE
137: *
138: *           Multiply by inv(X').
139: *
140:             DO I = 1, N
141:                WORK( I ) = WORK( I ) / X( I )
142:             END DO
143: *
144:             IF ( UP ) THEN
145:                CALL CPOTRS( 'U', N, 1, AF, LDAF,
146:      $            WORK, N, INFO )
147:             ELSE
148:                CALL CPOTRS( 'L', N, 1, AF, LDAF,
149:      $            WORK, N, INFO )
150:             END IF
151: *
152: *           Multiply by R.
153: *
154:             DO I = 1, N
155:                WORK( I ) = WORK( I ) * RWORK( 2*N+I )
156:             END DO
157:          END IF
158:          GO TO 10
159:       END IF
160: *
161: *     Compute the estimate of the reciprocal condition number.
162: *
163:       IF( AINVNM .NE. 0.0E+0 )
164:      $   CLA_PORCOND_X = 1.0E+0 / AINVNM
165: *
166:       RETURN
167: *
168:       END
169: