|
PROGRAM TEST
|
IMPLICIT NONE
|
C
|
INTEGER LDA, LDVS, LDWORK, N
|
PARAMETER (N = 2)
|
PARAMETER (LDA = N)
|
PARAMETER (LDVS = 2 * N)
|
PARAMETER (LDWORK = 3 * N)
|
C
|
DOUBLE PRECISION A(LDA,N), TEMP, VS(LDVS,N)
|
DOUBLE PRECISION WORK(LDWORK), WR(N), WI(N)
|
INTEGER I, ICOL, INFO, IROW, SORT
|
C
|
EXTERNAL DGEES, SELECT
|
INTRINSIC ABS
|
C
|
C Initialize the array A to store the matrix A shown below.
|
C
|
C A = 0 1
|
C -6 5
|
C
|
DATA A / 0.0D0, -6.0D0, 1.0D0, 5.0D0 /
|
C
|
C Print the initial value of A.
|
C
|
PRINT 1000
|
PRINT 1010, ((A(IROW,ICOL), ICOL = 1, N), IROW = 1, N)
|
C
|
C Compute the eigenvalues and Schur vectors of A.
|
C
|
CALL DGEES ('VECTORS AND EIGENVALUES', 'NOT SORTED', SELECT,
|
$ N, A, LDA, SORT, WR, WI, VS, LDVS, WORK, LDWORK,
|
$ TEMP, INFO)
|
IF (INFO .NE. 0) THEN
|
IF (INFO .LT. 0) THEN
|
PRINT 1020, ABS(INFO)
|
STOP 1
|
ELSEIF (INFO .LE. N) THEN
|
PRINT 1030, INFO
|
STOP 2
|
ELSEIF (INFO .EQ. N + 1) THEN
|
PRINT 1040
|
ELSE
|
PRINT 1050
|
END IF
|
END IF
|
C
|
C Print the eigenvalues and Schur vectors.
|
C
|
PRINT 1060
|
DO 120, IROW = 1, N
|
PRINT 1070, WR(IROW), (VS(I,IROW), I = 1, N)
|
120 CONTINUE
|
C
|
1000 FORMAT (1X, 'A:')
|
1010 FORMAT (2(3X, F4.1))
|
1020 FORMAT (/1X, 'Illegal argument to DGEES, argument #', I2)
|
1030 FORMAT (/1X, 'QR failed to converge, INFO = ', I2)
|
1040 FORMAT (/1X, 'Eigenvalues could not be reordered; problem',
|
$ /1X, 'is very ill-conditioned.')
|
1050 FORMAT (/1X, 'Leading eigenvalues in the Schur form no',
|
$ /1X, 'longer satisfy SELECT = .TRUE.')
|
1060 FORMAT (/1X, 'Eigenvalue', 4X, 'Schur vector**T')
|
1070 FORMAT (1X, F5.2, 10X, '[', F4.2, ', ', F4.2, ']')
|
C
|
END
|
|
LOGICAL FUNCTION SELECT (ARG1, ARG2)
|
IMPLICIT NONE
|
C
|
DOUBLE PRECISION ARG1, ARG2
|
INTRINSIC INT
|
C
|
C The value computed is always .TRUE. It is computed in
|
C the peculiar way below to avoid compiler messages about
|
C unused function arguments.
|
C
|
PRINT 1000
|
SELECT = (ARG1 .EQ. ARG2)
|
STOP
|
C
|
1000 FORMAT (///1X, '**** ERROR: ',
|
$ 'SELECT FUNCTION CALLED BUT NOT AVAILABLE. ****')
|
C
|
END
|
|