1SUBROUTINE LA_TEST_DGGEVX(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB,& 2 & ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE,& 3 & ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, BWORK, INFO) 4! 5! -- LAPACK95 interface driver routine (version 1.1) -- 6! UNI-C, Denmark; 7! SEPTEMBER 5, 1999 8! 9! .. Use Statements .. 10 USE LA_PRECISION, ONLY: WP => DP 11 USE F95_LAPACK, ONLY: LA_GGEVX 12! .. Implicit Statement .. 13 IMPLICIT NONE 14! .. Scalar Arguments .. 15 INTEGER, INTENT(IN) :: N, LDA, LDB, LDVL, LDVR, LWORK 16 INTEGER, INTENT(INOUT) :: INFO 17 INTEGER, INTENT(OUT):: ILO, IHI 18 CHARACTER*1, INTENT(IN) :: BALANC, JOBVL, JOBVR, SENSE 19 REAL(WP), INTENT(OUT) :: ABNRM, BBNRM 20! .. Array Arguments .. 21 REAL(WP), INTENT(INOUT) :: A(1:LDA,1:N), B(1:LDB, 1:N) 22 REAL(WP), INTENT(OUT):: WORK(1:LWORK) 23 REAL(WP), INTENT(OUT) :: ALPHAR(1:N), ALPHAI(1:N), BETA(1:N), & 24 & VL(1: LDVL, 1:N), VR(1: LDVR, 1:N), LSCALE(1:N), RSCALE(1:N), & 25 & RCONDE(1:N), RCONDV(1:N) 26 INTEGER :: IWORK(1: N+6) 27 LOGICAL :: BWORK(1:N) 28! .. Parameters .. 29 CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GGEVX' 30 CHARACTER(LEN=14), PARAMETER :: SRNAMT = 'LA_TEST_DGGEVX' 31! .. Common blocks .. 32 INTEGER :: INFOTC 33 COMMON /LINFO95/ INFOTC 34! .. Local Scalars .. 35 INTEGER :: I, J, IA1, IA2, IB1, IB2, IALPHAI, IALPHAR, IBETA, IVL1, & 36 & IVL2, IVR1, IVR2, ILSCALE, IRSCALE, IRCONDE, IRCONDV 37 CHARACTER*1 :: IJOBVL, IJOBVR, IBALANC 38! .. Local Arrays .. 39 LOGICAL, SAVE :: CTEST = .TRUE., ETEST = .TRUE. 40 LOGICAL LSAME 41! .. Executable Statements .. 42 IA1 = N; IA2 = N; IJOBVL = JOBVL; IJOBVR = JOBVR; IBALANC = BALANC 43 IB1 = N; IB2 = N; IALPHAR = N; IALPHAI = N; IBETA = N 44 IVL1 = N; IVL2 = N; IVR1 = N; IVR2 = N; ILSCALE = N; IRSCALE = N 45 IRCONDE = N; IRCONDV = N 46 I = INFO / 100; J = INFO - I*100 47 SELECT CASE(I) 48 CASE (1) 49 IA2 = IA1 - 1 50 CASE (2) 51 IB1 = IA1 - 1 52 CASE (3) 53 IALPHAR = IA1 - 1 54 CASE (4) 55 IALPHAI = IA1 - 1 56 CASE (5) 57 IBETA = IA1 - 1 58 CASE (6) 59 IJOBVL = 'V' 60 IVL1 = IA1 - 1 61 CASE (7) 62 IJOBVR = 'V' 63 IVR1 = IA1 - 1 64 CASE (8) 65 IBALANC = 'T' 66 CASE (11) 67 ILSCALE = IA2 - 1 68 CASE (12) 69 IRSCALE = IA2 - 1 70 CASE (15) 71 IRCONDE = IA2 - 1 72 CASE (16) 73 IRCONDV = IA2 - 1 74 CASE(:-1,9,10,13, 14, 17:) 75 CALL UESTOP(SRNAMT) 76 END SELECT 77 IF (LSAME(IJOBVL,'V')) THEN 78 IF (LSAME (IJOBVR, 'V')) THEN 79 CALL LA_GGEVX( A(1:IA1,1:IA2), B(1:IB1, 1:IB2), ALPHAR(1: IALPHAR), & 80 & ALPHAI(1:IALPHAI), BETA(1: IBETA), VL(1:IVL1,1:IVL2), & 81 & VR(1:IVR1,1:IVR2), IBALANC, ILO, IHI, LSCALE(1:ILSCALE), RSCALE(1: IRSCALE), & 82 & ABNRM, BBNRM, RCONDE(1: IRCONDE), RCONDV(1: IRCONDV), INFO) 83 ELSE 84 CALL LA_GGEVX( A(1:IA1,1:IA2), B(1:IB1, 1:IB2), ALPHAR(1: IALPHAR), & 85 & ALPHAI(1:IALPHAI), BETA(1: IBETA), VL(1:IVL1,1:IVL2), BALANC=IBALANC, & 86 & ILO=ILO, IHI=IHI, LSCALE=LSCALE(1:ILSCALE), RSCALE=RSCALE(1 : IRSCALE), & 87 & ABNRM=ABNRM, BBNRM=BBNRM, RCONDE=RCONDE(1: IRCONDE), & 88 & RCONDV=RCONDV(1 : IRCONDV), INFO = INFO) 89 END IF 90 ELSE 91 IF (LSAME (IJOBVR, 'V')) THEN 92 CALL LA_GGEVX( A(1:IA1,1:IA2), B(1:IB1, 1:IB2), ALPHAR(1: IALPHAR), & 93 & ALPHAI(1:IALPHAI), BETA(1: IBETA), VR = VR(1:IVR1,1:IVR2), ILO=ILO, IHI=IHI, & 94 & BALANC=IBALANC, LSCALE=LSCALE(1 :ILSCALE), & 95 & RSCALE=RSCALE(1: IRSCALE), ABNRM=ABNRM, BBNRM=BBNRM, RCONDE=RCONDE(1 : IRCONDE), & 96 & RCONDV=RCONDV(1 : IRCONDV), INFO = INFO) 97 ELSE 98 CALL LA_GGEVX( A(1:IA1,1:IA2), B(1:IB1, 1:IB2), ALPHAR(1: IALPHAR), & 99 & ALPHAI(1:IALPHAI), BETA(1: IBETA), BALANC=IBALANC, ILO=ILO, IHI=IHI, & 100 & LSCALE=LSCALE(1 :ILSCALE), RSCALE=RSCALE(1: IRSCALE), ABNRM=ABNRM, & 101 & BBNRM=BBNRM, RCONDE=RCONDE(1 : IRCONDE), & 102 & RCONDV=RCONDV(1 : IRCONDV), INFO = INFO) 103 END IF 104 END IF 105 CALL LA_AUX_AA01( I, CTEST, ETEST, SRNAMT ) 106 END SUBROUTINE LA_TEST_DGGEVX 107 108