NAKATA Maho
11b673cf82
Replace direct NORM character comparisons for the one-norm option with LSAME in the condition estimation routines. This keeps the '1' checks consistent with the existing LSAME handling for the equivalent 'O' option.
281 lines
7.8 KiB
FortranFixed
281 lines
7.8 KiB
FortranFixed
*> \brief \b CTRCON
|
|
*
|
|
* =========== DOCUMENTATION ===========
|
|
*
|
|
* Online html documentation available at
|
|
* http://www.netlib.org/lapack/explore-html/
|
|
*
|
|
*> Download CTRCON + dependencies
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ctrcon.f">
|
|
*> [TGZ]</a>
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ctrcon.f">
|
|
*> [ZIP]</a>
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ctrcon.f">
|
|
*> [TXT]</a>
|
|
*
|
|
* Definition:
|
|
* ===========
|
|
*
|
|
* SUBROUTINE CTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
|
|
* RWORK, INFO )
|
|
*
|
|
* .. Scalar Arguments ..
|
|
* CHARACTER DIAG, NORM, UPLO
|
|
* INTEGER INFO, LDA, N
|
|
* REAL RCOND
|
|
* ..
|
|
* .. Array Arguments ..
|
|
* REAL RWORK( * )
|
|
* COMPLEX A( LDA, * ), WORK( * )
|
|
* ..
|
|
*
|
|
*
|
|
*> \par Purpose:
|
|
* =============
|
|
*>
|
|
*> \verbatim
|
|
*>
|
|
*> CTRCON estimates the reciprocal of the condition number of a
|
|
*> triangular matrix A, in either the 1-norm or the infinity-norm.
|
|
*>
|
|
*> The norm of A is computed and an estimate is obtained for
|
|
*> norm(inv(A)), then the reciprocal of the condition number is
|
|
*> computed as
|
|
*> RCOND = 1 / ( norm(A) * norm(inv(A)) ).
|
|
*> \endverbatim
|
|
*
|
|
* Arguments:
|
|
* ==========
|
|
*
|
|
*> \param[in] NORM
|
|
*> \verbatim
|
|
*> NORM is CHARACTER*1
|
|
*> Specifies whether the 1-norm condition number or the
|
|
*> infinity-norm condition number is required:
|
|
*> = '1' or 'O': 1-norm;
|
|
*> = 'I': Infinity-norm.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] UPLO
|
|
*> \verbatim
|
|
*> UPLO is CHARACTER*1
|
|
*> = 'U': A is upper triangular;
|
|
*> = 'L': A is lower triangular.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] DIAG
|
|
*> \verbatim
|
|
*> DIAG is CHARACTER*1
|
|
*> = 'N': A is non-unit triangular;
|
|
*> = 'U': A is unit triangular.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] N
|
|
*> \verbatim
|
|
*> N is INTEGER
|
|
*> The order of the matrix A. N >= 0.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] A
|
|
*> \verbatim
|
|
*> A is COMPLEX array, dimension (LDA,N)
|
|
*> The triangular matrix A. If UPLO = 'U', the leading N-by-N
|
|
*> upper triangular part of the array A contains the upper
|
|
*> triangular matrix, and the strictly lower triangular part of
|
|
*> A is not referenced. If UPLO = 'L', the leading N-by-N lower
|
|
*> triangular part of the array A contains the lower triangular
|
|
*> matrix, and the strictly upper triangular part of A is not
|
|
*> referenced. If DIAG = 'U', the diagonal elements of A are
|
|
*> also not referenced and are assumed to be 1.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] LDA
|
|
*> \verbatim
|
|
*> LDA is INTEGER
|
|
*> The leading dimension of the array A. LDA >= max(1,N).
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] RCOND
|
|
*> \verbatim
|
|
*> RCOND is REAL
|
|
*> The reciprocal of the condition number of the matrix A,
|
|
*> computed as RCOND = 1/(norm(A) * norm(inv(A))).
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] WORK
|
|
*> \verbatim
|
|
*> WORK is COMPLEX array, dimension (2*N)
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] RWORK
|
|
*> \verbatim
|
|
*> RWORK is REAL array, dimension (N)
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] INFO
|
|
*> \verbatim
|
|
*> INFO is INTEGER
|
|
*> = 0: successful exit
|
|
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
|
*> \endverbatim
|
|
*
|
|
* Authors:
|
|
* ========
|
|
*
|
|
*> \author Univ. of Tennessee
|
|
*> \author Univ. of California Berkeley
|
|
*> \author Univ. of Colorado Denver
|
|
*> \author NAG Ltd.
|
|
*
|
|
*> \ingroup trcon
|
|
*
|
|
* =====================================================================
|
|
SUBROUTINE CTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
|
|
$ RWORK, INFO )
|
|
IMPLICIT NONE
|
|
*
|
|
* -- LAPACK computational routine --
|
|
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
|
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
|
*
|
|
* .. Scalar Arguments ..
|
|
CHARACTER DIAG, NORM, UPLO
|
|
INTEGER INFO, LDA, N
|
|
REAL RCOND
|
|
* ..
|
|
* .. Array Arguments ..
|
|
REAL RWORK( * )
|
|
COMPLEX A( LDA, * ), WORK( * )
|
|
* ..
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
REAL ONE, ZERO
|
|
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
LOGICAL NOUNIT, ONENRM, UPPER
|
|
CHARACTER NORMIN
|
|
INTEGER IX, KASE, KASE1
|
|
REAL AINVNM, ANORM, SCALE, SMLNUM, XNORM
|
|
COMPLEX ZDUM
|
|
* ..
|
|
* .. Local Arrays ..
|
|
INTEGER ISAVE( 3 )
|
|
* ..
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
INTEGER ICAMAX
|
|
REAL CLANTR, SLAMCH
|
|
EXTERNAL LSAME, ICAMAX, CLANTR, SLAMCH
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL CLACN2, CLATRS, CSRSCL, XERBLA
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, AIMAG, MAX, REAL
|
|
* ..
|
|
* .. Statement Functions ..
|
|
REAL CABS1
|
|
* ..
|
|
* .. Statement Function definitions ..
|
|
CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
UPPER = LSAME( UPLO, 'U' )
|
|
ONENRM = LSAME( NORM, '1' ) .OR. LSAME( NORM, 'O' )
|
|
NOUNIT = LSAME( DIAG, 'N' )
|
|
*
|
|
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
|
|
INFO = -1
|
|
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
|
|
INFO = -2
|
|
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
|
|
INFO = -3
|
|
ELSE IF( N.LT.0 ) THEN
|
|
INFO = -4
|
|
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
|
INFO = -6
|
|
END IF
|
|
IF( INFO.NE.0 ) THEN
|
|
CALL XERBLA( 'CTRCON', -INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible
|
|
*
|
|
IF( N.EQ.0 ) THEN
|
|
RCOND = ONE
|
|
RETURN
|
|
END IF
|
|
*
|
|
RCOND = ZERO
|
|
SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
|
|
*
|
|
* Compute the norm of the triangular matrix A.
|
|
*
|
|
ANORM = CLANTR( NORM, UPLO, DIAG, N, N, A, LDA, RWORK )
|
|
*
|
|
* Continue only if ANORM > 0.
|
|
*
|
|
IF( ANORM.GT.ZERO ) THEN
|
|
*
|
|
* Estimate the norm of the inverse of A.
|
|
*
|
|
AINVNM = ZERO
|
|
NORMIN = 'N'
|
|
IF( ONENRM ) THEN
|
|
KASE1 = 1
|
|
ELSE
|
|
KASE1 = 2
|
|
END IF
|
|
KASE = 0
|
|
10 CONTINUE
|
|
CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
|
|
IF( KASE.NE.0 ) THEN
|
|
IF( KASE.EQ.KASE1 ) THEN
|
|
*
|
|
* Multiply by inv(A).
|
|
*
|
|
CALL CLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
|
|
$ LDA, WORK, SCALE, RWORK, INFO )
|
|
ELSE
|
|
*
|
|
* Multiply by inv(A**H).
|
|
*
|
|
CALL CLATRS( UPLO, 'Conjugate transpose', DIAG,
|
|
$ NORMIN,
|
|
$ N, A, LDA, WORK, SCALE, RWORK, INFO )
|
|
END IF
|
|
NORMIN = 'Y'
|
|
*
|
|
* Multiply by 1/SCALE if doing so will not cause overflow.
|
|
*
|
|
IF( SCALE.NE.ONE ) THEN
|
|
IX = ICAMAX( N, WORK, 1 )
|
|
XNORM = CABS1( WORK( IX ) )
|
|
IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
|
|
$ GO TO 20
|
|
CALL CSRSCL( N, SCALE, WORK, 1 )
|
|
END IF
|
|
GO TO 10
|
|
END IF
|
|
*
|
|
* Compute the estimate of the reciprocal condition number.
|
|
*
|
|
IF( AINVNM.NE.ZERO )
|
|
$ RCOND = ( ONE / ANORM ) / AINVNM
|
|
END IF
|
|
*
|
|
20 CONTINUE
|
|
RETURN
|
|
*
|
|
* End of CTRCON
|
|
*
|
|
END
|