mirror of https://gitlab.com/QEF/q-e.git
2245 lines
68 KiB
Fortran
2245 lines
68 KiB
Fortran
SUBROUTINE SGEMUL(A,LDA,FORMA,B,LDB,FORMB,C,LDC,L,M,N)
|
|
IMPLICIT NONE
|
|
CHARACTER*1 FORMA,FORMB
|
|
REAL*8 A,B,C
|
|
real*8, allocatable :: auxa(:,:)
|
|
real*8, allocatable :: auxb(:,:)
|
|
real*8, allocatable :: auxc(:,:)
|
|
integer i,j
|
|
INTEGER LDA,LDB,LDC,L,M,N
|
|
DIMENSION A(LDA,*),B(LDB,*),C(LDC,*)
|
|
|
|
INTEGER MM,NN,KK
|
|
|
|
MM = L
|
|
NN = N
|
|
KK = M
|
|
|
|
if(forma.eq.'t' .or. forma.eq.'T') then
|
|
if(formb.eq.'t' .or. formb.eq.'T') then
|
|
allocate(auxc(MM,NN))
|
|
CALL SGEMM('N','N',MM,NN,KK,1.0D0,B,LDB,A,LDA,0.0D0,AUXC,MM)
|
|
call fpmd_transpose(AUXC,MM,C,LDC,NN,MM)
|
|
deallocate(auxc)
|
|
else
|
|
allocate(auxa(MM,KK))
|
|
call fpmd_transpose(A,LDA,AUXA,MM,MM,KK)
|
|
CALL SGEMM('N','N',MM,NN,KK,1.0D0,auxa,MM,B,LDB,0.0D0,C,LDC)
|
|
deallocate(auxa)
|
|
end if
|
|
else if (formb.eq.'t' .or. formb.eq.'T') then
|
|
allocate(auxb(KK,NN))
|
|
call fpmd_transpose(B,LDB,AUXB,KK,KK,NN)
|
|
CALL SGEMM('N','N',MM,NN,KK,1.0D0,A,LDA,auxb,KK,0.0D0,C,LDC)
|
|
deallocate(auxb)
|
|
else
|
|
CALL SGEMM(forma,formb,MM,NN,KK,1.0D0,A,LDA,B,LDB,0.0D0,C,LDC)
|
|
end if
|
|
|
|
RETURN
|
|
END
|
|
SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
|
|
*
|
|
* -- LAPACK auxiliary routine (version 2.0) --
|
|
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
* Courant Institute, Argonne National Lab, and Rice University
|
|
* February 29, 1992
|
|
*
|
|
* .. Scalar Arguments ..
|
|
CHARACTER TYPE
|
|
INTEGER INFO, KL, KU, LDA, M, N
|
|
REAL*8 CFROM, CTO
|
|
* ..
|
|
* .. Array Arguments ..
|
|
REAL*8 A( LDA, * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* SLASCL multiplies the M by N real matrix A by the real scalar
|
|
* CTO/CFROM. This is done without over/underflow as long as the final
|
|
* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
|
|
* A may be full, upper triangular, lower triangular, upper Hessenberg,
|
|
* or banded.
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* TYPE (input) CHARACTER*1
|
|
* TYPE indices the storage type of the input matrix.
|
|
* = 'G': A is a full matrix.
|
|
* = 'L': A is a lower triangular matrix.
|
|
* = 'U': A is an upper triangular matrix.
|
|
* = 'H': A is an upper Hessenberg matrix.
|
|
* = 'B': A is a symmetric band matrix with lower bandwidth KL
|
|
* and upper bandwidth KU and with the only the lower
|
|
* half stored.
|
|
* = 'Q': A is a symmetric band matrix with lower bandwidth KL
|
|
* and upper bandwidth KU and with the only the upper
|
|
* half stored.
|
|
* = 'Z': A is a band matrix with lower bandwidth KL and upper
|
|
* bandwidth KU.
|
|
*
|
|
* KL (input) INTEGER
|
|
* The lower bandwidth of A. Referenced only if TYPE = 'B',
|
|
* 'Q' or 'Z'.
|
|
*
|
|
* KU (input) INTEGER
|
|
* The upper bandwidth of A. Referenced only if TYPE = 'B',
|
|
* 'Q' or 'Z'.
|
|
*
|
|
* CFROM (input) REAL
|
|
* CTO (input) REAL
|
|
* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
|
|
* without over/underflow if the final result CTO*A(I,J)/CFROM
|
|
* can be represented without over/underflow. CFROM must be
|
|
* nonzero.
|
|
*
|
|
* M (input) INTEGER
|
|
* The number of rows of the matrix A. M >= 0.
|
|
*
|
|
* N (input) INTEGER
|
|
* The number of columns of the matrix A. N >= 0.
|
|
*
|
|
* A (input/output) REAL array, dimension (LDA,M)
|
|
* The matrix to be multiplied by CTO/CFROM. See TYPE for the
|
|
* storage type.
|
|
*
|
|
* LDA (input) INTEGER
|
|
* The leading dimension of the array A. LDA >= max(1,M).
|
|
*
|
|
* INFO (output) INTEGER
|
|
* 0 - successful exit
|
|
* <0 - if INFO = -i, the i-th argument had an illegal value.
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
REAL*8 ZERO, ONE
|
|
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
LOGICAL DONE
|
|
INTEGER I, ITYPE, J, K1, K2, K3, K4
|
|
REAL*8 BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
|
|
* ..
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
REAL*8 SLAMCH
|
|
EXTERNAL LSAME, SLAMCH
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, MAX, MIN
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL XERBLA
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input arguments
|
|
*
|
|
INFO = 0
|
|
*
|
|
IF( LSAME( TYPE, 'G' ) ) THEN
|
|
ITYPE = 0
|
|
ELSE IF( LSAME( TYPE, 'L' ) ) THEN
|
|
ITYPE = 1
|
|
ELSE IF( LSAME( TYPE, 'U' ) ) THEN
|
|
ITYPE = 2
|
|
ELSE IF( LSAME( TYPE, 'H' ) ) THEN
|
|
ITYPE = 3
|
|
ELSE IF( LSAME( TYPE, 'B' ) ) THEN
|
|
ITYPE = 4
|
|
ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
|
|
ITYPE = 5
|
|
ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
|
|
ITYPE = 6
|
|
ELSE
|
|
ITYPE = -1
|
|
END IF
|
|
*
|
|
IF( ITYPE.EQ.-1 ) THEN
|
|
INFO = -1
|
|
ELSE IF( CFROM.EQ.ZERO ) THEN
|
|
INFO = -4
|
|
ELSE IF( M.LT.0 ) THEN
|
|
INFO = -6
|
|
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
|
|
$ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
|
|
INFO = -7
|
|
ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
|
|
INFO = -9
|
|
ELSE IF( ITYPE.GE.4 ) THEN
|
|
IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
|
|
INFO = -2
|
|
ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
|
|
$ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
|
|
$ THEN
|
|
INFO = -3
|
|
ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
|
|
$ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
|
|
$ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
|
|
INFO = -9
|
|
END IF
|
|
END IF
|
|
*
|
|
IF( INFO.NE.0 ) THEN
|
|
CALL XERBLA( 'SLASCL', -INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible
|
|
*
|
|
IF( N.EQ.0 .OR. M.EQ.0 )
|
|
$ RETURN
|
|
*
|
|
* Get machine parameters
|
|
*
|
|
SMLNUM = SLAMCH( 'S' )
|
|
BIGNUM = ONE / SMLNUM
|
|
*
|
|
CFROMC = CFROM
|
|
CTOC = CTO
|
|
*
|
|
10 CONTINUE
|
|
CFROM1 = CFROMC*SMLNUM
|
|
CTO1 = CTOC / BIGNUM
|
|
IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
|
|
MUL = SMLNUM
|
|
DONE = .FALSE.
|
|
CFROMC = CFROM1
|
|
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
|
|
MUL = BIGNUM
|
|
DONE = .FALSE.
|
|
CTOC = CTO1
|
|
ELSE
|
|
MUL = CTOC / CFROMC
|
|
DONE = .TRUE.
|
|
END IF
|
|
*
|
|
IF( ITYPE.EQ.0 ) THEN
|
|
*
|
|
* Full matrix
|
|
*
|
|
DO 30 J = 1, N
|
|
DO 20 I = 1, M
|
|
A( I, J ) = A( I, J )*MUL
|
|
20 CONTINUE
|
|
30 CONTINUE
|
|
*
|
|
ELSE IF( ITYPE.EQ.1 ) THEN
|
|
*
|
|
* Lower triangular matrix
|
|
*
|
|
DO 50 J = 1, N
|
|
DO 40 I = J, M
|
|
A( I, J ) = A( I, J )*MUL
|
|
40 CONTINUE
|
|
50 CONTINUE
|
|
*
|
|
ELSE IF( ITYPE.EQ.2 ) THEN
|
|
*
|
|
* Upper triangular matrix
|
|
*
|
|
DO 70 J = 1, N
|
|
DO 60 I = 1, MIN( J, M )
|
|
A( I, J ) = A( I, J )*MUL
|
|
60 CONTINUE
|
|
70 CONTINUE
|
|
*
|
|
ELSE IF( ITYPE.EQ.3 ) THEN
|
|
*
|
|
* Upper Hessenberg matrix
|
|
*
|
|
DO 90 J = 1, N
|
|
DO 80 I = 1, MIN( J+1, M )
|
|
A( I, J ) = A( I, J )*MUL
|
|
80 CONTINUE
|
|
90 CONTINUE
|
|
*
|
|
ELSE IF( ITYPE.EQ.4 ) THEN
|
|
*
|
|
* Lower half of a symmetric band matrix
|
|
*
|
|
K3 = KL + 1
|
|
K4 = N + 1
|
|
DO 110 J = 1, N
|
|
DO 100 I = 1, MIN( K3, K4-J )
|
|
A( I, J ) = A( I, J )*MUL
|
|
100 CONTINUE
|
|
110 CONTINUE
|
|
*
|
|
ELSE IF( ITYPE.EQ.5 ) THEN
|
|
*
|
|
* Upper half of a symmetric band matrix
|
|
*
|
|
K1 = KU + 2
|
|
K3 = KU + 1
|
|
DO 130 J = 1, N
|
|
DO 120 I = MAX( K1-J, 1 ), K3
|
|
A( I, J ) = A( I, J )*MUL
|
|
120 CONTINUE
|
|
130 CONTINUE
|
|
*
|
|
ELSE IF( ITYPE.EQ.6 ) THEN
|
|
*
|
|
* Band matrix
|
|
*
|
|
K1 = KL + KU + 2
|
|
K2 = KL + 1
|
|
K3 = 2*KL + KU + 1
|
|
K4 = KL + KU + 1 + M
|
|
DO 150 J = 1, N
|
|
DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
|
|
A( I, J ) = A( I, J )*MUL
|
|
140 CONTINUE
|
|
150 CONTINUE
|
|
*
|
|
END IF
|
|
*
|
|
IF( .NOT.DONE )
|
|
$ GO TO 10
|
|
*
|
|
RETURN
|
|
*
|
|
* End of SLASCL
|
|
*
|
|
END
|
|
SUBROUTINE SLAE2( A, B, C, RT1, RT2 )
|
|
*
|
|
* -- LAPACK auxiliary routine (version 2.0) --
|
|
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
* Courant Institute, Argonne National Lab, and Rice University
|
|
* October 31, 1992
|
|
*
|
|
* .. Scalar Arguments ..
|
|
REAL*8 A, B, C, RT1, RT2
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix
|
|
* [ A B ]
|
|
* [ B C ].
|
|
* On return, RT1 is the eigenvalue of larger absolute value, and RT2
|
|
* is the eigenvalue of smaller absolute value.
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* A (input) REAL
|
|
* The (1,1) element of the 2-by-2 matrix.
|
|
*
|
|
* B (input) REAL
|
|
* The (1,2) and (2,1) elements of the 2-by-2 matrix.
|
|
*
|
|
* C (input) REAL
|
|
* The (2,2) element of the 2-by-2 matrix.
|
|
*
|
|
* RT1 (output) REAL
|
|
* The eigenvalue of larger absolute value.
|
|
*
|
|
* RT2 (output) REAL
|
|
* The eigenvalue of smaller absolute value.
|
|
*
|
|
* Further Details
|
|
* ===============
|
|
*
|
|
* RT1 is accurate to a few ulps barring over/underflow.
|
|
*
|
|
* RT2 may be inaccurate if there is massive cancellation in the
|
|
* determinant A*C-B*B; higher precision or correctly rounded or
|
|
* correctly truncated arithmetic would be needed to compute RT2
|
|
* accurately in all cases.
|
|
*
|
|
* Overflow is possible only if RT1 is within a factor of 5 of overflow.
|
|
* Underflow is harmless if the input data is 0 or exceeds
|
|
* underflow_threshold / macheps.
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
REAL*8 ONE
|
|
PARAMETER ( ONE = 1.0E0 )
|
|
REAL*8 TWO
|
|
PARAMETER ( TWO = 2.0E0 )
|
|
REAL*8 ZERO
|
|
PARAMETER ( ZERO = 0.0E0 )
|
|
REAL*8 HALF
|
|
PARAMETER ( HALF = 0.5E0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
REAL*8 AB, ACMN, ACMX, ADF, DF, RT, SM, TB
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, SQRT
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Compute the eigenvalues
|
|
*
|
|
SM = A + C
|
|
DF = A - C
|
|
ADF = ABS( DF )
|
|
TB = B + B
|
|
AB = ABS( TB )
|
|
IF( ABS( A ).GT.ABS( C ) ) THEN
|
|
ACMX = A
|
|
ACMN = C
|
|
ELSE
|
|
ACMX = C
|
|
ACMN = A
|
|
END IF
|
|
IF( ADF.GT.AB ) THEN
|
|
RT = ADF*SQRT( ONE+( AB / ADF )**2 )
|
|
ELSE IF( ADF.LT.AB ) THEN
|
|
RT = AB*SQRT( ONE+( ADF / AB )**2 )
|
|
ELSE
|
|
*
|
|
* Includes case AB=ADF=0
|
|
*
|
|
RT = AB*SQRT( TWO )
|
|
END IF
|
|
IF( SM.LT.ZERO ) THEN
|
|
RT1 = HALF*( SM-RT )
|
|
*
|
|
* Order of execution important.
|
|
* To get fully accurate smaller eigenvalue,
|
|
* next line needs to be executed in higher precision.
|
|
*
|
|
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
|
|
ELSE IF( SM.GT.ZERO ) THEN
|
|
RT1 = HALF*( SM+RT )
|
|
*
|
|
* Order of execution important.
|
|
* To get fully accurate smaller eigenvalue,
|
|
* next line needs to be executed in higher precision.
|
|
*
|
|
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
|
|
ELSE
|
|
*
|
|
* Includes case RT1 = RT2 = 0
|
|
*
|
|
RT1 = HALF*RT
|
|
RT2 = -HALF*RT
|
|
END IF
|
|
RETURN
|
|
*
|
|
* End of SLAE2
|
|
*
|
|
END
|
|
SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
|
|
*
|
|
* -- LAPACK auxiliary routine (version 2.0) --
|
|
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
* Courant Institute, Argonne National Lab, and Rice University
|
|
* October 31, 1992
|
|
*
|
|
* .. Scalar Arguments ..
|
|
REAL*8 A, B, C, CS1, RT1, RT2, SN1
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
|
|
* [ A B ]
|
|
* [ B C ].
|
|
* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
|
|
* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
|
|
* eigenvector for RT1, giving the decomposition
|
|
*
|
|
* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]
|
|
* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* A (input) REAL
|
|
* The (1,1) element of the 2-by-2 matrix.
|
|
*
|
|
* B (input) REAL
|
|
* The (1,2) element and the conjugate of the (2,1) element of
|
|
* the 2-by-2 matrix.
|
|
*
|
|
* C (input) REAL
|
|
* The (2,2) element of the 2-by-2 matrix.
|
|
*
|
|
* RT1 (output) REAL
|
|
* The eigenvalue of larger absolute value.
|
|
*
|
|
* RT2 (output) REAL
|
|
* The eigenvalue of smaller absolute value.
|
|
*
|
|
* CS1 (output) REAL
|
|
* SN1 (output) REAL
|
|
* The vector (CS1, SN1) is a unit right eigenvector for RT1.
|
|
*
|
|
* Further Details
|
|
* ===============
|
|
*
|
|
* RT1 is accurate to a few ulps barring over/underflow.
|
|
*
|
|
* RT2 may be inaccurate if there is massive cancellation in the
|
|
* determinant A*C-B*B; higher precision or correctly rounded or
|
|
* correctly truncated arithmetic would be needed to compute RT2
|
|
* accurately in all cases.
|
|
*
|
|
* CS1 and SN1 are accurate to a few ulps barring over/underflow.
|
|
*
|
|
* Overflow is possible only if RT1 is within a factor of 5 of overflow.
|
|
* Underflow is harmless if the input data is 0 or exceeds
|
|
* underflow_threshold / macheps.
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
REAL*8 ONE
|
|
PARAMETER ( ONE = 1.0E0 )
|
|
REAL*8 TWO
|
|
PARAMETER ( TWO = 2.0E0 )
|
|
REAL*8 ZERO
|
|
PARAMETER ( ZERO = 0.0E0 )
|
|
REAL*8 HALF
|
|
PARAMETER ( HALF = 0.5E0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
INTEGER SGN1, SGN2
|
|
REAL*8 AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
|
|
$ TB, TN
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, SQRT
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Compute the eigenvalues
|
|
*
|
|
SM = A + C
|
|
DF = A - C
|
|
ADF = ABS( DF )
|
|
TB = B + B
|
|
AB = ABS( TB )
|
|
IF( ABS( A ).GT.ABS( C ) ) THEN
|
|
ACMX = A
|
|
ACMN = C
|
|
ELSE
|
|
ACMX = C
|
|
ACMN = A
|
|
END IF
|
|
IF( ADF.GT.AB ) THEN
|
|
RT = ADF*SQRT( ONE+( AB / ADF )**2 )
|
|
ELSE IF( ADF.LT.AB ) THEN
|
|
RT = AB*SQRT( ONE+( ADF / AB )**2 )
|
|
ELSE
|
|
*
|
|
* Includes case AB=ADF=0
|
|
*
|
|
RT = AB*SQRT( TWO )
|
|
END IF
|
|
IF( SM.LT.ZERO ) THEN
|
|
RT1 = HALF*( SM-RT )
|
|
SGN1 = -1
|
|
*
|
|
* Order of execution important.
|
|
* To get fully accurate smaller eigenvalue,
|
|
* next line needs to be executed in higher precision.
|
|
*
|
|
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
|
|
ELSE IF( SM.GT.ZERO ) THEN
|
|
RT1 = HALF*( SM+RT )
|
|
SGN1 = 1
|
|
*
|
|
* Order of execution important.
|
|
* To get fully accurate smaller eigenvalue,
|
|
* next line needs to be executed in higher precision.
|
|
*
|
|
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
|
|
ELSE
|
|
*
|
|
* Includes case RT1 = RT2 = 0
|
|
*
|
|
RT1 = HALF*RT
|
|
RT2 = -HALF*RT
|
|
SGN1 = 1
|
|
END IF
|
|
*
|
|
* Compute the eigenvector
|
|
*
|
|
IF( DF.GE.ZERO ) THEN
|
|
CS = DF + RT
|
|
SGN2 = 1
|
|
ELSE
|
|
CS = DF - RT
|
|
SGN2 = -1
|
|
END IF
|
|
ACS = ABS( CS )
|
|
IF( ACS.GT.AB ) THEN
|
|
CT = -TB / CS
|
|
SN1 = ONE / SQRT( ONE+CT*CT )
|
|
CS1 = CT*SN1
|
|
ELSE
|
|
IF( AB.EQ.ZERO ) THEN
|
|
CS1 = ONE
|
|
SN1 = ZERO
|
|
ELSE
|
|
TN = -CS / TB
|
|
CS1 = ONE / SQRT( ONE+TN*TN )
|
|
SN1 = TN*CS1
|
|
END IF
|
|
END IF
|
|
IF( SGN1.EQ.SGN2 ) THEN
|
|
TN = CS1
|
|
CS1 = -SN1
|
|
SN1 = TN
|
|
END IF
|
|
RETURN
|
|
*
|
|
* End of SLAEV2
|
|
*
|
|
END
|
|
REAL*8 FUNCTION SLANST( NORM, N, D, E )
|
|
*
|
|
* -- LAPACK auxiliary routine (version 2.0) --
|
|
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
* Courant Institute, Argonne National Lab, and Rice University
|
|
* February 29, 1992
|
|
*
|
|
* .. Scalar Arguments ..
|
|
CHARACTER NORM
|
|
INTEGER N
|
|
* ..
|
|
* .. Array Arguments ..
|
|
REAL*8 D( * ), E( * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* SLANST returns the value of the one norm, or the Frobenius norm, or
|
|
* the infinity norm, or the element of largest absolute value of a
|
|
* real symmetric tridiagonal matrix A.
|
|
*
|
|
* Description
|
|
* ===========
|
|
*
|
|
* SLANST returns the value
|
|
*
|
|
* SLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'
|
|
* (
|
|
* ( norm1(A), NORM = '1', 'O' or 'o'
|
|
* (
|
|
* ( normI(A), NORM = 'I' or 'i'
|
|
* (
|
|
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
|
|
*
|
|
* where norm1 denotes the one norm of a matrix (maximum column sum),
|
|
* normI denotes the infinity norm of a matrix (maximum row sum) and
|
|
* normF denotes the Frobenius norm of a matrix (square root of sum of
|
|
* squares). Note that max(abs(A(i,j))) is not a matrix norm.
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* NORM (input) CHARACTER*1
|
|
* Specifies the value to be returned in SLANST as described
|
|
* above.
|
|
*
|
|
* N (input) INTEGER
|
|
* The order of the matrix A. N >= 0. When N = 0, SLANST is
|
|
* set to zero.
|
|
*
|
|
* D (input) REAL array, dimension (N)
|
|
* The diagonal elements of A.
|
|
*
|
|
* E (input) REAL array, dimension (N-1)
|
|
* The (n-1) sub-diagonal or super-diagonal elements of A.
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
REAL*8 ONE, ZERO
|
|
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
INTEGER I
|
|
REAL*8 ANORM, SCALE, SUM
|
|
* ..
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL SLASSQ
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, MAX, SQRT
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
IF( N.LE.0 ) THEN
|
|
ANORM = ZERO
|
|
ELSE IF( LSAME( NORM, 'M' ) ) THEN
|
|
*
|
|
* Find max(abs(A(i,j))).
|
|
*
|
|
ANORM = ABS( D( N ) )
|
|
DO 10 I = 1, N - 1
|
|
ANORM = MAX( ANORM, ABS( D( I ) ) )
|
|
ANORM = MAX( ANORM, ABS( E( I ) ) )
|
|
10 CONTINUE
|
|
ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR.
|
|
$ LSAME( NORM, 'I' ) ) THEN
|
|
*
|
|
* Find norm1(A).
|
|
*
|
|
IF( N.EQ.1 ) THEN
|
|
ANORM = ABS( D( 1 ) )
|
|
ELSE
|
|
ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
|
|
$ ABS( E( N-1 ) )+ABS( D( N ) ) )
|
|
DO 20 I = 2, N - 1
|
|
ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+
|
|
$ ABS( E( I-1 ) ) )
|
|
20 CONTINUE
|
|
END IF
|
|
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
|
|
*
|
|
* Find normF(A).
|
|
*
|
|
SCALE = ZERO
|
|
SUM = ONE
|
|
IF( N.GT.1 ) THEN
|
|
CALL SLASSQ( N-1, E, 1, SCALE, SUM )
|
|
SUM = 2*SUM
|
|
END IF
|
|
CALL SLASSQ( N, D, 1, SCALE, SUM )
|
|
ANORM = SCALE*SQRT( SUM )
|
|
END IF
|
|
*
|
|
SLANST = ANORM
|
|
RETURN
|
|
*
|
|
* End of SLANST
|
|
*
|
|
END
|
|
SUBROUTINE CGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
|
|
$ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
|
|
*
|
|
* -- LAPACK driver 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 ..
|
|
CHARACTER JOBVL, JOBVR
|
|
INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
|
|
* ..
|
|
* .. Array Arguments ..
|
|
REAL RWORK( * )
|
|
COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ),
|
|
$ BETA( * ), VL( LDVL, * ), VR( LDVR, * ),
|
|
$ WORK( * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* CGGEV computes for a pair of N-by-N complex nonsymmetric matrices
|
|
* (A,B), the generalized eigenvalues, and optionally, the left and/or
|
|
* right generalized eigenvectors.
|
|
*
|
|
* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
|
|
* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
|
|
* singular. It is usually represented as the pair (alpha,beta), as
|
|
* there is a reasonable interpretation for beta=0, and even for both
|
|
* being zero.
|
|
*
|
|
* The right generalized eigenvector v(j) corresponding to the
|
|
* generalized eigenvalue lambda(j) of (A,B) satisfies
|
|
*
|
|
* A * v(j) = lambda(j) * B * v(j).
|
|
*
|
|
* The left generalized eigenvector u(j) corresponding to the
|
|
* generalized eigenvalues lambda(j) of (A,B) satisfies
|
|
*
|
|
* u(j)**H * A = lambda(j) * u(j)**H * B
|
|
*
|
|
* where u(j)**H is the conjugate-transpose of u(j).
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* JOBVL (input) CHARACTER*1
|
|
* = 'N': do not compute the left generalized eigenvectors;
|
|
* = 'V': compute the left generalized eigenvectors.
|
|
*
|
|
* JOBVR (input) CHARACTER*1
|
|
* = 'N': do not compute the right generalized eigenvectors;
|
|
* = 'V': compute the right generalized eigenvectors.
|
|
*
|
|
* N (input) INTEGER
|
|
* The order of the matrices A, B, VL, and VR. N >= 0.
|
|
*
|
|
* A (input/output) COMPLEX array, dimension (LDA, N)
|
|
* On entry, the matrix A in the pair (A,B).
|
|
* On exit, A has been overwritten.
|
|
*
|
|
* LDA (input) INTEGER
|
|
* The leading dimension of A. LDA >= max(1,N).
|
|
*
|
|
* B (input/output) COMPLEX array, dimension (LDB, N)
|
|
* On entry, the matrix B in the pair (A,B).
|
|
* On exit, B has been overwritten.
|
|
*
|
|
* LDB (input) INTEGER
|
|
* The leading dimension of B. LDB >= max(1,N).
|
|
*
|
|
* ALPHA (output) COMPLEX array, dimension (N)
|
|
* BETA (output) COMPLEX array, dimension (N)
|
|
* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
|
|
* generalized eigenvalues.
|
|
*
|
|
* Note: the quotients ALPHA(j)/BETA(j) may easily over- or
|
|
* underflow, and BETA(j) may even be zero. Thus, the user
|
|
* should avoid naively computing the ratio alpha/beta.
|
|
* However, ALPHA will be always less than and usually
|
|
* comparable with norm(A) in magnitude, and BETA always less
|
|
* than and usually comparable with norm(B).
|
|
*
|
|
* VL (output) COMPLEX array, dimension (LDVL,N)
|
|
* If JOBVL = 'V', the left generalized eigenvectors u(j) are
|
|
* stored one after another in the columns of VL, in the same
|
|
* order as their eigenvalues.
|
|
* Each eigenvector will be scaled so the largest component
|
|
* will have abs(real part) + abs(imag. part) = 1.
|
|
* Not referenced if JOBVL = 'N'.
|
|
*
|
|
* LDVL (input) INTEGER
|
|
* The leading dimension of the matrix VL. LDVL >= 1, and
|
|
* if JOBVL = 'V', LDVL >= N.
|
|
*
|
|
* VR (output) COMPLEX array, dimension (LDVR,N)
|
|
* If JOBVR = 'V', the right generalized eigenvectors v(j) are
|
|
* stored one after another in the columns of VR, in the same
|
|
* order as their eigenvalues.
|
|
* Each eigenvector will be scaled so the largest component
|
|
* will have abs(real part) + abs(imag. part) = 1.
|
|
* Not referenced if JOBVR = 'N'.
|
|
*
|
|
* LDVR (input) INTEGER
|
|
* The leading dimension of the matrix VR. LDVR >= 1, and
|
|
* if JOBVR = 'V', LDVR >= N.
|
|
*
|
|
* WORK (workspace/output) COMPLEX array, dimension (LWORK)
|
|
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
|
*
|
|
* LWORK (input) INTEGER
|
|
* The dimension of the array WORK. LWORK >= max(1,2*N).
|
|
* For good performance, LWORK must generally be larger.
|
|
*
|
|
* 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.
|
|
*
|
|
* RWORK (workspace/output) REAL array, dimension (8*N)
|
|
*
|
|
* INFO (output) INTEGER
|
|
* = 0: successful exit
|
|
* < 0: if INFO = -i, the i-th argument had an illegal value.
|
|
* =1,...,N:
|
|
* The QZ iteration failed. No eigenvectors have been
|
|
* calculated, but ALPHA(j) and BETA(j) should be
|
|
* correct for j=INFO+1,...,N.
|
|
* > N: =N+1: other then QZ iteration failed in SHGEQZ,
|
|
* =N+2: error return from STGEVC.
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
REAL ZERO, ONE
|
|
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
|
|
COMPLEX CZERO, CONE
|
|
PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ),
|
|
$ CONE = ( 1.0E0, 0.0E0 ) )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
|
|
CHARACTER CHTEMP
|
|
INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
|
|
$ IN, IRIGHT, IROWS, IRWRK, ITAU, IWRK, JC, JR,
|
|
$ LWKMIN, LWKOPT
|
|
REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
|
|
$ SMLNUM, TEMP
|
|
COMPLEX X
|
|
* ..
|
|
* .. Local Arrays ..
|
|
LOGICAL LDUMMA( 1 )
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL CGEQRF, CGGBAK, CGGBAL, CGGHRD, CHGEQZ, CLACPY,
|
|
$ CLASCL, CLASET, CTGEVC, CUNGQR, CUNMQR, SLABAD,
|
|
$ XERBLA
|
|
* ..
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
INTEGER ILAENV
|
|
REAL CLANGE, SLAMCH
|
|
EXTERNAL LSAME, ILAENV, CLANGE, SLAMCH
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, AIMAG, MAX, REAL, SQRT
|
|
* ..
|
|
* .. Statement Functions ..
|
|
REAL ABS1
|
|
* ..
|
|
* .. Statement Function definitions ..
|
|
ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) )
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Decode the input arguments
|
|
*
|
|
IF( LSAME( JOBVL, 'N' ) ) THEN
|
|
IJOBVL = 1
|
|
ILVL = .FALSE.
|
|
ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
|
|
IJOBVL = 2
|
|
ILVL = .TRUE.
|
|
ELSE
|
|
IJOBVL = -1
|
|
ILVL = .FALSE.
|
|
END IF
|
|
*
|
|
IF( LSAME( JOBVR, 'N' ) ) THEN
|
|
IJOBVR = 1
|
|
ILVR = .FALSE.
|
|
ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
|
|
IJOBVR = 2
|
|
ILVR = .TRUE.
|
|
ELSE
|
|
IJOBVR = -1
|
|
ILVR = .FALSE.
|
|
END IF
|
|
ILV = ILVL .OR. ILVR
|
|
*
|
|
* Test the input arguments
|
|
*
|
|
INFO = 0
|
|
LQUERY = ( LWORK.EQ.-1 )
|
|
IF( IJOBVL.LE.0 ) THEN
|
|
INFO = -1
|
|
ELSE IF( IJOBVR.LE.0 ) THEN
|
|
INFO = -2
|
|
ELSE IF( N.LT.0 ) THEN
|
|
INFO = -3
|
|
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
|
INFO = -5
|
|
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
|
|
INFO = -7
|
|
ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
|
|
INFO = -11
|
|
ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
|
|
INFO = -13
|
|
END IF
|
|
*
|
|
* Compute workspace
|
|
* (Note: Comments in the code beginning "Workspace:" describe the
|
|
* minimal amount of workspace needed at that point in the code,
|
|
* as well as the preferred amount for good performance.
|
|
* NB refers to the optimal block size for the immediately
|
|
* following subroutine, as returned by ILAENV. The workspace is
|
|
* computed assuming ILO = 1 and IHI = N, the worst case.)
|
|
*
|
|
LWKMIN = 1
|
|
IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
|
|
LWKOPT = N + N*ILAENV( 1, 'CGEQRF', ' ', N, 1, N, 0 )
|
|
LWKMIN = MAX( 1, 2*N )
|
|
WORK( 1 ) = LWKOPT
|
|
END IF
|
|
*
|
|
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
|
|
$ INFO = -15
|
|
*
|
|
IF( INFO.NE.0 ) THEN
|
|
CALL XERBLA( 'CGGEV ', -INFO )
|
|
RETURN
|
|
ELSE IF( LQUERY ) THEN
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible
|
|
*
|
|
WORK( 1 ) = LWKOPT
|
|
IF( N.EQ.0 )
|
|
$ RETURN
|
|
*
|
|
* Get machine constants
|
|
*
|
|
EPS = SLAMCH( 'E' )*SLAMCH( 'B' )
|
|
SMLNUM = SLAMCH( 'S' )
|
|
BIGNUM = ONE / SMLNUM
|
|
CALL SLABAD( SMLNUM, BIGNUM )
|
|
SMLNUM = SQRT( SMLNUM ) / EPS
|
|
BIGNUM = ONE / SMLNUM
|
|
*
|
|
* Scale A if max element outside range [SMLNUM,BIGNUM]
|
|
*
|
|
ANRM = CLANGE( 'M', N, N, A, LDA, RWORK )
|
|
ILASCL = .FALSE.
|
|
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
|
|
ANRMTO = SMLNUM
|
|
ILASCL = .TRUE.
|
|
ELSE IF( ANRM.GT.BIGNUM ) THEN
|
|
ANRMTO = BIGNUM
|
|
ILASCL = .TRUE.
|
|
END IF
|
|
IF( ILASCL )
|
|
$ CALL CLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
|
|
*
|
|
* Scale B if max element outside range [SMLNUM,BIGNUM]
|
|
*
|
|
BNRM = CLANGE( 'M', N, N, B, LDB, RWORK )
|
|
ILBSCL = .FALSE.
|
|
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
|
|
BNRMTO = SMLNUM
|
|
ILBSCL = .TRUE.
|
|
ELSE IF( BNRM.GT.BIGNUM ) THEN
|
|
BNRMTO = BIGNUM
|
|
ILBSCL = .TRUE.
|
|
END IF
|
|
IF( ILBSCL )
|
|
$ CALL CLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
|
|
*
|
|
* Permute the matrices A, B to isolate eigenvalues if possible
|
|
* (Real Workspace: need 6*N)
|
|
*
|
|
ILEFT = 1
|
|
IRIGHT = N + 1
|
|
IRWRK = IRIGHT + N
|
|
CALL CGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ),
|
|
$ RWORK( IRIGHT ), RWORK( IRWRK ), IERR )
|
|
*
|
|
* Reduce B to triangular form (QR decomposition of B)
|
|
* (Complex Workspace: need N, prefer N*NB)
|
|
*
|
|
IROWS = IHI + 1 - ILO
|
|
IF( ILV ) THEN
|
|
ICOLS = N + 1 - ILO
|
|
ELSE
|
|
ICOLS = IROWS
|
|
END IF
|
|
ITAU = 1
|
|
IWRK = ITAU + IROWS
|
|
CALL CGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
|
|
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
|
|
*
|
|
* Apply the orthogonal transformation to matrix A
|
|
* (Complex Workspace: need N, prefer N*NB)
|
|
*
|
|
CALL CUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
|
|
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
|
|
$ LWORK+1-IWRK, IERR )
|
|
*
|
|
* Initialize VL
|
|
* (Complex Workspace: need N, prefer N*NB)
|
|
*
|
|
IF( ILVL ) THEN
|
|
CALL CLASET( 'Full', N, N, CZERO, CONE, VL, LDVL )
|
|
CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
|
|
$ VL( ILO+1, ILO ), LDVL )
|
|
CALL CUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
|
|
$ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
|
|
END IF
|
|
*
|
|
* Initialize VR
|
|
*
|
|
IF( ILVR )
|
|
$ CALL CLASET( 'Full', N, N, CZERO, CONE, VR, LDVR )
|
|
*
|
|
* Reduce to generalized Hessenberg form
|
|
*
|
|
IF( ILV ) THEN
|
|
*
|
|
* Eigenvectors requested -- work on whole matrix.
|
|
*
|
|
CALL CGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
|
|
$ LDVL, VR, LDVR, IERR )
|
|
ELSE
|
|
CALL CGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
|
|
$ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
|
|
END IF
|
|
*
|
|
* Perform QZ algorithm (Compute eigenvalues, and optionally, the
|
|
* Schur form and Schur vectors)
|
|
* (Complex Workspace: need N)
|
|
* (Real Workspace: need N)
|
|
*
|
|
IWRK = ITAU
|
|
IF( ILV ) THEN
|
|
CHTEMP = 'S'
|
|
ELSE
|
|
CHTEMP = 'E'
|
|
END IF
|
|
CALL CHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
|
|
$ ALPHA, BETA, VL, LDVL, VR, LDVR, WORK( IWRK ),
|
|
$ LWORK+1-IWRK, RWORK( IRWRK ), IERR )
|
|
IF( IERR.NE.0 ) THEN
|
|
IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
|
|
INFO = IERR
|
|
ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
|
|
INFO = IERR - N
|
|
ELSE
|
|
INFO = N + 1
|
|
END IF
|
|
GO TO 70
|
|
END IF
|
|
*
|
|
* Compute Eigenvectors
|
|
* (Real Workspace: need 2*N)
|
|
* (Complex Workspace: need 2*N)
|
|
*
|
|
IF( ILV ) THEN
|
|
IF( ILVL ) THEN
|
|
IF( ILVR ) THEN
|
|
CHTEMP = 'B'
|
|
ELSE
|
|
CHTEMP = 'L'
|
|
END IF
|
|
ELSE
|
|
CHTEMP = 'R'
|
|
END IF
|
|
*
|
|
CALL CTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
|
|
$ VR, LDVR, N, IN, WORK( IWRK ), RWORK( IRWRK ),
|
|
$ IERR )
|
|
IF( IERR.NE.0 ) THEN
|
|
INFO = N + 2
|
|
GO TO 70
|
|
END IF
|
|
*
|
|
* Undo balancing on VL and VR and normalization
|
|
* (Workspace: none needed)
|
|
*
|
|
IF( ILVL ) THEN
|
|
CALL CGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
|
|
$ RWORK( IRIGHT ), N, VL, LDVL, IERR )
|
|
DO 30 JC = 1, N
|
|
TEMP = ZERO
|
|
DO 10 JR = 1, N
|
|
TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) )
|
|
10 CONTINUE
|
|
IF( TEMP.LT.SMLNUM )
|
|
$ GO TO 30
|
|
TEMP = ONE / TEMP
|
|
DO 20 JR = 1, N
|
|
VL( JR, JC ) = VL( JR, JC )*TEMP
|
|
20 CONTINUE
|
|
30 CONTINUE
|
|
END IF
|
|
IF( ILVR ) THEN
|
|
CALL CGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
|
|
$ RWORK( IRIGHT ), N, VR, LDVR, IERR )
|
|
DO 60 JC = 1, N
|
|
TEMP = ZERO
|
|
DO 40 JR = 1, N
|
|
TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) )
|
|
40 CONTINUE
|
|
IF( TEMP.LT.SMLNUM )
|
|
$ GO TO 60
|
|
TEMP = ONE / TEMP
|
|
DO 50 JR = 1, N
|
|
VR( JR, JC ) = VR( JR, JC )*TEMP
|
|
50 CONTINUE
|
|
60 CONTINUE
|
|
END IF
|
|
END IF
|
|
*
|
|
* Undo scaling if necessary
|
|
*
|
|
IF( ILASCL )
|
|
$ CALL CLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
|
|
*
|
|
IF( ILBSCL )
|
|
$ CALL CLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
|
|
*
|
|
70 CONTINUE
|
|
WORK( 1 ) = LWKOPT
|
|
*
|
|
RETURN
|
|
*
|
|
* End of CGGEV
|
|
*
|
|
END
|
|
REAL FUNCTION CLANGE( NORM, M, N, A, LDA, WORK )
|
|
*
|
|
* -- LAPACK auxiliary routine (version 3.0) --
|
|
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
* Courant Institute, Argonne National Lab, and Rice University
|
|
* October 31, 1992
|
|
*
|
|
* .. Scalar Arguments ..
|
|
CHARACTER NORM
|
|
INTEGER LDA, M, N
|
|
* ..
|
|
* .. Array Arguments ..
|
|
REAL WORK( * )
|
|
COMPLEX A( LDA, * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* CLANGE returns the value of the one norm, or the Frobenius norm, or
|
|
* the infinity norm, or the element of largest absolute value of a
|
|
* complex matrix A.
|
|
*
|
|
* Description
|
|
* ===========
|
|
*
|
|
* CLANGE returns the value
|
|
*
|
|
* CLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
|
|
* (
|
|
* ( norm1(A), NORM = '1', 'O' or 'o'
|
|
* (
|
|
* ( normI(A), NORM = 'I' or 'i'
|
|
* (
|
|
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
|
|
*
|
|
* where norm1 denotes the one norm of a matrix (maximum column sum),
|
|
* normI denotes the infinity norm of a matrix (maximum row sum) and
|
|
* normF denotes the Frobenius norm of a matrix (square root of sum of
|
|
* squares). Note that max(abs(A(i,j))) is not a matrix norm.
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* NORM (input) CHARACTER*1
|
|
* Specifies the value to be returned in CLANGE as described
|
|
* above.
|
|
*
|
|
* M (input) INTEGER
|
|
* The number of rows of the matrix A. M >= 0. When M = 0,
|
|
* CLANGE is set to zero.
|
|
*
|
|
* N (input) INTEGER
|
|
* The number of columns of the matrix A. N >= 0. When N = 0,
|
|
* CLANGE is set to zero.
|
|
*
|
|
* A (input) COMPLEX array, dimension (LDA,N)
|
|
* The m by n matrix A.
|
|
*
|
|
* LDA (input) INTEGER
|
|
* The leading dimension of the array A. LDA >= max(M,1).
|
|
*
|
|
* WORK (workspace) REAL array, dimension (LWORK),
|
|
* where LWORK >= M when NORM = 'I'; otherwise, WORK is not
|
|
* referenced.
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
REAL ONE, ZERO
|
|
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
INTEGER I, J
|
|
REAL SCALE, SUM, VALUE
|
|
* ..
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
EXTERNAL LSAME
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL CLASSQ
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, MAX, MIN, SQRT
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
IF( MIN( M, N ).EQ.0 ) THEN
|
|
VALUE = ZERO
|
|
ELSE IF( LSAME( NORM, 'M' ) ) THEN
|
|
*
|
|
* Find max(abs(A(i,j))).
|
|
*
|
|
VALUE = ZERO
|
|
DO 20 J = 1, N
|
|
DO 10 I = 1, M
|
|
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
|
|
10 CONTINUE
|
|
20 CONTINUE
|
|
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
|
|
*
|
|
* Find norm1(A).
|
|
*
|
|
VALUE = ZERO
|
|
DO 40 J = 1, N
|
|
SUM = ZERO
|
|
DO 30 I = 1, M
|
|
SUM = SUM + ABS( A( I, J ) )
|
|
30 CONTINUE
|
|
VALUE = MAX( VALUE, SUM )
|
|
40 CONTINUE
|
|
ELSE IF( LSAME( NORM, 'I' ) ) THEN
|
|
*
|
|
* Find normI(A).
|
|
*
|
|
DO 50 I = 1, M
|
|
WORK( I ) = ZERO
|
|
50 CONTINUE
|
|
DO 70 J = 1, N
|
|
DO 60 I = 1, M
|
|
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
|
|
60 CONTINUE
|
|
70 CONTINUE
|
|
VALUE = ZERO
|
|
DO 80 I = 1, M
|
|
VALUE = MAX( VALUE, WORK( I ) )
|
|
80 CONTINUE
|
|
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
|
|
*
|
|
* Find normF(A).
|
|
*
|
|
SCALE = ZERO
|
|
SUM = ONE
|
|
DO 90 J = 1, N
|
|
CALL CLASSQ( M, A( 1, J ), 1, SCALE, SUM )
|
|
90 CONTINUE
|
|
VALUE = SCALE*SQRT( SUM )
|
|
END IF
|
|
*
|
|
CLANGE = VALUE
|
|
RETURN
|
|
*
|
|
* End of CLANGE
|
|
*
|
|
END
|
|
SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
|
|
*
|
|
* -- LAPACK auxiliary 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 TYPE
|
|
INTEGER INFO, KL, KU, LDA, M, N
|
|
REAL CFROM, CTO
|
|
* ..
|
|
* .. Array Arguments ..
|
|
COMPLEX A( LDA, * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* CLASCL multiplies the M by N complex matrix A by the real scalar
|
|
* CTO/CFROM. This is done without over/underflow as long as the final
|
|
* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
|
|
* A may be full, upper triangular, lower triangular, upper Hessenberg,
|
|
* or banded.
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* TYPE (input) CHARACTER*1
|
|
* TYPE indices the storage type of the input matrix.
|
|
* = 'G': A is a full matrix.
|
|
* = 'L': A is a lower triangular matrix.
|
|
* = 'U': A is an upper triangular matrix.
|
|
* = 'H': A is an upper Hessenberg matrix.
|
|
* = 'B': A is a symmetric band matrix with lower bandwidth KL
|
|
* and upper bandwidth KU and with the only the lower
|
|
* half stored.
|
|
* = 'Q': A is a symmetric band matrix with lower bandwidth KL
|
|
* and upper bandwidth KU and with the only the upper
|
|
* half stored.
|
|
* = 'Z': A is a band matrix with lower bandwidth KL and upper
|
|
* bandwidth KU.
|
|
*
|
|
* KL (input) INTEGER
|
|
* The lower bandwidth of A. Referenced only if TYPE = 'B',
|
|
* 'Q' or 'Z'.
|
|
*
|
|
* KU (input) INTEGER
|
|
* The upper bandwidth of A. Referenced only if TYPE = 'B',
|
|
* 'Q' or 'Z'.
|
|
*
|
|
* CFROM (input) REAL
|
|
* CTO (input) REAL
|
|
* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
|
|
* without over/underflow if the final result CTO*A(I,J)/CFROM
|
|
* can be represented without over/underflow. CFROM must be
|
|
* nonzero.
|
|
*
|
|
* M (input) INTEGER
|
|
* The number of rows of the matrix A. M >= 0.
|
|
*
|
|
* N (input) INTEGER
|
|
* The number of columns of the matrix A. N >= 0.
|
|
*
|
|
* A (input/output) COMPLEX array, dimension (LDA,M)
|
|
* The matrix to be multiplied by CTO/CFROM. See TYPE for the
|
|
* storage type.
|
|
*
|
|
* LDA (input) INTEGER
|
|
* The leading dimension of the array A. LDA >= max(1,M).
|
|
*
|
|
* INFO (output) INTEGER
|
|
* 0 - successful exit
|
|
* <0 - if INFO = -i, the i-th argument had an illegal value.
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
REAL ZERO, ONE
|
|
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
LOGICAL DONE
|
|
INTEGER I, ITYPE, J, K1, K2, K3, K4
|
|
REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
|
|
* ..
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
REAL SLAMCH
|
|
EXTERNAL LSAME, SLAMCH
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, MAX, MIN
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL XERBLA
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input arguments
|
|
*
|
|
INFO = 0
|
|
*
|
|
IF( LSAME( TYPE, 'G' ) ) THEN
|
|
ITYPE = 0
|
|
ELSE IF( LSAME( TYPE, 'L' ) ) THEN
|
|
ITYPE = 1
|
|
ELSE IF( LSAME( TYPE, 'U' ) ) THEN
|
|
ITYPE = 2
|
|
ELSE IF( LSAME( TYPE, 'H' ) ) THEN
|
|
ITYPE = 3
|
|
ELSE IF( LSAME( TYPE, 'B' ) ) THEN
|
|
ITYPE = 4
|
|
ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
|
|
ITYPE = 5
|
|
ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
|
|
ITYPE = 6
|
|
ELSE
|
|
ITYPE = -1
|
|
END IF
|
|
*
|
|
IF( ITYPE.EQ.-1 ) THEN
|
|
INFO = -1
|
|
ELSE IF( CFROM.EQ.ZERO ) THEN
|
|
INFO = -4
|
|
ELSE IF( M.LT.0 ) THEN
|
|
INFO = -6
|
|
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
|
|
$ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
|
|
INFO = -7
|
|
ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
|
|
INFO = -9
|
|
ELSE IF( ITYPE.GE.4 ) THEN
|
|
IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
|
|
INFO = -2
|
|
ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
|
|
$ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
|
|
$ THEN
|
|
INFO = -3
|
|
ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
|
|
$ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
|
|
$ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
|
|
INFO = -9
|
|
END IF
|
|
END IF
|
|
*
|
|
IF( INFO.NE.0 ) THEN
|
|
CALL XERBLA( 'CLASCL', -INFO )
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible
|
|
*
|
|
IF( N.EQ.0 .OR. M.EQ.0 )
|
|
$ RETURN
|
|
*
|
|
* Get machine parameters
|
|
*
|
|
SMLNUM = SLAMCH( 'S' )
|
|
BIGNUM = ONE / SMLNUM
|
|
*
|
|
CFROMC = CFROM
|
|
CTOC = CTO
|
|
*
|
|
10 CONTINUE
|
|
CFROM1 = CFROMC*SMLNUM
|
|
CTO1 = CTOC / BIGNUM
|
|
IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
|
|
MUL = SMLNUM
|
|
DONE = .FALSE.
|
|
CFROMC = CFROM1
|
|
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
|
|
MUL = BIGNUM
|
|
DONE = .FALSE.
|
|
CTOC = CTO1
|
|
ELSE
|
|
MUL = CTOC / CFROMC
|
|
DONE = .TRUE.
|
|
END IF
|
|
*
|
|
IF( ITYPE.EQ.0 ) THEN
|
|
*
|
|
* Full matrix
|
|
*
|
|
DO 30 J = 1, N
|
|
DO 20 I = 1, M
|
|
A( I, J ) = A( I, J )*MUL
|
|
20 CONTINUE
|
|
30 CONTINUE
|
|
*
|
|
ELSE IF( ITYPE.EQ.1 ) THEN
|
|
*
|
|
* Lower triangular matrix
|
|
*
|
|
DO 50 J = 1, N
|
|
DO 40 I = J, M
|
|
A( I, J ) = A( I, J )*MUL
|
|
40 CONTINUE
|
|
50 CONTINUE
|
|
*
|
|
ELSE IF( ITYPE.EQ.2 ) THEN
|
|
*
|
|
* Upper triangular matrix
|
|
*
|
|
DO 70 J = 1, N
|
|
DO 60 I = 1, MIN( J, M )
|
|
A( I, J ) = A( I, J )*MUL
|
|
60 CONTINUE
|
|
70 CONTINUE
|
|
*
|
|
ELSE IF( ITYPE.EQ.3 ) THEN
|
|
*
|
|
* Upper Hessenberg matrix
|
|
*
|
|
DO 90 J = 1, N
|
|
DO 80 I = 1, MIN( J+1, M )
|
|
A( I, J ) = A( I, J )*MUL
|
|
80 CONTINUE
|
|
90 CONTINUE
|
|
*
|
|
ELSE IF( ITYPE.EQ.4 ) THEN
|
|
*
|
|
* Lower half of a symmetric band matrix
|
|
*
|
|
K3 = KL + 1
|
|
K4 = N + 1
|
|
DO 110 J = 1, N
|
|
DO 100 I = 1, MIN( K3, K4-J )
|
|
A( I, J ) = A( I, J )*MUL
|
|
100 CONTINUE
|
|
110 CONTINUE
|
|
*
|
|
ELSE IF( ITYPE.EQ.5 ) THEN
|
|
*
|
|
* Upper half of a symmetric band matrix
|
|
*
|
|
K1 = KU + 2
|
|
K3 = KU + 1
|
|
DO 130 J = 1, N
|
|
DO 120 I = MAX( K1-J, 1 ), K3
|
|
A( I, J ) = A( I, J )*MUL
|
|
120 CONTINUE
|
|
130 CONTINUE
|
|
*
|
|
ELSE IF( ITYPE.EQ.6 ) THEN
|
|
*
|
|
* Band matrix
|
|
*
|
|
K1 = KL + KU + 2
|
|
K2 = KL + 1
|
|
K3 = 2*KL + KU + 1
|
|
K4 = KL + KU + 1 + M
|
|
DO 150 J = 1, N
|
|
DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
|
|
A( I, J ) = A( I, J )*MUL
|
|
140 CONTINUE
|
|
150 CONTINUE
|
|
*
|
|
END IF
|
|
*
|
|
IF( .NOT.DONE )
|
|
$ GO TO 10
|
|
*
|
|
RETURN
|
|
*
|
|
* End of CLASCL
|
|
*
|
|
END
|
|
SUBROUTINE SSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB,
|
|
$ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK,
|
|
$ LWORK, IWORK, IFAIL, INFO )
|
|
*
|
|
* -- LAPACK driver 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 ..
|
|
CHARACTER JOBZ, RANGE, UPLO
|
|
INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
|
|
REAL ABSTOL, VL, VU
|
|
* ..
|
|
* .. Array Arguments ..
|
|
INTEGER IFAIL( * ), IWORK( * )
|
|
REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * ),
|
|
$ Z( LDZ, * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* SSYGVX computes selected eigenvalues, and optionally, eigenvectors
|
|
* of a real generalized symmetric-definite eigenproblem, of the form
|
|
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
|
|
* and B are assumed to be symmetric and B is also positive definite.
|
|
* Eigenvalues and eigenvectors can be selected by specifying either a
|
|
* range of values or a range of indices for the desired eigenvalues.
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* ITYPE (input) INTEGER
|
|
* Specifies the problem type to be solved:
|
|
* = 1: A*x = (lambda)*B*x
|
|
* = 2: A*B*x = (lambda)*x
|
|
* = 3: B*A*x = (lambda)*x
|
|
*
|
|
* JOBZ (input) CHARACTER*1
|
|
* = 'N': Compute eigenvalues only;
|
|
* = 'V': Compute eigenvalues and eigenvectors.
|
|
*
|
|
* RANGE (input) CHARACTER*1
|
|
* = 'A': all eigenvalues will be found.
|
|
* = 'V': all eigenvalues in the half-open interval (VL,VU]
|
|
* will be found.
|
|
* = 'I': the IL-th through IU-th eigenvalues will be found.
|
|
*
|
|
* UPLO (input) CHARACTER*1
|
|
* = 'U': Upper triangle of A and B are stored;
|
|
* = 'L': Lower triangle of A and B are stored.
|
|
*
|
|
* N (input) INTEGER
|
|
* The order of the matrix pencil (A,B). N >= 0.
|
|
*
|
|
* A (input/output) REAL array, dimension (LDA, N)
|
|
* On entry, the symmetric matrix A. If UPLO = 'U', the
|
|
* leading N-by-N upper triangular part of A contains the
|
|
* upper triangular part of the matrix A. If UPLO = 'L',
|
|
* the leading N-by-N lower triangular part of A contains
|
|
* the lower triangular part of the matrix A.
|
|
*
|
|
* On exit, the lower triangle (if UPLO='L') or the upper
|
|
* triangle (if UPLO='U') of A, including the diagonal, is
|
|
* destroyed.
|
|
*
|
|
* LDA (input) INTEGER
|
|
* The leading dimension of the array A. LDA >= max(1,N).
|
|
*
|
|
* B (input/output) REAL array, dimension (LDA, N)
|
|
* On entry, the symmetric matrix B. If UPLO = 'U', the
|
|
* leading N-by-N upper triangular part of B contains the
|
|
* upper triangular part of the matrix B. If UPLO = 'L',
|
|
* the leading N-by-N lower triangular part of B contains
|
|
* the lower triangular part of the matrix B.
|
|
*
|
|
* On exit, if INFO <= N, the part of B containing the matrix is
|
|
* overwritten by the triangular factor U or L from the Cholesky
|
|
* factorization B = U**T*U or B = L*L**T.
|
|
*
|
|
* LDB (input) INTEGER
|
|
* The leading dimension of the array B. LDB >= max(1,N).
|
|
*
|
|
* VL (input) REAL
|
|
* VU (input) REAL
|
|
* If RANGE='V', the lower and upper bounds of the interval to
|
|
* be searched for eigenvalues. VL < VU.
|
|
* Not referenced if RANGE = 'A' or 'I'.
|
|
*
|
|
* IL (input) INTEGER
|
|
* IU (input) INTEGER
|
|
* If RANGE='I', the indices (in ascending order) of the
|
|
* smallest and largest eigenvalues to be returned.
|
|
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
|
|
* Not referenced if RANGE = 'A' or 'V'.
|
|
*
|
|
* ABSTOL (input) REAL
|
|
* The absolute error tolerance for the eigenvalues.
|
|
* An approximate eigenvalue is accepted as converged
|
|
* when it is determined to lie in an interval [a,b]
|
|
* of width less than or equal to
|
|
*
|
|
* ABSTOL + EPS * max( |a|,|b| ) ,
|
|
*
|
|
* where EPS is the machine precision. If ABSTOL is less than
|
|
* or equal to zero, then EPS*|T| will be used in its place,
|
|
* where |T| is the 1-norm of the tridiagonal matrix obtained
|
|
* by reducing A to tridiagonal form.
|
|
*
|
|
* Eigenvalues will be computed most accurately when ABSTOL is
|
|
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
|
|
* If this routine returns with INFO>0, indicating that some
|
|
* eigenvectors did not converge, try setting ABSTOL to
|
|
* 2*SLAMCH('S').
|
|
*
|
|
* M (output) INTEGER
|
|
* The total number of eigenvalues found. 0 <= M <= N.
|
|
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
|
|
*
|
|
* W (output) REAL array, dimension (N)
|
|
* On normal exit, the first M elements contain the selected
|
|
* eigenvalues in ascending order.
|
|
*
|
|
* Z (output) REAL array, dimension (LDZ, max(1,M))
|
|
* If JOBZ = 'N', then Z is not referenced.
|
|
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
|
|
* contain the orthonormal eigenvectors of the matrix A
|
|
* corresponding to the selected eigenvalues, with the i-th
|
|
* column of Z holding the eigenvector associated with W(i).
|
|
* The eigenvectors are normalized as follows:
|
|
* if ITYPE = 1 or 2, Z**T*B*Z = I;
|
|
* if ITYPE = 3, Z**T*inv(B)*Z = I.
|
|
*
|
|
* If an eigenvector fails to converge, then that column of Z
|
|
* contains the latest approximation to the eigenvector, and the
|
|
* index of the eigenvector is returned in IFAIL.
|
|
* Note: the user must ensure that at least max(1,M) columns are
|
|
* supplied in the array Z; if RANGE = 'V', the exact value of M
|
|
* is not known in advance and an upper bound must be used.
|
|
*
|
|
* LDZ (input) INTEGER
|
|
* The leading dimension of the array Z. LDZ >= 1, and if
|
|
* JOBZ = 'V', LDZ >= max(1,N).
|
|
*
|
|
* WORK (workspace/output) REAL array, dimension (LWORK)
|
|
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
|
*
|
|
* LWORK (input) INTEGER
|
|
* The length of the array WORK. LWORK >= max(1,8*N).
|
|
* For optimal efficiency, LWORK >= (NB+3)*N,
|
|
* where NB is the blocksize for SSYTRD 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.
|
|
*
|
|
* IWORK (workspace) INTEGER array, dimension (5*N)
|
|
*
|
|
* IFAIL (output) INTEGER array, dimension (N)
|
|
* If JOBZ = 'V', then if INFO = 0, the first M elements of
|
|
* IFAIL are zero. If INFO > 0, then IFAIL contains the
|
|
* indices of the eigenvectors that failed to converge.
|
|
* If JOBZ = 'N', then IFAIL is not referenced.
|
|
*
|
|
* INFO (output) INTEGER
|
|
* = 0: successful exit
|
|
* < 0: if INFO = -i, the i-th argument had an illegal value
|
|
* > 0: SPOTRF or SSYEVX returned an error code:
|
|
* <= N: if INFO = i, SSYEVX failed to converge;
|
|
* i eigenvectors failed to converge. Their indices
|
|
* are stored in array IFAIL.
|
|
* > N: if INFO = N + i, for 1 <= i <= N, then the leading
|
|
* minor of order i of B is not positive definite.
|
|
* The factorization of B could not be completed and
|
|
* no eigenvalues or eigenvectors were computed.
|
|
*
|
|
* Further Details
|
|
* ===============
|
|
*
|
|
* Based on contributions by
|
|
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
REAL ONE
|
|
PARAMETER ( ONE = 1.0E+0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
|
|
CHARACTER TRANS
|
|
INTEGER LOPT, LWKOPT, NB
|
|
* ..
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
INTEGER ILAENV
|
|
EXTERNAL ILAENV, LSAME
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL SPOTRF, SSYEVX, SSYGST, STRMM, STRSM, XERBLA
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC MAX, MIN
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
UPPER = LSAME( UPLO, 'U' )
|
|
WANTZ = LSAME( JOBZ, 'V' )
|
|
ALLEIG = LSAME( RANGE, 'A' )
|
|
VALEIG = LSAME( RANGE, 'V' )
|
|
INDEIG = LSAME( RANGE, 'I' )
|
|
LQUERY = ( LWORK.EQ.-1 )
|
|
*
|
|
INFO = 0
|
|
IF( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN
|
|
INFO = -1
|
|
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
|
|
INFO = -2
|
|
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
|
|
INFO = -3
|
|
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
|
|
INFO = -4
|
|
ELSE IF( N.LT.0 ) THEN
|
|
INFO = -5
|
|
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
|
INFO = -7
|
|
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
|
|
INFO = -9
|
|
ELSE IF( VALEIG .AND. N.GT.0 ) THEN
|
|
IF( VU.LE.VL ) INFO = -11
|
|
ELSE IF( INDEIG .AND. IL.LT.1 ) THEN
|
|
INFO = -12
|
|
ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
|
|
INFO = -13
|
|
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
|
|
INFO = -18
|
|
ELSE IF( LWORK.LT.MAX( 1, 8*N ) .AND. .NOT.LQUERY ) THEN
|
|
INFO = -20
|
|
END IF
|
|
*
|
|
IF( INFO.EQ.0 ) THEN
|
|
NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
|
|
LWKOPT = ( NB+3 )*N
|
|
WORK( 1 ) = LWKOPT
|
|
END IF
|
|
*
|
|
IF( INFO.NE.0 ) THEN
|
|
CALL XERBLA( 'SSYGVX', -INFO )
|
|
RETURN
|
|
ELSE IF( LQUERY ) THEN
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible
|
|
*
|
|
M = 0
|
|
IF( N.EQ.0 ) THEN
|
|
WORK( 1 ) = 1
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Form a Cholesky factorization of B.
|
|
*
|
|
CALL SPOTRF( UPLO, N, B, LDB, INFO )
|
|
IF( INFO.NE.0 ) THEN
|
|
INFO = N + INFO
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Transform problem to standard eigenvalue problem and solve.
|
|
*
|
|
CALL SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
|
|
CALL SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL,
|
|
$ M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
|
|
LOPT = WORK( 1 )
|
|
*
|
|
IF( WANTZ ) THEN
|
|
*
|
|
* Backtransform eigenvectors to the original problem.
|
|
*
|
|
IF( INFO.GT.0 )
|
|
$ M = INFO - 1
|
|
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
|
|
*
|
|
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
|
|
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
|
|
*
|
|
IF( UPPER ) THEN
|
|
TRANS = 'N'
|
|
ELSE
|
|
TRANS = 'T'
|
|
END IF
|
|
*
|
|
CALL STRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
|
|
$ LDB, Z, LDZ )
|
|
*
|
|
ELSE IF( ITYPE.EQ.3 ) THEN
|
|
*
|
|
* For B*A*x=(lambda)*x;
|
|
* backtransform eigenvectors: x = L*y or U'*y
|
|
*
|
|
IF( UPPER ) THEN
|
|
TRANS = 'T'
|
|
ELSE
|
|
TRANS = 'N'
|
|
END IF
|
|
*
|
|
CALL STRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
|
|
$ LDB, Z, LDZ )
|
|
END IF
|
|
END IF
|
|
*
|
|
* Set WORK(1) to optimal workspace size.
|
|
*
|
|
WORK( 1 ) = LWKOPT
|
|
*
|
|
RETURN
|
|
*
|
|
* End of SSYGVX
|
|
*
|
|
END
|
|
SUBROUTINE CHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB,
|
|
$ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK,
|
|
$ LWORK, RWORK, IWORK, IFAIL, INFO )
|
|
*
|
|
* -- LAPACK driver 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 ..
|
|
CHARACTER JOBZ, RANGE, UPLO
|
|
INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
|
|
REAL ABSTOL, VL, VU
|
|
* ..
|
|
* .. Array Arguments ..
|
|
INTEGER IFAIL( * ), IWORK( * )
|
|
REAL RWORK( * ), W( * )
|
|
COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ),
|
|
$ Z( LDZ, * )
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* CHEGVX computes selected eigenvalues, and optionally, eigenvectors
|
|
* of a complex generalized Hermitian-definite eigenproblem, of the form
|
|
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
|
|
* B are assumed to be Hermitian and B is also positive definite.
|
|
* Eigenvalues and eigenvectors can be selected by specifying either a
|
|
* range of values or a range of indices for the desired eigenvalues.
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* ITYPE (input) INTEGER
|
|
* Specifies the problem type to be solved:
|
|
* = 1: A*x = (lambda)*B*x
|
|
* = 2: A*B*x = (lambda)*x
|
|
* = 3: B*A*x = (lambda)*x
|
|
*
|
|
* JOBZ (input) CHARACTER*1
|
|
* = 'N': Compute eigenvalues only;
|
|
* = 'V': Compute eigenvalues and eigenvectors.
|
|
*
|
|
* RANGE (input) CHARACTER*1
|
|
* = 'A': all eigenvalues will be found.
|
|
* = 'V': all eigenvalues in the half-open interval (VL,VU]
|
|
* will be found.
|
|
* = 'I': the IL-th through IU-th eigenvalues will be found.
|
|
**
|
|
* UPLO (input) CHARACTER*1
|
|
* = 'U': Upper triangles of A and B are stored;
|
|
* = 'L': Lower triangles of A and B are stored.
|
|
*
|
|
* N (input) INTEGER
|
|
* The order of the matrices A and B. N >= 0.
|
|
*
|
|
* A (input/output) COMPLEX array, dimension (LDA, N)
|
|
* On entry, the Hermitian matrix A. If UPLO = 'U', the
|
|
* leading N-by-N upper triangular part of A contains the
|
|
* upper triangular part of the matrix A. If UPLO = 'L',
|
|
* the leading N-by-N lower triangular part of A contains
|
|
* the lower triangular part of the matrix A.
|
|
*
|
|
* On exit, the lower triangle (if UPLO='L') or the upper
|
|
* triangle (if UPLO='U') of A, including the diagonal, is
|
|
* destroyed.
|
|
*
|
|
* LDA (input) INTEGER
|
|
* The leading dimension of the array A. LDA >= max(1,N).
|
|
*
|
|
* B (input/output) COMPLEX array, dimension (LDB, N)
|
|
* On entry, the Hermitian matrix B. If UPLO = 'U', the
|
|
* leading N-by-N upper triangular part of B contains the
|
|
* upper triangular part of the matrix B. If UPLO = 'L',
|
|
* the leading N-by-N lower triangular part of B contains
|
|
* the lower triangular part of the matrix B.
|
|
*
|
|
* On exit, if INFO <= N, the part of B containing the matrix is
|
|
* overwritten by the triangular factor U or L from the Cholesky
|
|
* factorization B = U**H*U or B = L*L**H.
|
|
*
|
|
* LDB (input) INTEGER
|
|
* The leading dimension of the array B. LDB >= max(1,N).
|
|
*
|
|
* VL (input) REAL
|
|
* VU (input) REAL
|
|
* If RANGE='V', the lower and upper bounds of the interval to
|
|
* be searched for eigenvalues. VL < VU.
|
|
* Not referenced if RANGE = 'A' or 'I'.
|
|
*
|
|
* IL (input) INTEGER
|
|
* IU (input) INTEGER
|
|
* If RANGE='I', the indices (in ascending order) of the
|
|
* smallest and largest eigenvalues to be returned.
|
|
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
|
|
* Not referenced if RANGE = 'A' or 'V'.
|
|
*
|
|
* ABSTOL (input) REAL
|
|
* The absolute error tolerance for the eigenvalues.
|
|
* An approximate eigenvalue is accepted as converged
|
|
* when it is determined to lie in an interval [a,b]
|
|
* of width less than or equal to
|
|
*
|
|
* ABSTOL + EPS * max( |a|,|b| ) ,
|
|
*
|
|
* where EPS is the machine precision. If ABSTOL is less than
|
|
* or equal to zero, then EPS*|T| will be used in its place,
|
|
* where |T| is the 1-norm of the tridiagonal matrix obtained
|
|
* by reducing A to tridiagonal form.
|
|
*
|
|
* Eigenvalues will be computed most accurately when ABSTOL is
|
|
* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
|
|
* If this routine returns with INFO>0, indicating that some
|
|
* eigenvectors did not converge, try setting ABSTOL to
|
|
* 2*SLAMCH('S').
|
|
*
|
|
* M (output) INTEGER
|
|
* The total number of eigenvalues found. 0 <= M <= N.
|
|
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
|
|
*
|
|
* W (output) REAL array, dimension (N)
|
|
* The first M elements contain the selected
|
|
* eigenvalues in ascending order.
|
|
*
|
|
* Z (output) COMPLEX array, dimension (LDZ, max(1,M))
|
|
* If JOBZ = 'N', then Z is not referenced.
|
|
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
|
|
* contain the orthonormal eigenvectors of the matrix A
|
|
* corresponding to the selected eigenvalues, with the i-th
|
|
* column of Z holding the eigenvector associated with W(i).
|
|
* The eigenvectors are normalized as follows:
|
|
* if ITYPE = 1 or 2, Z**T*B*Z = I;
|
|
* if ITYPE = 3, Z**T*inv(B)*Z = I.
|
|
*
|
|
* If an eigenvector fails to converge, then that column of Z
|
|
* contains the latest approximation to the eigenvector, and the
|
|
* index of the eigenvector is returned in IFAIL.
|
|
* Note: the user must ensure that at least max(1,M) columns are
|
|
* supplied in the array Z; if RANGE = 'V', the exact value of M
|
|
* is not known in advance and an upper bound must be used.
|
|
*
|
|
* LDZ (input) INTEGER
|
|
* The leading dimension of the array Z. LDZ >= 1, and if
|
|
* JOBZ = 'V', LDZ >= max(1,N).
|
|
*
|
|
* WORK (workspace/output) COMPLEX array, dimension (LWORK)
|
|
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
|
*
|
|
* LWORK (input) INTEGER
|
|
* The length of the array WORK. LWORK >= max(1,2*N-1).
|
|
* For optimal efficiency, LWORK >= (NB+1)*N,
|
|
* where NB is the blocksize for CHETRD 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.
|
|
*
|
|
* RWORK (workspace) REAL array, dimension (7*N)
|
|
*
|
|
* IWORK (workspace) INTEGER array, dimension (5*N)
|
|
*
|
|
* IFAIL (output) INTEGER array, dimension (N)
|
|
* If JOBZ = 'V', then if INFO = 0, the first M elements of
|
|
* IFAIL are zero. If INFO > 0, then IFAIL contains the
|
|
* indices of the eigenvectors that failed to converge.
|
|
* If JOBZ = 'N', then IFAIL is not referenced.
|
|
*
|
|
* INFO (output) INTEGER
|
|
* = 0: successful exit
|
|
* < 0: if INFO = -i, the i-th argument had an illegal value
|
|
* > 0: CPOTRF or CHEEVX returned an error code:
|
|
* <= N: if INFO = i, CHEEVX failed to converge;
|
|
* i eigenvectors failed to converge. Their indices
|
|
* are stored in array IFAIL.
|
|
* > N: if INFO = N + i, for 1 <= i <= N, then the leading
|
|
* minor of order i of B is not positive definite.
|
|
* The factorization of B could not be completed and
|
|
* no eigenvalues or eigenvectors were computed.
|
|
*
|
|
* Further Details
|
|
* ===============
|
|
*
|
|
* Based on contributions by
|
|
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
COMPLEX CONE
|
|
PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
|
|
CHARACTER TRANS
|
|
INTEGER LOPT, LWKOPT, NB
|
|
* ..
|
|
* .. External Functions ..
|
|
LOGICAL LSAME
|
|
INTEGER ILAENV
|
|
EXTERNAL ILAENV, LSAME
|
|
* ..
|
|
* .. External Subroutines ..
|
|
EXTERNAL CHEEVX, CHEGST, CPOTRF, CTRMM, CTRSM, XERBLA
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC MAX, MIN
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* Test the input parameters.
|
|
*
|
|
WANTZ = LSAME( JOBZ, 'V' )
|
|
UPPER = LSAME( UPLO, 'U' )
|
|
ALLEIG = LSAME( RANGE, 'A' )
|
|
VALEIG = LSAME( RANGE, 'V' )
|
|
INDEIG = LSAME( RANGE, 'I' )
|
|
LQUERY = ( LWORK.EQ.-1 )
|
|
*
|
|
INFO = 0
|
|
IF( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN
|
|
INFO = -1
|
|
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
|
|
INFO = -2
|
|
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
|
|
INFO = -3
|
|
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
|
|
INFO = -4
|
|
ELSE IF( N.LT.0 ) THEN
|
|
INFO = -5
|
|
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
|
INFO = -7
|
|
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
|
|
INFO = -9
|
|
ELSE IF( VALEIG .AND. N.GT.0 ) THEN
|
|
IF( VU.LE.VL ) INFO = -11
|
|
ELSE IF( INDEIG .AND. IL.LT.1 ) THEN
|
|
INFO = -12
|
|
ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
|
|
INFO = -13
|
|
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
|
|
INFO = -18
|
|
ELSE IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) THEN
|
|
INFO = -20
|
|
END IF
|
|
*
|
|
IF( INFO.EQ.0 ) THEN
|
|
NB = ILAENV( 1, 'CHETRD', UPLO, N, -1, -1, -1 )
|
|
LWKOPT = ( NB+1 )*N
|
|
WORK( 1 ) = LWKOPT
|
|
END IF
|
|
*
|
|
IF( INFO.NE.0 ) THEN
|
|
CALL XERBLA( 'CHEGVX', -INFO )
|
|
RETURN
|
|
ELSE IF( LQUERY ) THEN
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Quick return if possible
|
|
*
|
|
M = 0
|
|
IF( N.EQ.0 ) THEN
|
|
WORK( 1 ) = 1
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Form a Cholesky factorization of B.
|
|
*
|
|
CALL CPOTRF( UPLO, N, B, LDB, INFO )
|
|
IF( INFO.NE.0 ) THEN
|
|
INFO = N + INFO
|
|
RETURN
|
|
END IF
|
|
*
|
|
* Transform problem to standard eigenvalue problem and solve.
|
|
*
|
|
CALL CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
|
|
CALL CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL,
|
|
$ M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL,
|
|
$ INFO )
|
|
LOPT = WORK( 1 )
|
|
*
|
|
IF( WANTZ ) THEN
|
|
*
|
|
* Backtransform eigenvectors to the original problem.
|
|
*
|
|
IF( INFO.GT.0 )
|
|
$ M = INFO - 1
|
|
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
|
|
*
|
|
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
|
|
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
|
|
*
|
|
IF( UPPER ) THEN
|
|
TRANS = 'N'
|
|
ELSE
|
|
TRANS = 'C'
|
|
END IF
|
|
*
|
|
CALL CTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, CONE, B,
|
|
$ LDB, Z, LDZ )
|
|
*
|
|
ELSE IF( ITYPE.EQ.3 ) THEN
|
|
*
|
|
* For B*A*x=(lambda)*x;
|
|
* backtransform eigenvectors: x = L*y or U'*y
|
|
*
|
|
IF( UPPER ) THEN
|
|
TRANS = 'C'
|
|
ELSE
|
|
TRANS = 'N'
|
|
END IF
|
|
*
|
|
CALL CTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, CONE, B,
|
|
$ LDB, Z, LDZ )
|
|
END IF
|
|
END IF
|
|
*
|
|
* Set WORK(1) to optimal complex workspace size.
|
|
*
|
|
WORK( 1 ) = LWKOPT
|
|
*
|
|
RETURN
|
|
*
|
|
* End of CHEGVX
|
|
*
|
|
END
|