1PROGRAM LA_DGGESX_ET_EXAMPLE
2!
3!  -- LAPACK95 interface driver routine (version 3.0) --
4!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
5!     September, 2000
6!
7!  .. USE STATEMENTS
8      USE LA_PRECISION, ONLY: WP => DP
9      USE F95_LAPACK, ONLY: LA_GGESX
10!  .. IMPLICIT STATEMENT ..
11      IMPLICIT NONE
12      INTERFACE
13      LOGICAL FUNCTION SELECT(ALPHAR, ALPHAI, BETA)
14      USE LA_PRECISION, ONLY: WP => DP
15      REAL(WP), INTENT(IN) :: ALPHAR, ALPHAI, BETA
16      END FUNCTION SELECT
17      END INTERFACE
18!  .. PARAMETERS ..
19      CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
20      INTEGER, PARAMETER :: NIN=5, NOUT=6
21!  .. LOCAL SCALARS ..
22      INTEGER :: I, INFO, N, SDIM
23!  .. LOCAL ARRAYS ..
24      REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:)
25      REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), VSL(:,:), VSR(:,:), DUMMY(:,:)
26      REAL(WP), ALLOCATABLE ::  ALPHAR(:), ALPHAI(:), BETA(:)
27      REAL(WP) RCONDE(2), RCONDV(2)
28!  .. EXECUTABLE STATEMENTS ..
29      WRITE (NOUT,*) 'GGESX ET_Example Program Results.'
30      READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
31      READ ( NIN, * ) N
32      PRINT *, 'N = ', N
33      ALLOCATE ( A(N,N), B(N,N), AA(N,N), BB(N,N), VSL(N,N), VSR(N,N) )
34      ALLOCATE (ALPHAI(N), ALPHAR(N), BETA(N))
35!
36      READ (NIN, *) AA
37      A=AA
38      WRITE(NOUT,*) 'The matrix A:'
39      DO I = 1, N; WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) A(I,:); ENDDO
40!
41        WRITE ( NOUT, * )'---------------------------------------------------------'
42        WRITE ( NOUT, * )
43        WRITE ( NOUT, * )'Details of LA_DGGESX LAPACK Subroutine Results.'
44        WRITE ( NOUT, * )
45!
46        WRITE(NOUT,*)
47        WRITE(NOUT,*) 'CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, VSL, VSR, SELECT, SDIM, RCONDE, RCONDV, INFO )'
48        A=AA
49        CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, VSL, VSR, SELECT, SDIM, RCONDE, RCONDV, INFO )
50        WRITE(NOUT,*) 'INFO = ', INFO, ' SDIM = ', SDIM, ' Eigenvalues:'
51        WRITE(NOUT,FMT) ALPHAR
52        WRITE(NOUT,FMT) ALPHAI
53        WRITE(NOUT,*) 'Left Schur vectors:'
54        DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VSL(:,I); END DO
55          WRITE(NOUT,*) 'Right Schur vectors:'
56          DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VSR(:,I); END DO
57          WRITE(NOUT,*) 'RCONDE = :'; WRITE(NOUT,FMT) RCONDE
58          WRITE(NOUT,*) 'RCONDV = :'; WRITE(NOUT,FMT) RCONDV
59!
60            WRITE(NOUT,*)
61            WRITE(NOUT,*) 'CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, VSL, VSR )'
62            A=AA; VSL = HUGE(1.0_WP); VSR = HUGE(1.0_WP)
63            CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, VSL, VSR)
64            WRITE(NOUT,*) 'INFO = ', INFO, ' Eigenvalues:'
65            WRITE(NOUT,FMT)  ALPHAR
66            WRITE(NOUT,FMT)  ALPHAI
67            WRITE(NOUT,*) 'Left Schur vectors:'
68            DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VSL(:,I); END DO
69              WRITE(NOUT,*) 'Right Schur vectors:'
70              DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VSR(:,I); END DO
71!
72                WRITE(NOUT,*)
73                WRITE(NOUT,*) 'CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, SELECT=SELECT, SDIM=SDIM, INFO=INFO )'
74                A=AA
75                CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, SELECT=SELECT, SDIM=SDIM, INFO=INFO )
76                WRITE(NOUT,*) 'INFO = ', INFO, ' SDIM = ', SDIM, ' Eigenvalues:'
77                WRITE(NOUT,FMT) ALPHAR
78                WRITE(NOUT,FMT) ALPHAI
79!
80                WRITE(NOUT,*)
81                WRITE(NOUT,*) 'CALL LA_GGESX( A, B,  ALPHAR, ALPHAI, BETA )'
82                A=AA
83                CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA)
84                WRITE(NOUT,*) 'INFO = ', INFO, ' Eigenvalues:'
85                WRITE(NOUT,FMT) ALPHAR
86                WRITE(NOUT,FMT) ALPHAI
87! START THE ERROR TESTS
88                WRITE(NOUT,*)
89                WRITE(NOUT,*) 'CALL LA_GGESX( DUMMY, B, ALPHAR, ALPHAI, BETA, SELECT=SELECT, SDIM=SDIM, &
90&                 RCONDE=RCONDE, RCONDV=RCONDV,  INFO=INFO )'
91                A=AA
92                CALL LA_GGESX( DUMMY, B, ALPHAR, ALPHAI, BETA, SELECT=SELECT, SDIM=SDIM,  RCONDE=RCONDE, &
93&                 RCONDV=RCONDV, INFO=INFO )
94                WRITE(NOUT,*) 'INFO = ', INFO
95!
96                WRITE(NOUT,*)
97                WRITE(NOUT,*) 'CALL LA_GGESX( A,B(1:N-1,:), ALPHAR, ALPHAI, BETA, SELECT=SELECT, SDIM=SDIM, &
98&                 RCONDE=RCONDE, RCONDV=RCONDV, INFO=INFO )'
99                A=AA
100                CALL LA_GGESX( A, B(1:N-1,:), ALPHAR, ALPHAI, BETA, SELECT=SELECT, SDIM=SDIM, &
101&                 RCONDE=RCONDE, RCONDV=RCONDV, INFO=INFO )
102                WRITE(NOUT,*) 'INFO = ', INFO
103!
104                WRITE(NOUT,*)
105                WRITE(NOUT,*) 'CALL LA_GGESX( A,B(:,1:N-1), ALPHAR, ALPHAI, BETA, SELECT=SELECT, SDIM=SDIM, &
106&                 RCONDE=RCONDE, RCONDV=RCONDV, INFO=INFO )'
107                A=AA
108                CALL LA_GGESX( A, B(:,1:N-1), ALPHAR, ALPHAI, BETA, SELECT=SELECT, SDIM=SDIM, &
109&                 RCONDE=RCONDE, RCONDV=RCONDV, INFO=INFO )
110                WRITE(NOUT,*) 'INFO = ', INFO
111!
112                WRITE(NOUT,*)
113                WRITE(NOUT,*) 'CALL LA_GGESX( A, B, ALPHAR(1:N-1), ALPHAI, BETA, SELECT=SELECT, SDIM=SDIM, &
114&                 RCONDE=RCONDE, RCONDV=RCONDV, INFO=INFO )'
115                A=AA
116                CALL LA_GGESX( A, B, ALPHAR(1 :N-1), ALPHAI, BETA, SELECT=SELECT, SDIM=SDIM, &
117&                 RCONDE=RCONDE, RCONDV=RCONDV, INFO=INFO)
118                WRITE(NOUT,*) 'INFO = ', INFO
119!
120                WRITE(NOUT,*)
121                WRITE(NOUT,*) 'CALL LA_GGESX( A, B, ALPHAR, ALPHAI(1:N-1), BETA, SELECT=SELECT, SDIM=SDIM, &
122&                 RCONDE=RCONDE, RCONDV=RCONDV,INFO=INFO )'
123                A=AA
124                CALL LA_GGESX( A, B, ALPHAR, ALPHAI(1:N-1), BETA, SELECT=SELECT, SDIM=SDIM, &
125&                 RCONDE=RCONDE, RCONDV=RCONDV, INFO=INFO)
126                WRITE(NOUT,*) 'INFO = ', INFO
127!
128                WRITE(NOUT,*)
129                WRITE(NOUT,*) 'CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA(1:N-1), SELECT=SELECT, SDIM=SDIM, &
130&                 RCONDE=RCONDE, RCONDV=RCONDV, INFO=INFO )'
131                A=AA
132                CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA(1:N-1), SELECT=SELECT, SDIM=SDIM, &
133&                 RCONDE=RCONDE, RCONDV=RCONDV, INFO=INFO)
134                WRITE(NOUT,*) 'INFO = ', INFO
135!
136                WRITE(NOUT,*)
137                WRITE(NOUT,*) 'CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, VSL(1:N-1,:), VSR, SELECT, &
138&                 SDIM, RCONDE, RCONDV, INFO )'
139                A=AA
140                CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, VSL(1:N-1,:), VSR, SELECT, &
141&                 SDIM, RCONDE, RCONDV, INFO)
142                WRITE(NOUT,*) 'INFO = ', INFO
143!
144                WRITE(NOUT,*)
145                WRITE(NOUT,*) 'CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, VSL(:,1:N-1), VSR, SELECT, SDIM, &
146&                 RCONDE, RCONDV,  INFO )'
147                A=AA
148                CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, VSL(:,1:N-1), VSR, SELECT, SDIM, &
149&                 RCONDE, RCONDV, INFO)
150                WRITE(NOUT,*) 'INFO = ', INFO
151!
152                WRITE(NOUT,*)
153                WRITE(NOUT,*) 'CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, VSL, VSR(1:N-1,:), SELECT, SDIM, &
154&                 RCONDE, RCONDV, INFO )'
155                A=AA
156                CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, VSL, VSR(1:N-1,:), SELECT, SDIM, &
157&                 RCONDE, RCONDV,  INFO)
158                WRITE(NOUT,*) 'INFO = ', INFO
159!
160                WRITE(NOUT,*)
161                WRITE(NOUT,*) 'CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, VSL, VSR(:,1:N-1), SELECT, SDIM, &
162&                 RCONDE, RCONDV,  INFO )'
163                A=AA
164                CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, VSL, VSR(:,1:N-1), SELECT, SDIM, &
165&                 RCONDE, RCONDV, INFO)
166                WRITE(NOUT,*) 'INFO = ', INFO
167END PROGRAM LA_DGGESX_ET_EXAMPLE
168                LOGICAL FUNCTION SELECT(ALPHAR, ALPHAI, BETA)
169                USE LA_PRECISION, ONLY: WP => DP
170                REAL(WP), INTENT(IN) :: ALPHAR, ALPHAI, BETA
171                SELECT = .TRUE.
172              END FUNCTION SELECT
173
174
175
176