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