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