You can not select more than 25 topics Topics must start with a chinese character,a letter or number, can include dashes ('-') and can be up to 35 characters long.

dggev3.f 19 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596
  1. *> \brief <b> DGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (blocked algorithm)</b>
  2. *
  3. * =========== DOCUMENTATION ===========
  4. *
  5. * Online html documentation available at
  6. * http://www.netlib.org/lapack/explore-html/
  7. *
  8. *> \htmlonly
  9. *> Download DGGEV3 + dependencies
  10. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dggev3.f">
  11. *> [TGZ]</a>
  12. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dggev3.f">
  13. *> [ZIP]</a>
  14. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dggev3.f">
  15. *> [TXT]</a>
  16. *> \endhtmlonly
  17. *
  18. * Definition:
  19. * ===========
  20. *
  21. * SUBROUTINE DGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR,
  22. * $ ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK,
  23. * $ INFO )
  24. *
  25. * .. Scalar Arguments ..
  26. * CHARACTER JOBVL, JOBVR
  27. * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
  28. * ..
  29. * .. Array Arguments ..
  30. * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
  31. * $ B( LDB, * ), BETA( * ), VL( LDVL, * ),
  32. * $ VR( LDVR, * ), WORK( * )
  33. * ..
  34. *
  35. *
  36. *> \par Purpose:
  37. * =============
  38. *>
  39. *> \verbatim
  40. *>
  41. *> DGGEV3 computes for a pair of N-by-N real nonsymmetric matrices (A,B)
  42. *> the generalized eigenvalues, and optionally, the left and/or right
  43. *> generalized eigenvectors.
  44. *>
  45. *> A generalized eigenvalue for a pair of matrices (A,B) is a scalar
  46. *> lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
  47. *> singular. It is usually represented as the pair (alpha,beta), as
  48. *> there is a reasonable interpretation for beta=0, and even for both
  49. *> being zero.
  50. *>
  51. *> The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
  52. *> of (A,B) satisfies
  53. *>
  54. *> A * v(j) = lambda(j) * B * v(j).
  55. *>
  56. *> The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
  57. *> of (A,B) satisfies
  58. *>
  59. *> u(j)**H * A = lambda(j) * u(j)**H * B .
  60. *>
  61. *> where u(j)**H is the conjugate-transpose of u(j).
  62. *>
  63. *> \endverbatim
  64. *
  65. * Arguments:
  66. * ==========
  67. *
  68. *> \param[in] JOBVL
  69. *> \verbatim
  70. *> JOBVL is CHARACTER*1
  71. *> = 'N': do not compute the left generalized eigenvectors;
  72. *> = 'V': compute the left generalized eigenvectors.
  73. *> \endverbatim
  74. *>
  75. *> \param[in] JOBVR
  76. *> \verbatim
  77. *> JOBVR is CHARACTER*1
  78. *> = 'N': do not compute the right generalized eigenvectors;
  79. *> = 'V': compute the right generalized eigenvectors.
  80. *> \endverbatim
  81. *>
  82. *> \param[in] N
  83. *> \verbatim
  84. *> N is INTEGER
  85. *> The order of the matrices A, B, VL, and VR. N >= 0.
  86. *> \endverbatim
  87. *>
  88. *> \param[in,out] A
  89. *> \verbatim
  90. *> A is DOUBLE PRECISION array, dimension (LDA, N)
  91. *> On entry, the matrix A in the pair (A,B).
  92. *> On exit, A has been overwritten.
  93. *> \endverbatim
  94. *>
  95. *> \param[in] LDA
  96. *> \verbatim
  97. *> LDA is INTEGER
  98. *> The leading dimension of A. LDA >= max(1,N).
  99. *> \endverbatim
  100. *>
  101. *> \param[in,out] B
  102. *> \verbatim
  103. *> B is DOUBLE PRECISION array, dimension (LDB, N)
  104. *> On entry, the matrix B in the pair (A,B).
  105. *> On exit, B has been overwritten.
  106. *> \endverbatim
  107. *>
  108. *> \param[in] LDB
  109. *> \verbatim
  110. *> LDB is INTEGER
  111. *> The leading dimension of B. LDB >= max(1,N).
  112. *> \endverbatim
  113. *>
  114. *> \param[out] ALPHAR
  115. *> \verbatim
  116. *> ALPHAR is DOUBLE PRECISION array, dimension (N)
  117. *> \endverbatim
  118. *>
  119. *> \param[out] ALPHAI
  120. *> \verbatim
  121. *> ALPHAI is DOUBLE PRECISION array, dimension (N)
  122. *> \endverbatim
  123. *>
  124. *> \param[out] BETA
  125. *> \verbatim
  126. *> BETA is DOUBLE PRECISION array, dimension (N)
  127. *> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
  128. *> be the generalized eigenvalues. If ALPHAI(j) is zero, then
  129. *> the j-th eigenvalue is real; if positive, then the j-th and
  130. *> (j+1)-st eigenvalues are a complex conjugate pair, with
  131. *> ALPHAI(j+1) negative.
  132. *>
  133. *> Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
  134. *> may easily over- or underflow, and BETA(j) may even be zero.
  135. *> Thus, the user should avoid naively computing the ratio
  136. *> alpha/beta. However, ALPHAR and ALPHAI will be always less
  137. *> than and usually comparable with norm(A) in magnitude, and
  138. *> BETA always less than and usually comparable with norm(B).
  139. *> \endverbatim
  140. *>
  141. *> \param[out] VL
  142. *> \verbatim
  143. *> VL is DOUBLE PRECISION array, dimension (LDVL,N)
  144. *> If JOBVL = 'V', the left eigenvectors u(j) are stored one
  145. *> after another in the columns of VL, in the same order as
  146. *> their eigenvalues. If the j-th eigenvalue is real, then
  147. *> u(j) = VL(:,j), the j-th column of VL. If the j-th and
  148. *> (j+1)-th eigenvalues form a complex conjugate pair, then
  149. *> u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
  150. *> Each eigenvector is scaled so the largest component has
  151. *> abs(real part)+abs(imag. part)=1.
  152. *> Not referenced if JOBVL = 'N'.
  153. *> \endverbatim
  154. *>
  155. *> \param[in] LDVL
  156. *> \verbatim
  157. *> LDVL is INTEGER
  158. *> The leading dimension of the matrix VL. LDVL >= 1, and
  159. *> if JOBVL = 'V', LDVL >= N.
  160. *> \endverbatim
  161. *>
  162. *> \param[out] VR
  163. *> \verbatim
  164. *> VR is DOUBLE PRECISION array, dimension (LDVR,N)
  165. *> If JOBVR = 'V', the right eigenvectors v(j) are stored one
  166. *> after another in the columns of VR, in the same order as
  167. *> their eigenvalues. If the j-th eigenvalue is real, then
  168. *> v(j) = VR(:,j), the j-th column of VR. If the j-th and
  169. *> (j+1)-th eigenvalues form a complex conjugate pair, then
  170. *> v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
  171. *> Each eigenvector is scaled so the largest component has
  172. *> abs(real part)+abs(imag. part)=1.
  173. *> Not referenced if JOBVR = 'N'.
  174. *> \endverbatim
  175. *>
  176. *> \param[in] LDVR
  177. *> \verbatim
  178. *> LDVR is INTEGER
  179. *> The leading dimension of the matrix VR. LDVR >= 1, and
  180. *> if JOBVR = 'V', LDVR >= N.
  181. *> \endverbatim
  182. *>
  183. *> \param[out] WORK
  184. *> \verbatim
  185. *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
  186. *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
  187. *> \endverbatim
  188. *>
  189. *> \param[in] LWORK
  190. *> \verbatim
  191. *> LWORK is INTEGER.
  192. *> The dimension of the array WORK. LWORK >= MAX(1,8*N).
  193. *> For good performance, LWORK should generally be larger.
  194. *>
  195. *> If LWORK = -1, then a workspace query is assumed; the routine
  196. *> only calculates the optimal size of the WORK array, returns
  197. *> this value as the first entry of the WORK array, and no error
  198. *> message related to LWORK is issued by XERBLA.
  199. *> \endverbatim
  200. *>
  201. *> \param[out] INFO
  202. *> \verbatim
  203. *> INFO is INTEGER
  204. *> = 0: successful exit
  205. *> < 0: if INFO = -i, the i-th argument had an illegal value.
  206. *> = 1,...,N:
  207. *> The QZ iteration failed. No eigenvectors have been
  208. *> calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
  209. *> should be correct for j=INFO+1,...,N.
  210. *> > N: =N+1: other than QZ iteration failed in DLAQZ0.
  211. *> =N+2: error return from DTGEVC.
  212. *> \endverbatim
  213. *
  214. * Authors:
  215. * ========
  216. *
  217. *> \author Univ. of Tennessee
  218. *> \author Univ. of California Berkeley
  219. *> \author Univ. of Colorado Denver
  220. *> \author NAG Ltd.
  221. *
  222. *> \ingroup ggev3
  223. *
  224. * =====================================================================
  225. SUBROUTINE DGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR,
  226. $ ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK,
  227. $ INFO )
  228. *
  229. * -- LAPACK driver routine --
  230. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  231. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  232. *
  233. * .. Scalar Arguments ..
  234. CHARACTER JOBVL, JOBVR
  235. INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
  236. * ..
  237. * .. Array Arguments ..
  238. DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
  239. $ B( LDB, * ), BETA( * ), VL( LDVL, * ),
  240. $ VR( LDVR, * ), WORK( * )
  241. * ..
  242. *
  243. * =====================================================================
  244. *
  245. * .. Parameters ..
  246. DOUBLE PRECISION ZERO, ONE
  247. PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
  248. * ..
  249. * .. Local Scalars ..
  250. LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
  251. CHARACTER CHTEMP
  252. INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
  253. $ IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, LWKOPT,
  254. $ LWKMIN
  255. DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
  256. $ SMLNUM, TEMP
  257. * ..
  258. * .. Local Arrays ..
  259. LOGICAL LDUMMA( 1 )
  260. * ..
  261. * .. External Subroutines ..
  262. EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHD3, DLAQZ0, DLACPY,
  263. $ DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, XERBLA
  264. * ..
  265. * .. External Functions ..
  266. LOGICAL LSAME
  267. DOUBLE PRECISION DLAMCH, DLANGE
  268. EXTERNAL LSAME, DLAMCH, DLANGE
  269. * ..
  270. * .. Intrinsic Functions ..
  271. INTRINSIC ABS, MAX, SQRT
  272. * ..
  273. * .. Executable Statements ..
  274. *
  275. * Decode the input arguments
  276. *
  277. IF( LSAME( JOBVL, 'N' ) ) THEN
  278. IJOBVL = 1
  279. ILVL = .FALSE.
  280. ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
  281. IJOBVL = 2
  282. ILVL = .TRUE.
  283. ELSE
  284. IJOBVL = -1
  285. ILVL = .FALSE.
  286. END IF
  287. *
  288. IF( LSAME( JOBVR, 'N' ) ) THEN
  289. IJOBVR = 1
  290. ILVR = .FALSE.
  291. ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
  292. IJOBVR = 2
  293. ILVR = .TRUE.
  294. ELSE
  295. IJOBVR = -1
  296. ILVR = .FALSE.
  297. END IF
  298. ILV = ILVL .OR. ILVR
  299. *
  300. * Test the input arguments
  301. *
  302. INFO = 0
  303. LQUERY = ( LWORK.EQ.-1 )
  304. LWKMIN = MAX( 1, 8*N )
  305. IF( IJOBVL.LE.0 ) THEN
  306. INFO = -1
  307. ELSE IF( IJOBVR.LE.0 ) THEN
  308. INFO = -2
  309. ELSE IF( N.LT.0 ) THEN
  310. INFO = -3
  311. ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
  312. INFO = -5
  313. ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
  314. INFO = -7
  315. ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
  316. INFO = -12
  317. ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
  318. INFO = -14
  319. ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
  320. INFO = -16
  321. END IF
  322. *
  323. * Compute workspace
  324. *
  325. IF( INFO.EQ.0 ) THEN
  326. CALL DGEQRF( N, N, B, LDB, WORK, WORK, -1, IERR )
  327. LWKOPT = MAX( LWKMIN, 3*N+INT( WORK( 1 ) ) )
  328. CALL DORMQR( 'L', 'T', N, N, N, B, LDB, WORK, A, LDA, WORK, -1,
  329. $ IERR )
  330. LWKOPT = MAX( LWKOPT, 3*N+INT( WORK( 1 ) ) )
  331. IF( ILVL ) THEN
  332. CALL DORGQR( N, N, N, VL, LDVL, WORK, WORK, -1, IERR )
  333. LWKOPT = MAX( LWKOPT, 3*N+INT( WORK( 1 ) ) )
  334. END IF
  335. IF( ILV ) THEN
  336. CALL DGGHD3( JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, VL,
  337. $ LDVL, VR, LDVR, WORK, -1, IERR )
  338. LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) )
  339. CALL DLAQZ0( 'S', JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB,
  340. $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
  341. $ WORK, -1, 0, IERR )
  342. LWKOPT = MAX( LWKOPT, 2*N+INT( WORK( 1 ) ) )
  343. ELSE
  344. CALL DGGHD3( 'N', 'N', N, 1, N, A, LDA, B, LDB, VL, LDVL,
  345. $ VR, LDVR, WORK, -1, IERR )
  346. LWKOPT = MAX( LWKOPT, 3*N+INT( WORK( 1 ) ) )
  347. CALL DLAQZ0( 'E', JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB,
  348. $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
  349. $ WORK, -1, 0, IERR )
  350. LWKOPT = MAX( LWKOPT, 2*N+INT( WORK( 1 ) ) )
  351. END IF
  352. IF( N.EQ.0 ) THEN
  353. WORK( 1 ) = 1
  354. ELSE
  355. WORK( 1 ) = LWKOPT
  356. END IF
  357. END IF
  358. *
  359. IF( INFO.NE.0 ) THEN
  360. CALL XERBLA( 'DGGEV3 ', -INFO )
  361. RETURN
  362. ELSE IF( LQUERY ) THEN
  363. RETURN
  364. END IF
  365. *
  366. * Quick return if possible
  367. *
  368. IF( N.EQ.0 )
  369. $ RETURN
  370. *
  371. * Get machine constants
  372. *
  373. EPS = DLAMCH( 'P' )
  374. SMLNUM = DLAMCH( 'S' )
  375. BIGNUM = ONE / SMLNUM
  376. SMLNUM = SQRT( SMLNUM ) / EPS
  377. BIGNUM = ONE / SMLNUM
  378. *
  379. * Scale A if max element outside range [SMLNUM,BIGNUM]
  380. *
  381. ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
  382. ILASCL = .FALSE.
  383. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
  384. ANRMTO = SMLNUM
  385. ILASCL = .TRUE.
  386. ELSE IF( ANRM.GT.BIGNUM ) THEN
  387. ANRMTO = BIGNUM
  388. ILASCL = .TRUE.
  389. END IF
  390. IF( ILASCL )
  391. $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
  392. *
  393. * Scale B if max element outside range [SMLNUM,BIGNUM]
  394. *
  395. BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
  396. ILBSCL = .FALSE.
  397. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
  398. BNRMTO = SMLNUM
  399. ILBSCL = .TRUE.
  400. ELSE IF( BNRM.GT.BIGNUM ) THEN
  401. BNRMTO = BIGNUM
  402. ILBSCL = .TRUE.
  403. END IF
  404. IF( ILBSCL )
  405. $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
  406. *
  407. * Permute the matrices A, B to isolate eigenvalues if possible
  408. *
  409. ILEFT = 1
  410. IRIGHT = N + 1
  411. IWRK = IRIGHT + N
  412. CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
  413. $ WORK( IRIGHT ), WORK( IWRK ), IERR )
  414. *
  415. * Reduce B to triangular form (QR decomposition of B)
  416. *
  417. IROWS = IHI + 1 - ILO
  418. IF( ILV ) THEN
  419. ICOLS = N + 1 - ILO
  420. ELSE
  421. ICOLS = IROWS
  422. END IF
  423. ITAU = IWRK
  424. IWRK = ITAU + IROWS
  425. CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
  426. $ WORK( IWRK ), LWORK+1-IWRK, IERR )
  427. *
  428. * Apply the orthogonal transformation to matrix A
  429. *
  430. CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
  431. $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
  432. $ LWORK+1-IWRK, IERR )
  433. *
  434. * Initialize VL
  435. *
  436. IF( ILVL ) THEN
  437. CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
  438. IF( IROWS.GT.1 ) THEN
  439. CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
  440. $ VL( ILO+1, ILO ), LDVL )
  441. END IF
  442. CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
  443. $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
  444. END IF
  445. *
  446. * Initialize VR
  447. *
  448. IF( ILVR )
  449. $ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
  450. *
  451. * Reduce to generalized Hessenberg form
  452. *
  453. IF( ILV ) THEN
  454. *
  455. * Eigenvectors requested -- work on whole matrix.
  456. *
  457. CALL DGGHD3( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
  458. $ LDVL, VR, LDVR, WORK( IWRK ), LWORK+1-IWRK, IERR )
  459. ELSE
  460. CALL DGGHD3( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
  461. $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR,
  462. $ WORK( IWRK ), LWORK+1-IWRK, IERR )
  463. END IF
  464. *
  465. * Perform QZ algorithm (Compute eigenvalues, and optionally, the
  466. * Schur forms and Schur vectors)
  467. *
  468. IWRK = ITAU
  469. IF( ILV ) THEN
  470. CHTEMP = 'S'
  471. ELSE
  472. CHTEMP = 'E'
  473. END IF
  474. CALL DLAQZ0( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
  475. $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
  476. $ WORK( IWRK ), LWORK+1-IWRK, 0, IERR )
  477. IF( IERR.NE.0 ) THEN
  478. IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
  479. INFO = IERR
  480. ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
  481. INFO = IERR - N
  482. ELSE
  483. INFO = N + 1
  484. END IF
  485. GO TO 110
  486. END IF
  487. *
  488. * Compute Eigenvectors
  489. *
  490. IF( ILV ) THEN
  491. IF( ILVL ) THEN
  492. IF( ILVR ) THEN
  493. CHTEMP = 'B'
  494. ELSE
  495. CHTEMP = 'L'
  496. END IF
  497. ELSE
  498. CHTEMP = 'R'
  499. END IF
  500. CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
  501. $ VR, LDVR, N, IN, WORK( IWRK ), IERR )
  502. IF( IERR.NE.0 ) THEN
  503. INFO = N + 2
  504. GO TO 110
  505. END IF
  506. *
  507. * Undo balancing on VL and VR and normalization
  508. *
  509. IF( ILVL ) THEN
  510. CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
  511. $ WORK( IRIGHT ), N, VL, LDVL, IERR )
  512. DO 50 JC = 1, N
  513. IF( ALPHAI( JC ).LT.ZERO )
  514. $ GO TO 50
  515. TEMP = ZERO
  516. IF( ALPHAI( JC ).EQ.ZERO ) THEN
  517. DO 10 JR = 1, N
  518. TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
  519. 10 CONTINUE
  520. ELSE
  521. DO 20 JR = 1, N
  522. TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
  523. $ ABS( VL( JR, JC+1 ) ) )
  524. 20 CONTINUE
  525. END IF
  526. IF( TEMP.LT.SMLNUM )
  527. $ GO TO 50
  528. TEMP = ONE / TEMP
  529. IF( ALPHAI( JC ).EQ.ZERO ) THEN
  530. DO 30 JR = 1, N
  531. VL( JR, JC ) = VL( JR, JC )*TEMP
  532. 30 CONTINUE
  533. ELSE
  534. DO 40 JR = 1, N
  535. VL( JR, JC ) = VL( JR, JC )*TEMP
  536. VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
  537. 40 CONTINUE
  538. END IF
  539. 50 CONTINUE
  540. END IF
  541. IF( ILVR ) THEN
  542. CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
  543. $ WORK( IRIGHT ), N, VR, LDVR, IERR )
  544. DO 100 JC = 1, N
  545. IF( ALPHAI( JC ).LT.ZERO )
  546. $ GO TO 100
  547. TEMP = ZERO
  548. IF( ALPHAI( JC ).EQ.ZERO ) THEN
  549. DO 60 JR = 1, N
  550. TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
  551. 60 CONTINUE
  552. ELSE
  553. DO 70 JR = 1, N
  554. TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
  555. $ ABS( VR( JR, JC+1 ) ) )
  556. 70 CONTINUE
  557. END IF
  558. IF( TEMP.LT.SMLNUM )
  559. $ GO TO 100
  560. TEMP = ONE / TEMP
  561. IF( ALPHAI( JC ).EQ.ZERO ) THEN
  562. DO 80 JR = 1, N
  563. VR( JR, JC ) = VR( JR, JC )*TEMP
  564. 80 CONTINUE
  565. ELSE
  566. DO 90 JR = 1, N
  567. VR( JR, JC ) = VR( JR, JC )*TEMP
  568. VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
  569. 90 CONTINUE
  570. END IF
  571. 100 CONTINUE
  572. END IF
  573. *
  574. * End of eigenvector calculation
  575. *
  576. END IF
  577. *
  578. * Undo scaling if necessary
  579. *
  580. 110 CONTINUE
  581. *
  582. IF( ILASCL ) THEN
  583. CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
  584. CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
  585. END IF
  586. *
  587. IF( ILBSCL ) THEN
  588. CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
  589. END IF
  590. *
  591. WORK( 1 ) = LWKOPT
  592. RETURN
  593. *
  594. * End of DGGEV3
  595. *
  596. END