001:       REAL FUNCTION CLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, C,
002:      $                             CAPPLY, 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 Aguments ..
015:       CHARACTER          TRANS
016:       LOGICAL            CAPPLY
017:       INTEGER            N, LDA, LDAF, INFO
018: *     ..
019: *     .. Array Arguments ..
020:       INTEGER            IPIV( * )
021:       COMPLEX            A( LDA, * ), AF( LDAF, * ), WORK( * )
022:       REAL               C( * ), RWORK( * )
023: *
024: *     CLA_GERCOND_C computes the infinity norm condition number of
025: *     op(A) * inv(diag(C)) where C is a REAL 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, 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:       CLA_GERCOND_C = 0.0E+0
056: *
057:       INFO = 0
058:       NOTRANS = LSAME( TRANS, 'N' )
059:       IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT.
060:      $     LSAME( TRANS, 'C' ) ) THEN
061:       ELSE IF( N.LT.0 ) THEN
062:          INFO = -2
063:       END IF
064:       IF( INFO.NE.0 ) THEN
065:          CALL XERBLA( 'CLA_GERCOND_C', -INFO )
066:          RETURN
067:       END IF
068: *
069: *     Compute norm of op(A)*op2(C).
070: *
071:       ANORM = 0.0E+0
072:       IF ( NOTRANS ) THEN
073:          DO I = 1, N
074:             TMP = 0.0E+0
075:             IF ( CAPPLY ) THEN
076:                DO J = 1, N
077:                   TMP = TMP + CABS1( A( I, J ) ) / C( J )
078:                END DO
079:             ELSE
080:                DO J = 1, N
081:                   TMP = TMP + CABS1( A( I, J ) )
082:                END DO
083:             END IF
084:             RWORK( 2*N+I ) = TMP
085:             ANORM = MAX( ANORM, TMP )
086:          END DO
087:       ELSE
088:          DO I = 1, N
089:             TMP = 0.0E+0
090:             IF ( CAPPLY ) THEN
091:                DO J = 1, N
092:                   TMP = TMP + CABS1( A( J, I ) ) / C( J )
093:                END DO
094:             ELSE
095:                DO J = 1, N
096:                   TMP = TMP + CABS1( A( J, I ) )
097:                END DO
098:             END IF
099:             RWORK( 2*N+I ) = TMP
100:             ANORM = MAX( ANORM, TMP )
101:          END DO
102:       END IF
103: *
104: *     Quick return if possible.
105: *
106:       IF( N.EQ.0 ) THEN
107:          CLA_GERCOND_C = 1.0E+0
108:          RETURN
109:       ELSE IF( ANORM .EQ. 0.0E+0 ) THEN
110:          RETURN
111:       END IF
112: *
113: *     Estimate the norm of inv(op(A)).
114: *
115:       AINVNM = 0.0E+0
116: *
117:       KASE = 0
118:    10 CONTINUE
119:       CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
120:       IF( KASE.NE.0 ) THEN
121:          IF( KASE.EQ.2 ) THEN
122: *
123: *           Multiply by R.
124: *
125:             DO I = 1, N
126:                WORK( I ) = WORK( I ) * RWORK( 2*N+I )
127:             END DO
128: *
129:             IF (NOTRANS) THEN
130:                CALL CGETRS( 'No transpose', N, 1, AF, LDAF, IPIV,
131:      $            WORK, N, INFO )
132:             ELSE
133:                CALL CGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV,
134:      $            WORK, N, INFO )
135:             ENDIF
136: *
137: *           Multiply by inv(C).
138: *
139:             IF ( CAPPLY ) THEN
140:                DO I = 1, N
141:                   WORK( I ) = WORK( I ) * C( I )
142:                END DO
143:             END IF
144:          ELSE
145: *
146: *           Multiply by inv(C').
147: *
148:             IF ( CAPPLY ) THEN
149:                DO I = 1, N
150:                   WORK( I ) = WORK( I ) * C( I )
151:                END DO
152:             END IF
153: *
154:             IF ( NOTRANS ) THEN
155:                CALL CGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV,
156:      $            WORK, N, INFO )
157:             ELSE
158:                CALL CGETRS( 'No transpose', N, 1, AF, LDAF, IPIV,
159:      $            WORK, N, INFO )
160:             END IF
161: *
162: *           Multiply by R.
163: *
164:             DO I = 1, N
165:                WORK( I ) = WORK( I ) * RWORK( 2*N+I )
166:             END DO
167:          END IF
168:          GO TO 10
169:       END IF
170: *
171: *     Compute the estimate of the reciprocal condition number.
172: *
173:       IF( AINVNM .NE. 0.0E+0 )
174:      $   CLA_GERCOND_C = 1.0E+0 / AINVNM
175: *
176:       RETURN
177: *
178:       END
179: