001:       DOUBLE PRECISION FUNCTION ZLA_SYRCOND_C( UPLO, 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 Arguments ..
016:       CHARACTER          UPLO
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_SYRCOND_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:       INTEGER            KASE
032:       DOUBLE PRECISION   AINVNM, ANORM, TMP
033:       INTEGER            I, J
034:       LOGICAL            UP
035:       COMPLEX*16         ZDUM
036: *     ..
037: *     .. Local Arrays ..
038:       INTEGER            ISAVE( 3 )
039: *     ..
040: *     .. External Functions ..
041:       LOGICAL            LSAME
042:       EXTERNAL           LSAME
043: *     ..
044: *     .. External Subroutines ..
045:       EXTERNAL           ZLACN2, ZSYTRS, XERBLA
046: *     ..
047: *     .. Intrinsic Functions ..
048:       INTRINSIC          ABS, MAX
049: *     ..
050: *     .. Statement Functions ..
051:       DOUBLE PRECISION CABS1
052: *     ..
053: *     .. Statement Function Definitions ..
054:       CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
055: *     ..
056: *     .. Executable Statements ..
057: *
058:       ZLA_SYRCOND_C = 0.0D+0
059: *
060:       INFO = 0
061:       IF( N.LT.0 ) THEN
062:          INFO = -2
063:       END IF
064:       IF( INFO.NE.0 ) THEN
065:          CALL XERBLA( 'ZLA_SYRCOND_C', -INFO )
066:          RETURN
067:       END IF
068:       UP = .FALSE.
069:       IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE.
070: *
071: *     Compute norm of op(A)*op2(C).
072: *
073:       ANORM = 0.0D+0
074:       IF ( UP ) THEN
075:          DO I = 1, N
076:             TMP = 0.0D+0
077:             IF ( CAPPLY ) THEN
078:                DO J = 1, N
079:                   IF (I.GT.J) THEN
080:                      TMP = TMP + CABS1( A( J, I ) ) / C( J )
081:                   ELSE
082:                      TMP = TMP + CABS1( A( I, J ) ) / C( J )
083:                   END IF
084:                END DO
085:             ELSE
086:                DO J = 1, N
087:                   IF ( I.GT.J ) THEN
088:                      TMP = TMP + CABS1( A( J, I ) )
089:                   ELSE
090:                      TMP = TMP + CABS1( A( I, J ) )
091:                   END IF
092:                END DO
093:             END IF
094:             RWORK( 2*N+I ) = TMP
095:             ANORM = MAX( ANORM, TMP )
096:          END DO
097:       ELSE
098:          DO I = 1, N
099:             TMP = 0.0D+0
100:             IF ( CAPPLY ) THEN
101:                DO J = 1, N
102:                   IF ( I.LT.J ) THEN
103:                      TMP = TMP + CABS1( A( J, I ) ) / C( J )
104:                   ELSE
105:                      TMP = TMP + CABS1( A( I, J ) ) / C( J )
106:                   END IF
107:                END DO
108:             ELSE
109:                DO J = 1, N
110:                   IF ( I.LT.J ) THEN
111:                      TMP = TMP + CABS1( A( J, I ) )
112:                   ELSE
113:                      TMP = TMP + CABS1( A( I, J ) )
114:                   END IF
115:                END DO
116:             END IF
117:             RWORK( 2*N+I ) = TMP
118:             ANORM = MAX( ANORM, TMP )
119:          END DO
120:       END IF
121: *
122: *     Quick return if possible.
123: *
124:       IF( N.EQ.0 ) THEN
125:          ZLA_SYRCOND_C = 1.0D+0
126:          RETURN
127:       ELSE IF( ANORM .EQ. 0.0D+0 ) THEN
128:          RETURN
129:       END IF
130: *
131: *     Estimate the norm of inv(op(A)).
132: *
133:       AINVNM = 0.0D+0
134: *
135:       KASE = 0
136:    10 CONTINUE
137:       CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
138:       IF( KASE.NE.0 ) THEN
139:          IF( KASE.EQ.2 ) THEN
140: *
141: *           Multiply by R.
142: *
143:             DO I = 1, N
144:                WORK( I ) = WORK( I ) * RWORK( 2*N+I )
145:             END DO
146: *
147:             IF ( UP ) THEN
148:                CALL ZSYTRS( 'U', N, 1, AF, LDAF, IPIV,
149:      $            WORK, N, INFO )
150:             ELSE
151:                CALL ZSYTRS( 'L', N, 1, AF, LDAF, IPIV,
152:      $            WORK, N, INFO )
153:             ENDIF
154: *
155: *           Multiply by inv(C).
156: *
157:             IF ( CAPPLY ) THEN
158:                DO I = 1, N
159:                   WORK( I ) = WORK( I ) * C( I )
160:                END DO
161:             END IF
162:          ELSE
163: *
164: *           Multiply by inv(C').
165: *
166:             IF ( CAPPLY ) THEN
167:                DO I = 1, N
168:                   WORK( I ) = WORK( I ) * C( I )
169:                END DO
170:             END IF
171: *
172:             IF ( UP ) THEN
173:                CALL ZSYTRS( 'U', N, 1, AF, LDAF, IPIV,
174:      $            WORK, N, INFO )
175:             ELSE
176:                CALL ZSYTRS( 'L', N, 1, AF, LDAF, IPIV,
177:      $            WORK, N, INFO )
178:             END IF
179: *
180: *           Multiply by R.
181: *
182:             DO I = 1, N
183:                WORK( I ) = WORK( I ) * RWORK( 2*N+I )
184:             END DO
185:          END IF
186:          GO TO 10
187:       END IF
188: *
189: *     Compute the estimate of the reciprocal condition number.
190: *
191:       IF( AINVNM .NE. 0.0D+0 )
192:      $   ZLA_SYRCOND_C = 1.0D+0 / AINVNM
193: *
194:       RETURN
195: *
196:       END
197: