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.

sgeevx.f 24 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691
  1. *> \brief <b> SGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices</b>
  2. *
  3. * =========== DOCUMENTATION ===========
  4. *
  5. * Online html documentation available at
  6. * http://www.netlib.org/lapack/explore-html/
  7. *
  8. *> \htmlonly
  9. *> Download SGEEVX + dependencies
  10. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgeevx.f">
  11. *> [TGZ]</a>
  12. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgeevx.f">
  13. *> [ZIP]</a>
  14. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgeevx.f">
  15. *> [TXT]</a>
  16. *> \endhtmlonly
  17. *
  18. * Definition:
  19. * ===========
  20. *
  21. * SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI,
  22. * VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM,
  23. * RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )
  24. *
  25. * .. Scalar Arguments ..
  26. * CHARACTER BALANC, JOBVL, JOBVR, SENSE
  27. * INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
  28. * REAL ABNRM
  29. * ..
  30. * .. Array Arguments ..
  31. * INTEGER IWORK( * )
  32. * REAL A( LDA, * ), RCONDE( * ), RCONDV( * ),
  33. * $ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ),
  34. * $ WI( * ), WORK( * ), WR( * )
  35. * ..
  36. *
  37. *
  38. *> \par Purpose:
  39. * =============
  40. *>
  41. *> \verbatim
  42. *>
  43. *> SGEEVX computes for an N-by-N real nonsymmetric matrix A, the
  44. *> eigenvalues and, optionally, the left and/or right eigenvectors.
  45. *>
  46. *> Optionally also, it computes a balancing transformation to improve
  47. *> the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
  48. *> SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
  49. *> (RCONDE), and reciprocal condition numbers for the right
  50. *> eigenvectors (RCONDV).
  51. *>
  52. *> The right eigenvector v(j) of A satisfies
  53. *> A * v(j) = lambda(j) * v(j)
  54. *> where lambda(j) is its eigenvalue.
  55. *> The left eigenvector u(j) of A satisfies
  56. *> u(j)**H * A = lambda(j) * u(j)**H
  57. *> where u(j)**H denotes the conjugate-transpose of u(j).
  58. *>
  59. *> The computed eigenvectors are normalized to have Euclidean norm
  60. *> equal to 1 and largest component real.
  61. *>
  62. *> Balancing a matrix means permuting the rows and columns to make it
  63. *> more nearly upper triangular, and applying a diagonal similarity
  64. *> transformation D * A * D**(-1), where D is a diagonal matrix, to
  65. *> make its rows and columns closer in norm and the condition numbers
  66. *> of its eigenvalues and eigenvectors smaller. The computed
  67. *> reciprocal condition numbers correspond to the balanced matrix.
  68. *> Permuting rows and columns will not change the condition numbers
  69. *> (in exact arithmetic) but diagonal scaling will. For further
  70. *> explanation of balancing, see section 4.10.2 of the LAPACK
  71. *> Users' Guide.
  72. *> \endverbatim
  73. *
  74. * Arguments:
  75. * ==========
  76. *
  77. *> \param[in] BALANC
  78. *> \verbatim
  79. *> BALANC is CHARACTER*1
  80. *> Indicates how the input matrix should be diagonally scaled
  81. *> and/or permuted to improve the conditioning of its
  82. *> eigenvalues.
  83. *> = 'N': Do not diagonally scale or permute;
  84. *> = 'P': Perform permutations to make the matrix more nearly
  85. *> upper triangular. Do not diagonally scale;
  86. *> = 'S': Diagonally scale the matrix, i.e. replace A by
  87. *> D*A*D**(-1), where D is a diagonal matrix chosen
  88. *> to make the rows and columns of A more equal in
  89. *> norm. Do not permute;
  90. *> = 'B': Both diagonally scale and permute A.
  91. *>
  92. *> Computed reciprocal condition numbers will be for the matrix
  93. *> after balancing and/or permuting. Permuting does not change
  94. *> condition numbers (in exact arithmetic), but balancing does.
  95. *> \endverbatim
  96. *>
  97. *> \param[in] JOBVL
  98. *> \verbatim
  99. *> JOBVL is CHARACTER*1
  100. *> = 'N': left eigenvectors of A are not computed;
  101. *> = 'V': left eigenvectors of A are computed.
  102. *> If SENSE = 'E' or 'B', JOBVL must = 'V'.
  103. *> \endverbatim
  104. *>
  105. *> \param[in] JOBVR
  106. *> \verbatim
  107. *> JOBVR is CHARACTER*1
  108. *> = 'N': right eigenvectors of A are not computed;
  109. *> = 'V': right eigenvectors of A are computed.
  110. *> If SENSE = 'E' or 'B', JOBVR must = 'V'.
  111. *> \endverbatim
  112. *>
  113. *> \param[in] SENSE
  114. *> \verbatim
  115. *> SENSE is CHARACTER*1
  116. *> Determines which reciprocal condition numbers are computed.
  117. *> = 'N': None are computed;
  118. *> = 'E': Computed for eigenvalues only;
  119. *> = 'V': Computed for right eigenvectors only;
  120. *> = 'B': Computed for eigenvalues and right eigenvectors.
  121. *>
  122. *> If SENSE = 'E' or 'B', both left and right eigenvectors
  123. *> must also be computed (JOBVL = 'V' and JOBVR = 'V').
  124. *> \endverbatim
  125. *>
  126. *> \param[in] N
  127. *> \verbatim
  128. *> N is INTEGER
  129. *> The order of the matrix A. N >= 0.
  130. *> \endverbatim
  131. *>
  132. *> \param[in,out] A
  133. *> \verbatim
  134. *> A is REAL array, dimension (LDA,N)
  135. *> On entry, the N-by-N matrix A.
  136. *> On exit, A has been overwritten. If JOBVL = 'V' or
  137. *> JOBVR = 'V', A contains the real Schur form of the balanced
  138. *> version of the input matrix A.
  139. *> \endverbatim
  140. *>
  141. *> \param[in] LDA
  142. *> \verbatim
  143. *> LDA is INTEGER
  144. *> The leading dimension of the array A. LDA >= max(1,N).
  145. *> \endverbatim
  146. *>
  147. *> \param[out] WR
  148. *> \verbatim
  149. *> WR is REAL array, dimension (N)
  150. *> \endverbatim
  151. *>
  152. *> \param[out] WI
  153. *> \verbatim
  154. *> WI is REAL array, dimension (N)
  155. *> WR and WI contain the real and imaginary parts,
  156. *> respectively, of the computed eigenvalues. Complex
  157. *> conjugate pairs of eigenvalues will appear consecutively
  158. *> with the eigenvalue having the positive imaginary part
  159. *> first.
  160. *> \endverbatim
  161. *>
  162. *> \param[out] VL
  163. *> \verbatim
  164. *> VL is REAL array, dimension (LDVL,N)
  165. *> If JOBVL = 'V', the left eigenvectors u(j) are stored one
  166. *> after another in the columns of VL, in the same order
  167. *> as their eigenvalues.
  168. *> If JOBVL = 'N', VL is not referenced.
  169. *> If the j-th eigenvalue is real, then u(j) = VL(:,j),
  170. *> the j-th column of VL.
  171. *> If the j-th and (j+1)-st eigenvalues form a complex
  172. *> conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
  173. *> u(j+1) = VL(:,j) - i*VL(:,j+1).
  174. *> \endverbatim
  175. *>
  176. *> \param[in] LDVL
  177. *> \verbatim
  178. *> LDVL is INTEGER
  179. *> The leading dimension of the array VL. LDVL >= 1; if
  180. *> JOBVL = 'V', LDVL >= N.
  181. *> \endverbatim
  182. *>
  183. *> \param[out] VR
  184. *> \verbatim
  185. *> VR is REAL array, dimension (LDVR,N)
  186. *> If JOBVR = 'V', the right eigenvectors v(j) are stored one
  187. *> after another in the columns of VR, in the same order
  188. *> as their eigenvalues.
  189. *> If JOBVR = 'N', VR is not referenced.
  190. *> If the j-th eigenvalue is real, then v(j) = VR(:,j),
  191. *> the j-th column of VR.
  192. *> If the j-th and (j+1)-st eigenvalues form a complex
  193. *> conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
  194. *> v(j+1) = VR(:,j) - i*VR(:,j+1).
  195. *> \endverbatim
  196. *>
  197. *> \param[in] LDVR
  198. *> \verbatim
  199. *> LDVR is INTEGER
  200. *> The leading dimension of the array VR. LDVR >= 1, and if
  201. *> JOBVR = 'V', LDVR >= N.
  202. *> \endverbatim
  203. *>
  204. *> \param[out] ILO
  205. *> \verbatim
  206. *> ILO is INTEGER
  207. *> \endverbatim
  208. *>
  209. *> \param[out] IHI
  210. *> \verbatim
  211. *> IHI is INTEGER
  212. *> ILO and IHI are integer values determined when A was
  213. *> balanced. The balanced A(i,j) = 0 if I > J and
  214. *> J = 1,...,ILO-1 or I = IHI+1,...,N.
  215. *> \endverbatim
  216. *>
  217. *> \param[out] SCALE
  218. *> \verbatim
  219. *> SCALE is REAL array, dimension (N)
  220. *> Details of the permutations and scaling factors applied
  221. *> when balancing A. If P(j) is the index of the row and column
  222. *> interchanged with row and column j, and D(j) is the scaling
  223. *> factor applied to row and column j, then
  224. *> SCALE(J) = P(J), for J = 1,...,ILO-1
  225. *> = D(J), for J = ILO,...,IHI
  226. *> = P(J) for J = IHI+1,...,N.
  227. *> The order in which the interchanges are made is N to IHI+1,
  228. *> then 1 to ILO-1.
  229. *> \endverbatim
  230. *>
  231. *> \param[out] ABNRM
  232. *> \verbatim
  233. *> ABNRM is REAL
  234. *> The one-norm of the balanced matrix (the maximum
  235. *> of the sum of absolute values of elements of any column).
  236. *> \endverbatim
  237. *>
  238. *> \param[out] RCONDE
  239. *> \verbatim
  240. *> RCONDE is REAL array, dimension (N)
  241. *> RCONDE(j) is the reciprocal condition number of the j-th
  242. *> eigenvalue.
  243. *> \endverbatim
  244. *>
  245. *> \param[out] RCONDV
  246. *> \verbatim
  247. *> RCONDV is REAL array, dimension (N)
  248. *> RCONDV(j) is the reciprocal condition number of the j-th
  249. *> right eigenvector.
  250. *> \endverbatim
  251. *>
  252. *> \param[out] WORK
  253. *> \verbatim
  254. *> WORK is REAL array, dimension (MAX(1,LWORK))
  255. *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
  256. *> \endverbatim
  257. *>
  258. *> \param[in] LWORK
  259. *> \verbatim
  260. *> LWORK is INTEGER
  261. *> The dimension of the array WORK. If SENSE = 'N' or 'E',
  262. *> LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',
  263. *> LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).
  264. *> For good performance, LWORK must generally be larger.
  265. *>
  266. *> If LWORK = -1, then a workspace query is assumed; the routine
  267. *> only calculates the optimal size of the WORK array, returns
  268. *> this value as the first entry of the WORK array, and no error
  269. *> message related to LWORK is issued by XERBLA.
  270. *> \endverbatim
  271. *>
  272. *> \param[out] IWORK
  273. *> \verbatim
  274. *> IWORK is INTEGER array, dimension (2*N-2)
  275. *> If SENSE = 'N' or 'E', not referenced.
  276. *> \endverbatim
  277. *>
  278. *> \param[out] INFO
  279. *> \verbatim
  280. *> INFO is INTEGER
  281. *> = 0: successful exit
  282. *> < 0: if INFO = -i, the i-th argument had an illegal value.
  283. *> > 0: if INFO = i, the QR algorithm failed to compute all the
  284. *> eigenvalues, and no eigenvectors or condition numbers
  285. *> have been computed; elements 1:ILO-1 and i+1:N of WR
  286. *> and WI contain eigenvalues which have converged.
  287. *> \endverbatim
  288. *
  289. * Authors:
  290. * ========
  291. *
  292. *> \author Univ. of Tennessee
  293. *> \author Univ. of California Berkeley
  294. *> \author Univ. of Colorado Denver
  295. *> \author NAG Ltd.
  296. *
  297. *
  298. * @generated from dgeevx.f, fortran d -> s, Tue Apr 19 01:47:44 2016
  299. *
  300. *> \ingroup geevx
  301. *
  302. * =====================================================================
  303. SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI,
  304. $ VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM,
  305. $ RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )
  306. implicit none
  307. *
  308. * -- LAPACK driver routine --
  309. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  310. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  311. *
  312. * .. Scalar Arguments ..
  313. CHARACTER BALANC, JOBVL, JOBVR, SENSE
  314. INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
  315. REAL ABNRM
  316. * ..
  317. * .. Array Arguments ..
  318. INTEGER IWORK( * )
  319. REAL A( LDA, * ), RCONDE( * ), RCONDV( * ),
  320. $ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ),
  321. $ WI( * ), WORK( * ), WR( * )
  322. * ..
  323. *
  324. * =====================================================================
  325. *
  326. * .. Parameters ..
  327. REAL ZERO, ONE
  328. PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
  329. * ..
  330. * .. Local Scalars ..
  331. LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE,
  332. $ WNTSNN, WNTSNV
  333. CHARACTER JOB, SIDE
  334. INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K,
  335. $ LWORK_TREVC, MAXWRK, MINWRK, NOUT
  336. REAL ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
  337. $ SN
  338. * ..
  339. * .. Local Arrays ..
  340. LOGICAL SELECT( 1 )
  341. REAL DUM( 1 )
  342. * ..
  343. * .. External Subroutines ..
  344. EXTERNAL SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLACPY,
  345. $ SLARTG, SLASCL, SORGHR, SROT, SSCAL, STREVC3,
  346. $ STRSNA, XERBLA
  347. * ..
  348. * .. External Functions ..
  349. LOGICAL LSAME
  350. INTEGER ISAMAX, ILAENV
  351. REAL SLAMCH, SLANGE, SLAPY2, SNRM2, SROUNDUP_LWORK
  352. EXTERNAL LSAME, ISAMAX, ILAENV, SLAMCH, SLANGE, SLAPY2,
  353. $ SNRM2, SROUNDUP_LWORK
  354. * ..
  355. * .. Intrinsic Functions ..
  356. INTRINSIC MAX, SQRT
  357. * ..
  358. * .. Executable Statements ..
  359. *
  360. * Test the input arguments
  361. *
  362. INFO = 0
  363. LQUERY = ( LWORK.EQ.-1 )
  364. WANTVL = LSAME( JOBVL, 'V' )
  365. WANTVR = LSAME( JOBVR, 'V' )
  366. WNTSNN = LSAME( SENSE, 'N' )
  367. WNTSNE = LSAME( SENSE, 'E' )
  368. WNTSNV = LSAME( SENSE, 'V' )
  369. WNTSNB = LSAME( SENSE, 'B' )
  370. IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'S' )
  371. $ .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) )
  372. $ THEN
  373. INFO = -1
  374. ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
  375. INFO = -2
  376. ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
  377. INFO = -3
  378. ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR.
  379. $ ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND.
  380. $ WANTVR ) ) ) THEN
  381. INFO = -4
  382. ELSE IF( N.LT.0 ) THEN
  383. INFO = -5
  384. ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
  385. INFO = -7
  386. ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
  387. INFO = -11
  388. ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
  389. INFO = -13
  390. END IF
  391. *
  392. * Compute workspace
  393. * (Note: Comments in the code beginning "Workspace:" describe the
  394. * minimal amount of workspace needed at that point in the code,
  395. * as well as the preferred amount for good performance.
  396. * NB refers to the optimal block size for the immediately
  397. * following subroutine, as returned by ILAENV.
  398. * HSWORK refers to the workspace preferred by SHSEQR, as
  399. * calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
  400. * the worst case.)
  401. *
  402. IF( INFO.EQ.0 ) THEN
  403. IF( N.EQ.0 ) THEN
  404. MINWRK = 1
  405. MAXWRK = 1
  406. ELSE
  407. MAXWRK = N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 )
  408. *
  409. IF( WANTVL ) THEN
  410. CALL STREVC3( 'L', 'B', SELECT, N, A, LDA,
  411. $ VL, LDVL, VR, LDVR,
  412. $ N, NOUT, WORK, -1, IERR )
  413. LWORK_TREVC = INT( WORK(1) )
  414. MAXWRK = MAX( MAXWRK, N + LWORK_TREVC )
  415. CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
  416. $ WORK, -1, INFO )
  417. ELSE IF( WANTVR ) THEN
  418. CALL STREVC3( 'R', 'B', SELECT, N, A, LDA,
  419. $ VL, LDVL, VR, LDVR,
  420. $ N, NOUT, WORK, -1, IERR )
  421. LWORK_TREVC = INT( WORK(1) )
  422. MAXWRK = MAX( MAXWRK, N + LWORK_TREVC )
  423. CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
  424. $ WORK, -1, INFO )
  425. ELSE
  426. IF( WNTSNN ) THEN
  427. CALL SHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR,
  428. $ LDVR, WORK, -1, INFO )
  429. ELSE
  430. CALL SHSEQR( 'S', 'N', N, 1, N, A, LDA, WR, WI, VR,
  431. $ LDVR, WORK, -1, INFO )
  432. END IF
  433. END IF
  434. HSWORK = INT( WORK(1) )
  435. *
  436. IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
  437. MINWRK = 2*N
  438. IF( .NOT.WNTSNN )
  439. $ MINWRK = MAX( MINWRK, N*N+6*N )
  440. MAXWRK = MAX( MAXWRK, HSWORK )
  441. IF( .NOT.WNTSNN )
  442. $ MAXWRK = MAX( MAXWRK, N*N + 6*N )
  443. ELSE
  444. MINWRK = 3*N
  445. IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
  446. $ MINWRK = MAX( MINWRK, N*N + 6*N )
  447. MAXWRK = MAX( MAXWRK, HSWORK )
  448. MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'SORGHR',
  449. $ ' ', N, 1, N, -1 ) )
  450. IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
  451. $ MAXWRK = MAX( MAXWRK, N*N + 6*N )
  452. MAXWRK = MAX( MAXWRK, 3*N )
  453. END IF
  454. MAXWRK = MAX( MAXWRK, MINWRK )
  455. END IF
  456. WORK( 1 ) = SROUNDUP_LWORK(MAXWRK)
  457. *
  458. IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
  459. INFO = -21
  460. END IF
  461. END IF
  462. *
  463. IF( INFO.NE.0 ) THEN
  464. CALL XERBLA( 'SGEEVX', -INFO )
  465. RETURN
  466. ELSE IF( LQUERY ) THEN
  467. RETURN
  468. END IF
  469. *
  470. * Quick return if possible
  471. *
  472. IF( N.EQ.0 )
  473. $ RETURN
  474. *
  475. * Get machine constants
  476. *
  477. EPS = SLAMCH( 'P' )
  478. SMLNUM = SLAMCH( 'S' )
  479. BIGNUM = ONE / SMLNUM
  480. SMLNUM = SQRT( SMLNUM ) / EPS
  481. BIGNUM = ONE / SMLNUM
  482. *
  483. * Scale A if max element outside range [SMLNUM,BIGNUM]
  484. *
  485. ICOND = 0
  486. ANRM = SLANGE( 'M', N, N, A, LDA, DUM )
  487. SCALEA = .FALSE.
  488. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
  489. SCALEA = .TRUE.
  490. CSCALE = SMLNUM
  491. ELSE IF( ANRM.GT.BIGNUM ) THEN
  492. SCALEA = .TRUE.
  493. CSCALE = BIGNUM
  494. END IF
  495. IF( SCALEA )
  496. $ CALL SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
  497. *
  498. * Balance the matrix and compute ABNRM
  499. *
  500. CALL SGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR )
  501. ABNRM = SLANGE( '1', N, N, A, LDA, DUM )
  502. IF( SCALEA ) THEN
  503. DUM( 1 ) = ABNRM
  504. CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
  505. ABNRM = DUM( 1 )
  506. END IF
  507. *
  508. * Reduce to upper Hessenberg form
  509. * (Workspace: need 2*N, prefer N+N*NB)
  510. *
  511. ITAU = 1
  512. IWRK = ITAU + N
  513. CALL SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
  514. $ LWORK-IWRK+1, IERR )
  515. *
  516. IF( WANTVL ) THEN
  517. *
  518. * Want left eigenvectors
  519. * Copy Householder vectors to VL
  520. *
  521. SIDE = 'L'
  522. CALL SLACPY( 'L', N, N, A, LDA, VL, LDVL )
  523. *
  524. * Generate orthogonal matrix in VL
  525. * (Workspace: need 2*N-1, prefer N+(N-1)*NB)
  526. *
  527. CALL SORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
  528. $ LWORK-IWRK+1, IERR )
  529. *
  530. * Perform QR iteration, accumulating Schur vectors in VL
  531. * (Workspace: need 1, prefer HSWORK (see comments) )
  532. *
  533. IWRK = ITAU
  534. CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL,
  535. $ WORK( IWRK ), LWORK-IWRK+1, INFO )
  536. *
  537. IF( WANTVR ) THEN
  538. *
  539. * Want left and right eigenvectors
  540. * Copy Schur vectors to VR
  541. *
  542. SIDE = 'B'
  543. CALL SLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
  544. END IF
  545. *
  546. ELSE IF( WANTVR ) THEN
  547. *
  548. * Want right eigenvectors
  549. * Copy Householder vectors to VR
  550. *
  551. SIDE = 'R'
  552. CALL SLACPY( 'L', N, N, A, LDA, VR, LDVR )
  553. *
  554. * Generate orthogonal matrix in VR
  555. * (Workspace: need 2*N-1, prefer N+(N-1)*NB)
  556. *
  557. CALL SORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
  558. $ LWORK-IWRK+1, IERR )
  559. *
  560. * Perform QR iteration, accumulating Schur vectors in VR
  561. * (Workspace: need 1, prefer HSWORK (see comments) )
  562. *
  563. IWRK = ITAU
  564. CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
  565. $ WORK( IWRK ), LWORK-IWRK+1, INFO )
  566. *
  567. ELSE
  568. *
  569. * Compute eigenvalues only
  570. * If condition numbers desired, compute Schur form
  571. *
  572. IF( WNTSNN ) THEN
  573. JOB = 'E'
  574. ELSE
  575. JOB = 'S'
  576. END IF
  577. *
  578. * (Workspace: need 1, prefer HSWORK (see comments) )
  579. *
  580. IWRK = ITAU
  581. CALL SHSEQR( JOB, 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
  582. $ WORK( IWRK ), LWORK-IWRK+1, INFO )
  583. END IF
  584. *
  585. * If INFO .NE. 0 from SHSEQR, then quit
  586. *
  587. IF( INFO.NE.0 )
  588. $ GO TO 50
  589. *
  590. IF( WANTVL .OR. WANTVR ) THEN
  591. *
  592. * Compute left and/or right eigenvectors
  593. * (Workspace: need 3*N, prefer N + 2*N*NB)
  594. *
  595. CALL STREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
  596. $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, IERR )
  597. END IF
  598. *
  599. * Compute condition numbers if desired
  600. * (Workspace: need N*N+6*N unless SENSE = 'E')
  601. *
  602. IF( .NOT.WNTSNN ) THEN
  603. CALL STRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
  604. $ RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, IWORK,
  605. $ ICOND )
  606. END IF
  607. *
  608. IF( WANTVL ) THEN
  609. *
  610. * Undo balancing of left eigenvectors
  611. *
  612. CALL SGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, N, VL, LDVL,
  613. $ IERR )
  614. *
  615. * Normalize left eigenvectors and make largest component real
  616. *
  617. DO 20 I = 1, N
  618. IF( WI( I ).EQ.ZERO ) THEN
  619. SCL = ONE / SNRM2( N, VL( 1, I ), 1 )
  620. CALL SSCAL( N, SCL, VL( 1, I ), 1 )
  621. ELSE IF( WI( I ).GT.ZERO ) THEN
  622. SCL = ONE / SLAPY2( SNRM2( N, VL( 1, I ), 1 ),
  623. $ SNRM2( N, VL( 1, I+1 ), 1 ) )
  624. CALL SSCAL( N, SCL, VL( 1, I ), 1 )
  625. CALL SSCAL( N, SCL, VL( 1, I+1 ), 1 )
  626. DO 10 K = 1, N
  627. WORK( K ) = VL( K, I )**2 + VL( K, I+1 )**2
  628. 10 CONTINUE
  629. K = ISAMAX( N, WORK, 1 )
  630. CALL SLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
  631. CALL SROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
  632. VL( K, I+1 ) = ZERO
  633. END IF
  634. 20 CONTINUE
  635. END IF
  636. *
  637. IF( WANTVR ) THEN
  638. *
  639. * Undo balancing of right eigenvectors
  640. *
  641. CALL SGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, N, VR, LDVR,
  642. $ IERR )
  643. *
  644. * Normalize right eigenvectors and make largest component real
  645. *
  646. DO 40 I = 1, N
  647. IF( WI( I ).EQ.ZERO ) THEN
  648. SCL = ONE / SNRM2( N, VR( 1, I ), 1 )
  649. CALL SSCAL( N, SCL, VR( 1, I ), 1 )
  650. ELSE IF( WI( I ).GT.ZERO ) THEN
  651. SCL = ONE / SLAPY2( SNRM2( N, VR( 1, I ), 1 ),
  652. $ SNRM2( N, VR( 1, I+1 ), 1 ) )
  653. CALL SSCAL( N, SCL, VR( 1, I ), 1 )
  654. CALL SSCAL( N, SCL, VR( 1, I+1 ), 1 )
  655. DO 30 K = 1, N
  656. WORK( K ) = VR( K, I )**2 + VR( K, I+1 )**2
  657. 30 CONTINUE
  658. K = ISAMAX( N, WORK, 1 )
  659. CALL SLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
  660. CALL SROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
  661. VR( K, I+1 ) = ZERO
  662. END IF
  663. 40 CONTINUE
  664. END IF
  665. *
  666. * Undo scaling if necessary
  667. *
  668. 50 CONTINUE
  669. IF( SCALEA ) THEN
  670. CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
  671. $ MAX( N-INFO, 1 ), IERR )
  672. CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
  673. $ MAX( N-INFO, 1 ), IERR )
  674. IF( INFO.EQ.0 ) THEN
  675. IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 )
  676. $ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N,
  677. $ IERR )
  678. ELSE
  679. CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
  680. $ IERR )
  681. CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
  682. $ IERR )
  683. END IF
  684. END IF
  685. *
  686. WORK( 1 ) = SROUNDUP_LWORK(MAXWRK)
  687. RETURN
  688. *
  689. * End of SGEEVX
  690. *
  691. END