diff options
author | julie <julielangou@users.noreply.github.com> | 2008-12-16 17:06:58 +0000 |
---|---|---|
committer | julie <julielangou@users.noreply.github.com> | 2008-12-16 17:06:58 +0000 |
commit | ff981f106bde4ce6a74aa4f4a572c943f5a395b2 (patch) | |
tree | a386cad907bcaefd6893535c31d67ec9468e693e /SRC/zla_gercond_c.f | |
parent | e58b61578b55644f6391f3333262b72c1dc88437 (diff) | |
download | lapack-ff981f106bde4ce6a74aa4f4a572c943f5a395b2.tar.gz lapack-ff981f106bde4ce6a74aa4f4a572c943f5a395b2.tar.bz2 lapack-ff981f106bde4ce6a74aa4f4a572c943f5a395b2.zip |
Diffstat (limited to 'SRC/zla_gercond_c.f')
-rw-r--r-- | SRC/zla_gercond_c.f | 179 |
1 files changed, 179 insertions, 0 deletions
diff --git a/SRC/zla_gercond_c.f b/SRC/zla_gercond_c.f new file mode 100644 index 00000000..a4cf0926 --- /dev/null +++ b/SRC/zla_gercond_c.f @@ -0,0 +1,179 @@ + DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF, + $ LDAF, IPIV, C, CAPPLY, INFO, WORK, + $ RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Aguments .. + CHARACTER TRANS + LOGICAL CAPPLY + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) + DOUBLE PRECISION C( * ), RWORK( * ) +* +* ZLA_GERCOND_C computes the infinity norm condition number of +* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. +* WORK is a COMPLEX*16 workspace of size 2*N, and +* RWORK is a DOUBLE PRECISION workspace of size 3*N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, ANORM, TMP + COMPLEX*16 ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZGETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. + ZLA_GERCOND_C = 0.0D+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLA_GERCOND_C', -INFO ) + RETURN + END IF +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0D+0 + IF ( NOTRANS ) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CAPPLY ) THEN + DO J = 1, N + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END DO + ELSE + DO J = 1, N + TMP = TMP + CABS1( A( I, J ) ) + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CAPPLY ) THEN + DO J = 1, N + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + END DO + ELSE + DO J = 1, N + TMP = TMP + CABS1( A( J, I ) ) + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + ZLA_GERCOND_C = 1.0D+0 + RETURN + ELSE IF( ANORM .EQ. 0.0D+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 +* + KASE = 0 + 10 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF (NOTRANS) THEN + CALL ZGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF +* + IF ( NOTRANS ) THEN + CALL ZGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ ZLA_GERCOND_C = 1.0D+0 / AINVNM +* + RETURN +* + END |