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.
275 lines
7.6 KiB
FortranFixed
275 lines
7.6 KiB
FortranFixed
*> \brief \b STRCON
|
|
*
|
|
* =========== DOCUMENTATION ===========
|
|
*
|
|
* Online html documentation available at
|
|
* http://www.netlib.org/lapack/explore-html/
|
|
*
|
|
*> Download STRCON + dependencies
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/strcon.f">
|
|
*> [TGZ]</a>
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/strcon.f">
|
|
*> [ZIP]</a>
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/strcon.f">
|
|
*> [TXT]</a>
|
|
*
|
|
* Definition:
|
|
* ===========
|
|
*
|
|
* SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
|
|
* IWORK, INFO )
|
|
*
|
|
* .. Scalar Arguments ..
|
|
* CHARACTER DIAG, NORM, UPLO
|
|
* INTEGER INFO, LDA, N
|
|
* REAL RCOND
|
|
* ..
|
|
* .. Array Arguments ..
|
|
* INTEGER IWORK( * )
|
|
* REAL A( LDA, * ), WORK( * )
|
|
* ..
|
|
*
|
|
*
|
|
*> \par Purpose:
|
|
* =============
|
|
*>
|
|
*> \verbatim
|
|
*>
|
|
*> STRCON 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 REAL 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 REAL array, dimension (3*N)
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] IWORK
|
|
*> \verbatim
|
|
*> IWORK is INTEGER 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 STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
|
|
$ IWORK, 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 ..
|
|
INTEGER IWORK( * )
|
|
REAL 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
|
|
* ..
|
|
* .. Local Arrays ..
|
|
INTEGER ISAVE( 3 )
|
|
* ..
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
INTEGER ISAMAX
|
|
REAL SLAMCH, SLANTR
|
|
EXTERNAL LSAME, ISAMAX, SLAMCH, SLANTR
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL SLACN2, SLATRS, SRSCL, XERBLA
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, MAX, REAL
|
|
* ..
|
|
* .. 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( 'STRCON', -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 = SLANTR( NORM, UPLO, DIAG, N, N, A, LDA, WORK )
|
|
*
|
|
* 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 SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE,
|
|
$ ISAVE )
|
|
IF( KASE.NE.0 ) THEN
|
|
IF( KASE.EQ.KASE1 ) THEN
|
|
*
|
|
* Multiply by inv(A).
|
|
*
|
|
CALL SLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
|
|
$ LDA, WORK, SCALE, WORK( 2*N+1 ), INFO )
|
|
ELSE
|
|
*
|
|
* Multiply by inv(A**T).
|
|
*
|
|
CALL SLATRS( UPLO, 'Transpose', DIAG, NORMIN, N, A,
|
|
$ LDA,
|
|
$ WORK, SCALE, WORK( 2*N+1 ), INFO )
|
|
END IF
|
|
NORMIN = 'Y'
|
|
*
|
|
* Multiply by 1/SCALE if doing so will not cause overflow.
|
|
*
|
|
IF( SCALE.NE.ONE ) THEN
|
|
IX = ISAMAX( N, WORK, 1 )
|
|
XNORM = ABS( WORK( IX ) )
|
|
IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
|
|
$ GO TO 20
|
|
CALL SRSCL( 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 STRCON
|
|
*
|
|
END
|