1SUBROUTINE LA_TEST_CGGES(JOBVSL, JOBVSR, SORT, SELECT, N, A, LDA, B, LDB, SDIM, & 2& ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO) 3! 4! -- LAPACK95 interface driver routine (version 1.1) -- 5! UNI-C, Denmark; 6! September 25, 1999 7! 8! .. Use Statements .. 9 USE LA_PRECISION, ONLY: WP => SP 10 USE F95_LAPACK, ONLY: LA_GGES 11! .. Implicit Statement .. 12 IMPLICIT NONE 13! .. Scalar Arguments .. 14 INTEGER, INTENT(IN) :: N, LDA, LDB, LDVSL, LDVSR, LWORK 15 INTEGER, INTENT(INOUT) :: INFO 16 INTEGER, INTENT(OUT) :: SDIM 17 CHARACTER*1, INTENT(IN) :: JOBVSL, JOBVSR, SORT 18! .. Array Arguments .. 19 COMPLEX(WP), INTENT(INOUT) :: A(1:LDA,1:N), B(1:LDB, 1:N) 20 COMPLEX(WP), INTENT(OUT):: WORK(1:LWORK) 21 LOGICAL :: BWORK(1: N) 22 REAL(WP) :: RWORK(1: 8*N) 23 COMPLEX(WP), INTENT(OUT) :: ALPHA(1:N), BETA(1:N), & 24& VSL(1: LDVSL, 1:N), VSR(1: LDVSR, 1:N) 25 26 INTERFACE 27 LOGICAL FUNCTION SELECT(ALPHA, BETA) 28 USE LA_PRECISION, ONLY: WP => SP 29 COMPLEX(WP), INTENT(IN) :: ALPHA, BETA 30 END FUNCTION SELECT 31 END INTERFACE 32 OPTIONAL :: SELECT 33! .. Parameters .. 34 CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GGES ' 35 CHARACTER(LEN=14), PARAMETER :: SRNAMT = 'LA_TEST_CGGES ' 36! .. Common blocks .. 37 INTEGER :: INFOTC 38 COMMON /LINFO95/ INFOTC 39! .. Local Scalars .. 40 INTEGER :: I, J, IA1, IA2, IB1, IB2, IALPHA, IBETA, IVSL1, & 41 & IVSL2, IVSR1, IVSR2 42 CHARACTER*1 :: IJOBVSL, IJOBVSR 43! .. Local Arrays .. 44 LOGICAL, SAVE :: CTEST = .TRUE., ETEST = .TRUE. 45 LOGICAL LSAME 46! .. Executable Statements .. 47 IA1 = N; IA2 = N; IJOBVSL = JOBVSL; IJOBVSR = JOBVSR 48 IB1 = N; IB2 = N; IALPHA = N; IBETA = N 49 IVSL1 = N; IVSL2 = N; IVSR1 = N; IVSR2 = N 50 I = INFO / 100; J = INFO - I*100 51 SELECT CASE(I) 52 CASE (1) 53 IA2 = IA1 - 1 54 CASE (2) 55 IB1 = IA1 - 1 56 CASE (3) 57 IALPHA = IA1 - 1 58 CASE (4) 59 IBETA = IA1 - 1 60 CASE (5) 61 IVSL1 = IA1 - 1; IJOBVSL = 'V';IJOBVSR = 'V' 62 CALL LA_GGES( A(1:IA1,1:IA2), B(1:IB1, 1:IB2), & 63& ALPHA=ALPHA(1: IALPHA), & 64& BETA=BETA(1: IBETA), VSL=VSL(1:IVSL1,1:IVSL2), & 65& VSR=VSR(1:IVSR1,1:IVSR2), SDIM=SDIM,& 66& INFO=INFO) 67 CALL LA_AUX_AA01( I, CTEST, ETEST, SRNAMT ) 68 RETURN 69 CASE (6) 70 IVSR1 = IA1 - 1; IJOBVSL = 'V';IJOBVSR = 'V' 71 CALL LA_GGES( A(1:IA1,1:IA2), B(1:IB1, 1:IB2), & 72& ALPHA=ALPHA(1: IALPHA), & 73& BETA=BETA(1: IBETA), VSL=VSL(1:IVSL1,1:IVSL2), & 74& VSR=VSR(1:IVSR1,1:IVSR2), SDIM=SDIM,& 75& INFO=INFO) 76 CALL LA_AUX_AA01( I, CTEST, ETEST, SRNAMT ) 77 RETURN 78 CASE(:-1,7:) 79 CALL UESTOP(SRNAMT) 80 END SELECT 81 82 IF (LSAME(SORT, 'N')) THEN 83 84 IF (LSAME(IJOBVSL,'V')) THEN 85 IF (LSAME (IJOBVSR, 'V')) THEN 86 CALL LA_GGES( A(1:IA1,1:IA2), B(1:IB1, 1:IB2), & 87 & ALPHA=ALPHA(1: IALPHA), & 88 & BETA=BETA(1: IBETA), VSL=VSL(1:IVSL1,1:IVSL2), & 89 & VSR=VSR(1:IVSR1,1:IVSR2), SDIM=SDIM, & 90 & INFO=INFO) 91 ELSE 92 CALL LA_GGES( A(1:IA1,1:IA2), B(1:IB1, 1:IB2), & 93 & ALPHA=ALPHA(1: IALPHA), & 94 & BETA=BETA(1: IBETA), VSL=VSL(1:IVSL1,1:IVSL2),& 95 & SDIM=SDIM, INFO=INFO) 96 END IF 97 ELSE 98 IF (LSAME (IJOBVSR, 'V')) THEN 99 CALL LA_GGES( A(1:IA1,1:IA2), B(1:IB1, 1:IB2), & 100 & ALPHA=ALPHA(1: IALPHA),& 101 & BETA=BETA(1: IBETA), VSR = VSR(1:IVSR1,1:IVSR2), & 102 & SDIM=SDIM, INFO = INFO) 103 ELSE 104 CALL LA_GGES( A(1:IA1,1:IA2), B(1:IB1, 1:IB2), & 105 & ALPHA=ALPHA(1: IALPHA), & 106 & BETA=BETA(1: IBETA), SDIM=SDIM, INFO = INFO) 107 END IF 108 END IF 109 ELSE 110 IF (LSAME(IJOBVSL,'V')) THEN 111 IF (LSAME (IJOBVSR, 'V')) THEN 112 CALL LA_GGES( A(1:IA1,1:IA2), B(1:IB1, 1:IB2),& 113& ALPHA(1: IALPHA), BETA(1: IBETA), & 114& VSL(1:IVSL1,1:IVSL2), VSR(1:IVSR1,1:IVSR2), & 115& SELECT, SDIM, INFO) 116 ELSE 117 CALL LA_GGES( A(1:IA1,1:IA2), B(1:IB1, 1:IB2),& 118 & ALPHA(1:IALPHA), BETA(1: IBETA),& 119& VSL=VSL(1:IVSL1,1:IVSL2), SELECT=SELECT, & 120& SDIM=SDIM, INFO=INFO) 121 END IF 122 ELSE 123 IF (LSAME (IJOBVSR, 'V')) THEN 124 CALL LA_GGES( A(1:IA1,1:IA2), B(1:IB1, 1:IB2), & 125 & ALPHA(1:IALPHA), BETA(1: IBETA),& 126& VSR = VSR(1:IVSR1,1:IVSR2), SELECT=SELECT, SDIM=SDIM, & 127& INFO = INFO) 128 ELSE 129 CALL LA_GGES( A(1:IA1,1:IA2), B(1:IB1, 1:IB2), & 130 & ALPHA(1:IALPHA), BETA(1: IBETA), SELECT=SELECT, SDIM=SDIM,& 131 & INFO = INFO) 132 END IF 133 END IF 134 END IF 135 CALL LA_AUX_AA01( I, CTEST, ETEST, SRNAMT ) 136END SUBROUTINE LA_TEST_CGGES 137