801 lines
No EOL
22 KiB
Fortran
801 lines
No EOL
22 KiB
Fortran
SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
|
|
*
|
|
* -- LAPACK routine (version 3.0) --
|
|
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
* Courant Institute, Argonne National Lab, and Rice University
|
|
* June 30, 1999
|
|
*
|
|
* .. Scalar Arguments ..
|
|
INTEGER INFO, LDA, LWORK, N
|
|
* ..
|
|
* .. Array Arguments ..
|
|
INTEGER IPIV( * )
|
|
DOUBLE PRECISION A( LDA, * ), WORK( * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* DGETRI computes the inverse of a matrix using the LU factorization
|
|
* computed by DGETRF.
|
|
*
|
|
* This method inverts U and then computes inv(A) by solving the system
|
|
* inv(A)*L = inv(U) for inv(A).
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* N (input) INTEGER
|
|
* The order of the matrix A. N >= 0.
|
|
*
|
|
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
|
|
* On entry, the factors L and U from the factorization
|
|
* A = P*L*U as computed by DGETRF.
|
|
* On exit, if INFO = 0, the inverse of the original matrix A.
|
|
*
|
|
* LDA (input) INTEGER
|
|
* The leading dimension of the array A. LDA >= max(1,N).
|
|
*
|
|
* IPIV (input) INTEGER array, dimension (N)
|
|
* The pivot indices from DGETRF; for 1<=i<=N, row i of the
|
|
* matrix was interchanged with row IPIV(i).
|
|
*
|
|
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
|
|
* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
|
|
*
|
|
* LWORK (input) INTEGER
|
|
* The dimension of the array WORK. LWORK >= max(1,N).
|
|
* For optimal performance LWORK >= N*NB, where NB is
|
|
* the optimal blocksize returned by ILAENV.
|
|
*
|
|
* If LWORK = -1, then a workspace query is assumed; the routine
|
|
* only calculates the optimal size of the WORK array, returns
|
|
* this value as the first entry of the WORK array, and no error
|
|
* message related to LWORK is issued by XERBLA.
|
|
*
|
|
* INFO (output) INTEGER
|
|
* = 0: successful exit
|
|
* < 0: if INFO = -i, the i-th argument had an illegal value
|
|
* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
|
|
* singular and its inverse could not be computed.
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
DOUBLE PRECISION ZERO, ONE
|
|
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
LOGICAL LQUERY
|
|
INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
|
|
$ NBMIN, NN
|
|
* ..
|
|
* .. External Functions ..
|
|
INTEGER ILAENV
|
|
EXTERNAL ILAENV
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC MAX, MIN
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )
|
|
LWKOPT = N*NB
|
|
WORK( 1 ) = LWKOPT
|
|
LQUERY = ( LWORK.EQ.-1 )
|
|
IF( N.LT.0 ) THEN
|
|
INFO = -1
|
|
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
|
INFO = -3
|
|
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
|
|
INFO = -6
|
|
END IF
|
|
IF( INFO.NE.0 ) THEN
|
|
CALL XERBLA( 'DGETRI', -INFO )
|
|
RETURN
|
|
ELSE IF( LQUERY ) THEN
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible
|
|
*
|
|
IF( N.EQ.0 )
|
|
$ RETURN
|
|
*
|
|
* Form inv(U). If INFO > 0 from DTRTRI, then U is singular,
|
|
* and the inverse is not computed.
|
|
*
|
|
CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
|
|
IF( INFO.GT.0 )
|
|
$ RETURN
|
|
*
|
|
NBMIN = 2
|
|
LDWORK = N
|
|
IF( NB.GT.1 .AND. NB.LT.N ) THEN
|
|
IWS = MAX( LDWORK*NB, 1 )
|
|
IF( LWORK.LT.IWS ) THEN
|
|
NB = LWORK / LDWORK
|
|
NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )
|
|
END IF
|
|
ELSE
|
|
IWS = N
|
|
END IF
|
|
*
|
|
* Solve the equation inv(A)*L = inv(U) for inv(A).
|
|
*
|
|
IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
|
|
*
|
|
* Use unblocked code.
|
|
*
|
|
DO 20 J = N, 1, -1
|
|
*
|
|
* Copy current column of L to WORK and replace with zeros.
|
|
*
|
|
DO 10 I = J + 1, N
|
|
WORK( I ) = A( I, J )
|
|
A( I, J ) = ZERO
|
|
10 CONTINUE
|
|
*
|
|
* Compute current column of inv(A).
|
|
*
|
|
IF( J.LT.N )
|
|
$ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
|
|
$ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
|
|
20 CONTINUE
|
|
ELSE
|
|
*
|
|
* Use blocked code.
|
|
*
|
|
NN = ( ( N-1 ) / NB )*NB + 1
|
|
DO 50 J = NN, 1, -NB
|
|
JB = MIN( NB, N-J+1 )
|
|
*
|
|
* Copy current block column of L to WORK and replace with
|
|
* zeros.
|
|
*
|
|
DO 40 JJ = J, J + JB - 1
|
|
DO 30 I = JJ + 1, N
|
|
WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
|
|
A( I, JJ ) = ZERO
|
|
30 CONTINUE
|
|
40 CONTINUE
|
|
*
|
|
* Compute current block column of inv(A).
|
|
*
|
|
IF( J+JB.LE.N )
|
|
$ CALL DGEMM( 'No transpose', 'No transpose', N, JB,
|
|
$ N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
|
|
$ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
|
|
CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
|
|
$ ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
|
|
50 CONTINUE
|
|
END IF
|
|
*
|
|
* Apply column interchanges.
|
|
*
|
|
DO 60 J = N - 1, 1, -1
|
|
JP = IPIV( J )
|
|
IF( JP.NE.J )
|
|
$ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
|
|
60 CONTINUE
|
|
*
|
|
WORK( 1 ) = IWS
|
|
RETURN
|
|
*
|
|
* End of DGETRI
|
|
*
|
|
END
|
|
SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
|
|
*
|
|
* -- LAPACK routine (version 3.0) --
|
|
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
* Courant Institute, Argonne National Lab, and Rice University
|
|
* February 29, 1992
|
|
*
|
|
* .. Scalar Arguments ..
|
|
CHARACTER DIAG, UPLO
|
|
INTEGER INFO, LDA, N
|
|
* ..
|
|
* .. Array Arguments ..
|
|
DOUBLE PRECISION A( LDA, * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* DTRTI2 computes the inverse of a real upper or lower triangular
|
|
* matrix.
|
|
*
|
|
* This is the Level 2 BLAS version of the algorithm.
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* UPLO (input) CHARACTER*1
|
|
* Specifies whether the matrix A is upper or lower triangular.
|
|
* = 'U': Upper triangular
|
|
* = 'L': Lower triangular
|
|
*
|
|
* DIAG (input) CHARACTER*1
|
|
* Specifies whether or not the matrix A is unit triangular.
|
|
* = 'N': Non-unit triangular
|
|
* = 'U': Unit triangular
|
|
*
|
|
* N (input) INTEGER
|
|
* The order of the matrix A. N >= 0.
|
|
*
|
|
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
|
|
* On entry, 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.
|
|
*
|
|
* On exit, the (triangular) inverse of the original matrix, in
|
|
* the same storage format.
|
|
*
|
|
* LDA (input) INTEGER
|
|
* The leading dimension of the array A. LDA >= max(1,N).
|
|
*
|
|
* INFO (output) INTEGER
|
|
* = 0: successful exit
|
|
* < 0: if INFO = -k, the k-th argument had an illegal value
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
DOUBLE PRECISION ONE
|
|
PARAMETER ( ONE = 1.0D+0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
LOGICAL NOUNIT, UPPER
|
|
INTEGER J
|
|
DOUBLE PRECISION AJJ
|
|
* ..
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL DSCAL, DTRMV, XERBLA
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC MAX
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
UPPER = LSAME( UPLO, 'U' )
|
|
NOUNIT = LSAME( DIAG, 'N' )
|
|
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
|
|
INFO = -1
|
|
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
|
|
INFO = -2
|
|
ELSE IF( N.LT.0 ) THEN
|
|
INFO = -3
|
|
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
|
INFO = -5
|
|
END IF
|
|
IF( INFO.NE.0 ) THEN
|
|
CALL XERBLA( 'DTRTI2', -INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
IF( UPPER ) THEN
|
|
*
|
|
* Compute inverse of upper triangular matrix.
|
|
*
|
|
DO 10 J = 1, N
|
|
IF( NOUNIT ) THEN
|
|
A( J, J ) = ONE / A( J, J )
|
|
AJJ = -A( J, J )
|
|
ELSE
|
|
AJJ = -ONE
|
|
END IF
|
|
*
|
|
* Compute elements 1:j-1 of j-th column.
|
|
*
|
|
CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
|
|
$ A( 1, J ), 1 )
|
|
CALL DSCAL( J-1, AJJ, A( 1, J ), 1 )
|
|
10 CONTINUE
|
|
ELSE
|
|
*
|
|
* Compute inverse of lower triangular matrix.
|
|
*
|
|
DO 20 J = N, 1, -1
|
|
IF( NOUNIT ) THEN
|
|
A( J, J ) = ONE / A( J, J )
|
|
AJJ = -A( J, J )
|
|
ELSE
|
|
AJJ = -ONE
|
|
END IF
|
|
IF( J.LT.N ) THEN
|
|
*
|
|
* Compute elements j+1:n of j-th column.
|
|
*
|
|
CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J,
|
|
$ A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
|
|
CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 )
|
|
END IF
|
|
20 CONTINUE
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* End of DTRTI2
|
|
*
|
|
END
|
|
SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
|
|
*
|
|
* -- LAPACK routine (version 3.0) --
|
|
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
* Courant Institute, Argonne National Lab, and Rice University
|
|
* March 31, 1993
|
|
*
|
|
* .. Scalar Arguments ..
|
|
CHARACTER DIAG, UPLO
|
|
INTEGER INFO, LDA, N
|
|
* ..
|
|
* .. Array Arguments ..
|
|
DOUBLE PRECISION A( LDA, * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* DTRTRI computes the inverse of a real upper or lower triangular
|
|
* matrix A.
|
|
*
|
|
* This is the Level 3 BLAS version of the algorithm.
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* UPLO (input) CHARACTER*1
|
|
* = 'U': A is upper triangular;
|
|
* = 'L': A is lower triangular.
|
|
*
|
|
* DIAG (input) CHARACTER*1
|
|
* = 'N': A is non-unit triangular;
|
|
* = 'U': A is unit triangular.
|
|
*
|
|
* N (input) INTEGER
|
|
* The order of the matrix A. N >= 0.
|
|
*
|
|
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
|
|
* On entry, 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.
|
|
* On exit, the (triangular) inverse of the original matrix, in
|
|
* the same storage format.
|
|
*
|
|
* LDA (input) INTEGER
|
|
* The leading dimension of the array A. LDA >= max(1,N).
|
|
*
|
|
* INFO (output) INTEGER
|
|
* = 0: successful exit
|
|
* < 0: if INFO = -i, the i-th argument had an illegal value
|
|
* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
|
|
* matrix is singular and its inverse can not be computed.
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
DOUBLE PRECISION ONE, ZERO
|
|
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
LOGICAL NOUNIT, UPPER
|
|
INTEGER J, JB, NB, NN
|
|
* ..
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
INTEGER ILAENV
|
|
EXTERNAL LSAME, ILAENV
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC MAX, MIN
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
INFO = 0
|
|
UPPER = LSAME( UPLO, 'U' )
|
|
NOUNIT = LSAME( DIAG, 'N' )
|
|
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
|
|
INFO = -1
|
|
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
|
|
INFO = -2
|
|
ELSE IF( N.LT.0 ) THEN
|
|
INFO = -3
|
|
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
|
INFO = -5
|
|
END IF
|
|
IF( INFO.NE.0 ) THEN
|
|
CALL XERBLA( 'DTRTRI', -INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible
|
|
*
|
|
IF( N.EQ.0 )
|
|
$ RETURN
|
|
*
|
|
* Check for singularity if non-unit.
|
|
*
|
|
IF( NOUNIT ) THEN
|
|
DO 10 INFO = 1, N
|
|
IF( A( INFO, INFO ).EQ.ZERO )
|
|
$ RETURN
|
|
10 CONTINUE
|
|
INFO = 0
|
|
END IF
|
|
*
|
|
* Determine the block size for this environment.
|
|
*
|
|
NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 )
|
|
IF( NB.LE.1 .OR. NB.GE.N ) THEN
|
|
*
|
|
* Use unblocked code
|
|
*
|
|
CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
|
|
ELSE
|
|
*
|
|
* Use blocked code
|
|
*
|
|
IF( UPPER ) THEN
|
|
*
|
|
* Compute inverse of upper triangular matrix
|
|
*
|
|
DO 20 J = 1, N, NB
|
|
JB = MIN( NB, N-J+1 )
|
|
*
|
|
* Compute rows 1:j-1 of current block column
|
|
*
|
|
CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
|
|
$ JB, ONE, A, LDA, A( 1, J ), LDA )
|
|
CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
|
|
$ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
|
|
*
|
|
* Compute inverse of current diagonal block
|
|
*
|
|
CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
|
|
20 CONTINUE
|
|
ELSE
|
|
*
|
|
* Compute inverse of lower triangular matrix
|
|
*
|
|
NN = ( ( N-1 ) / NB )*NB + 1
|
|
DO 30 J = NN, 1, -NB
|
|
JB = MIN( NB, N-J+1 )
|
|
IF( J+JB.LE.N ) THEN
|
|
*
|
|
* Compute rows j+jb:n of current block column
|
|
*
|
|
CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG,
|
|
$ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
|
|
$ A( J+JB, J ), LDA )
|
|
CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG,
|
|
$ N-J-JB+1, JB, -ONE, A( J, J ), LDA,
|
|
$ A( J+JB, J ), LDA )
|
|
END IF
|
|
*
|
|
* Compute inverse of current diagonal block
|
|
*
|
|
CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
|
|
30 CONTINUE
|
|
END IF
|
|
END IF
|
|
*
|
|
RETURN
|
|
*
|
|
* End of DTRTRI
|
|
*
|
|
END
|
|
INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )
|
|
*
|
|
* -- LAPACK auxiliary routine (version 3.0) --
|
|
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
* Courant Institute, Argonne National Lab, and Rice University
|
|
* June 30, 1998
|
|
*
|
|
* .. Scalar Arguments ..
|
|
INTEGER ISPEC
|
|
REAL ONE, ZERO
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* IEEECK is called from the ILAENV to verify that Infinity and
|
|
* possibly NaN arithmetic is safe (i.e. will not trap).
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* ISPEC (input) INTEGER
|
|
* Specifies whether to test just for inifinity arithmetic
|
|
* or whether to test for infinity and NaN arithmetic.
|
|
* = 0: Verify infinity arithmetic only.
|
|
* = 1: Verify infinity and NaN arithmetic.
|
|
*
|
|
* ZERO (input) REAL
|
|
* Must contain the value 0.0
|
|
* This is passed to prevent the compiler from optimizing
|
|
* away this code.
|
|
*
|
|
* ONE (input) REAL
|
|
* Must contain the value 1.0
|
|
* This is passed to prevent the compiler from optimizing
|
|
* away this code.
|
|
*
|
|
* RETURN VALUE: INTEGER
|
|
* = 0: Arithmetic failed to produce the correct answers
|
|
* = 1: Arithmetic produced the correct answers
|
|
*
|
|
* .. Local Scalars ..
|
|
REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
|
|
$ NEGZRO, NEWZRO, POSINF
|
|
* ..
|
|
* .. Executable Statements ..
|
|
IEEECK = 1
|
|
*
|
|
POSINF = ONE / ZERO
|
|
IF( POSINF.LE.ONE ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
NEGINF = -ONE / ZERO
|
|
IF( NEGINF.GE.ZERO ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
NEGZRO = ONE / ( NEGINF+ONE )
|
|
IF( NEGZRO.NE.ZERO ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
NEGINF = ONE / NEGZRO
|
|
IF( NEGINF.GE.ZERO ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
NEWZRO = NEGZRO + ZERO
|
|
IF( NEWZRO.NE.ZERO ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
POSINF = ONE / NEWZRO
|
|
IF( POSINF.LE.ONE ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
NEGINF = NEGINF*POSINF
|
|
IF( NEGINF.GE.ZERO ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
POSINF = POSINF*POSINF
|
|
IF( POSINF.LE.ONE ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
*
|
|
*
|
|
*
|
|
* Return if we were only asked to check infinity arithmetic
|
|
*
|
|
IF( ISPEC.EQ.0 )
|
|
$ RETURN
|
|
*
|
|
NAN1 = POSINF + NEGINF
|
|
*
|
|
NAN2 = POSINF / NEGINF
|
|
*
|
|
NAN3 = POSINF / POSINF
|
|
*
|
|
NAN4 = POSINF*ZERO
|
|
*
|
|
NAN5 = NEGINF*NEGZRO
|
|
*
|
|
NAN6 = NAN5*0.0
|
|
*
|
|
IF( NAN1.EQ.NAN1 ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
IF( NAN2.EQ.NAN2 ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
IF( NAN3.EQ.NAN3 ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
IF( NAN4.EQ.NAN4 ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
IF( NAN5.EQ.NAN5 ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
IF( NAN6.EQ.NAN6 ) THEN
|
|
IEEECK = 0
|
|
RETURN
|
|
END IF
|
|
*
|
|
RETURN
|
|
END
|
|
|
|
c END
|
|
|
|
c LOGICAL FUNCTION LSAME( CA, CB )
|
|
*
|
|
* -- LAPACK auxiliary routine (version 3.0) --
|
|
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
* Courant Institute, Argonne National Lab, and Rice University
|
|
* September 30, 1994
|
|
*
|
|
* .. Scalar Arguments ..
|
|
c CHARACTER CA, CB
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* LSAME returns .TRUE. if CA is the same letter as CB regardless of
|
|
* case.
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* CA (input) CHARACTER*1
|
|
* CB (input) CHARACTER*1
|
|
* CA and CB specify the single characters to be compared.
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Intrinsic Functions ..
|
|
c INTRINSIC ICHAR
|
|
* ..
|
|
* .. Local Scalars ..
|
|
c INTEGER INTA, INTB, ZCODE
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test if the characters are equal
|
|
*
|
|
c LSAME = CA.EQ.CB
|
|
c IF( LSAME )
|
|
c $ RETURN
|
|
*
|
|
* Now test for equivalence if both characters are alphabetic.
|
|
*
|
|
c ZCODE = ICHAR( 'Z' )
|
|
*
|
|
* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
|
|
* machines, on which ICHAR returns a value with bit 8 set.
|
|
* ICHAR('A') on Prime machines returns 193 which is the same as
|
|
* ICHAR('A') on an EBCDIC machine.
|
|
*
|
|
c INTA = ICHAR( CA )
|
|
c INTB = ICHAR( CB )
|
|
*
|
|
c IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
|
|
*
|
|
* ASCII is assumed - ZCODE is the ASCII code of either lower or
|
|
* upper case 'Z'.
|
|
*
|
|
c IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
|
|
c IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
|
|
*
|
|
c ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
|
|
*
|
|
* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
|
|
* upper case 'Z'.
|
|
*
|
|
c IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
|
|
c $ INTA.GE.145 .AND. INTA.LE.153 .OR.
|
|
c $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
|
|
c IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
|
|
c $ INTB.GE.145 .AND. INTB.LE.153 .OR.
|
|
c $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
|
|
*
|
|
c ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
|
|
*
|
|
* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
|
|
* plus 128 of either lower or upper case 'Z'.
|
|
*
|
|
c IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
|
|
c IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
|
|
c END IF
|
|
c LSAME = INTA.EQ.INTB
|
|
*
|
|
* RETURN
|
|
*
|
|
* End of LSAME
|
|
*
|
|
c END
|
|
c$$$ SUBROUTINE XERBLA( SRNAME, INFO )
|
|
c$$$*
|
|
c$$$* -- LAPACK auxiliary routine (version 3.0) --
|
|
c$$$* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
c$$$* Courant Institute, Argonne National Lab, and Rice University
|
|
c$$$* September 30, 1994
|
|
c$$$*
|
|
c$$$* .. Scalar Arguments ..
|
|
c$$$ CHARACTER*6 SRNAME
|
|
c$$$ INTEGER INFO
|
|
c$$$* ..
|
|
c$$$*
|
|
c$$$* Purpose
|
|
c$$$* =======
|
|
c$$$*
|
|
c$$$* XERBLA is an error handler for the LAPACK routines.
|
|
c$$$* It is called by an LAPACK routine if an input parameter has an
|
|
c$$$* invalid value. A message is printed and execution stops.
|
|
c$$$*
|
|
c$$$* Installers may consider modifying the STOP statement in order to
|
|
c$$$* call system-specific exception-handling facilities.
|
|
c$$$*
|
|
c$$$* Arguments
|
|
c$$$* =========
|
|
c$$$*
|
|
c$$$* SRNAME (input) CHARACTER*6
|
|
c$$$* The name of the routine which called XERBLA.
|
|
c$$$*
|
|
c$$$* INFO (input) INTEGER
|
|
c$$$* The position of the invalid parameter in the parameter list
|
|
c$$$* of the calling routine.
|
|
c$$$*
|
|
c$$$* =====================================================================
|
|
c$$$*
|
|
c$$$* .. Executable Statements ..
|
|
c$$$*
|
|
c$$$ WRITE( *, FMT = 9999 )SRNAME, INFO
|
|
c$$$*
|
|
c$$$ STOP
|
|
c$$$*
|
|
c$$$ 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ',
|
|
c$$$ $ 'an illegal value' )
|
|
c$$$*
|
|
c$$$* End of XERBLA
|
|
c$$$*
|
|
c$$$ END |