Télécharger dlahqr.eso

Retour à la liste

Numérotation des lignes :

dlahqr
  1. C DLAHQR SOURCE FANDEUR 22/05/02 21:15:07 11359
  2. *
  3. *> \brief \b DLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.
  4. *
  5. * =========== DOCUMENTATION ===========
  6. *
  7. * Online html documentation available at
  8. * http://www.netlib.org/lapack/explore-html/
  9. *
  10. *> \htmlonly
  11. *> Download DLAHQR + dependencies
  12. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlahqr.f">
  13. *> [TGZ]</a>
  14. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlahqr.f">
  15. *> [ZIP]</a>
  16. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlahqr.f">
  17. *> [TXT]</a>
  18. *> \endhtmlonly
  19. *
  20. * Definition:
  21. * ===========
  22. *
  23. * SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
  24. * ILOZ, IHIZ, Z, LDZ, INFO )
  25. *
  26. * .. Scalar Arguments ..
  27. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
  28. * LOGICAL WANTT, WANTZ
  29. * ..
  30. * .. Array Arguments ..
  31. * DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
  32. * ..
  33. *
  34. *
  35. *> \par Purpose:
  36. * =============
  37. *>
  38. *> \verbatim
  39. *>
  40. *> DLAHQR is an auxiliary routine called by DHSEQR to update the
  41. *> eigenvalues and Schur decomposition already computed by DHSEQR, by
  42. *> dealing with the Hessenberg submatrix in rows and columns ILO to
  43. *> IHI.
  44. *> \endverbatim
  45. *
  46. * Arguments:
  47. * ==========
  48. *
  49. *> \param[in] WANTT
  50. *> \verbatim
  51. *> WANTT is LOGICAL
  52. *> = .TRUE. : the full Schur form T is required;
  53. *> = .FALSE.: only eigenvalues are required.
  54. *> \endverbatim
  55. *>
  56. *> \param[in] WANTZ
  57. *> \verbatim
  58. *> WANTZ is LOGICAL
  59. *> = .TRUE. : the matrix of Schur vectors Z is required;
  60. *> = .FALSE.: Schur vectors are not required.
  61. *> \endverbatim
  62. *>
  63. *> \param[in] N
  64. *> \verbatim
  65. *> N is INTEGER
  66. *> The order of the matrix H. N >= 0.
  67. *> \endverbatim
  68. *>
  69. *> \param[in] ILO
  70. *> \verbatim
  71. *> ILO is INTEGER
  72. *> \endverbatim
  73. *>
  74. *> \param[in] IHI
  75. *> \verbatim
  76. *> IHI is INTEGER
  77. *> It is assumed that H is already upper quasi-triangular in
  78. *> rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
  79. *> ILO = 1). DLAHQR works primarily with the Hessenberg
  80. *> submatrix in rows and columns ILO to IHI, but applies
  81. *> transformations to all of H if WANTT is .TRUE..
  82. *> 1 <= ILO <= max(1,IHI); IHI <= N.
  83. *> \endverbatim
  84. *>
  85. *> \param[in,out] H
  86. *> \verbatim
  87. *> H is DOUBLE PRECISION array, dimension (LDH,N)
  88. *> On entry, the upper Hessenberg matrix H.
  89. *> On exit, if INFO is zero and if WANTT is .TRUE., H is upper
  90. *> quasi-triangular in rows and columns ILO:IHI, with any
  91. *> 2-by-2 diagonal blocks in standard form. If INFO is zero
  92. *> and WANTT is .FALSE., the contents of H are unspecified on
  93. *> exit. The output state of H if INFO is nonzero is given
  94. *> below under the description of INFO.
  95. *> \endverbatim
  96. *>
  97. *> \param[in] LDH
  98. *> \verbatim
  99. *> LDH is INTEGER
  100. *> The leading dimension of the array H. LDH >= max(1,N).
  101. *> \endverbatim
  102. *>
  103. *> \param[out] WR
  104. *> \verbatim
  105. *> WR is DOUBLE PRECISION array, dimension (N)
  106. *> \endverbatim
  107. *>
  108. *> \param[out] WI
  109. *> \verbatim
  110. *> WI is DOUBLE PRECISION array, dimension (N)
  111. *> The real and imaginary parts, respectively, of the computed
  112. *> eigenvalues ILO to IHI are stored in the corresponding
  113. *> elements of WR and WI. If two eigenvalues are computed as a
  114. *> complex conjugate pair, they are stored in consecutive
  115. *> elements of WR and WI, say the i-th and (i+1)th, with
  116. *> WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
  117. *> eigenvalues are stored in the same order as on the diagonal
  118. *> of the Schur form returned in H, with WR(i) = H(i,i), and, if
  119. *> H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
  120. *> WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
  121. *> \endverbatim
  122. *>
  123. *> \param[in] ILOZ
  124. *> \verbatim
  125. *> ILOZ is INTEGER
  126. *> \endverbatim
  127. *>
  128. *> \param[in] IHIZ
  129. *> \verbatim
  130. *> IHIZ is INTEGER
  131. *> Specify the rows of Z to which transformations must be
  132. *> applied if WANTZ is .TRUE..
  133. *> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
  134. *> \endverbatim
  135. *>
  136. *> \param[in,out] Z
  137. *> \verbatim
  138. *> Z is DOUBLE PRECISION array, dimension (LDZ,N)
  139. *> If WANTZ is .TRUE., on entry Z must contain the current
  140. *> matrix Z of transformations accumulated by DHSEQR, and on
  141. *> exit Z has been updated; transformations are applied only to
  142. *> the submatrix Z(ILOZ:IHIZ,ILO:IHI).
  143. *> If WANTZ is .FALSE., Z is not referenced.
  144. *> \endverbatim
  145. *>
  146. *> \param[in] LDZ
  147. *> \verbatim
  148. *> LDZ is INTEGER
  149. *> The leading dimension of the array Z. LDZ >= max(1,N).
  150. *> \endverbatim
  151. *>
  152. *> \param[out] INFO
  153. *> \verbatim
  154. *> INFO is INTEGER
  155. *> = 0: successful exit
  156. *> .GT. 0: If INFO = i, DLAHQR failed to compute all the
  157. *> eigenvalues ILO to IHI in a total of 30 iterations
  158. *> per eigenvalue; elements i+1:ihi of WR and WI
  159. *> contain those eigenvalues which have been
  160. *> successfully computed.
  161. *>
  162. *> If INFO .GT. 0 and WANTT is .FALSE., then on exit,
  163. *> the remaining unconverged eigenvalues are the
  164. *> eigenvalues of the upper Hessenberg matrix rows
  165. *> and columns ILO thorugh INFO of the final, output
  166. *> value of H.
  167. *>
  168. *> If INFO .GT. 0 and WANTT is .TRUE., then on exit
  169. *> (*) (initial value of H)*U = U*(final value of H)
  170. *> where U is an orthognal matrix. The final
  171. *> value of H is upper Hessenberg and triangular in
  172. *> rows and columns INFO+1 through IHI.
  173. *>
  174. *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit
  175. *> (final value of Z) = (initial value of Z)*U
  176. *> where U is the orthogonal matrix in (*)
  177. *> (regardless of the value of WANTT.)
  178. *> \endverbatim
  179. *
  180. * Authors:
  181. * ========
  182. *
  183. *> \author Univ. of Tennessee
  184. *> \author Univ. of California Berkeley
  185. *> \author Univ. of Colorado Denver
  186. *> \author NAG Ltd.
  187. *
  188. *> \date December 2016
  189. *
  190. *> \ingroup doubleOTHERauxiliary
  191. *
  192. *> \par Further Details:
  193. * =====================
  194. *>
  195. *> \verbatim
  196. *>
  197. *> 02-96 Based on modifications by
  198. *> David Day, Sandia National Laboratory, USA
  199. *>
  200. *> 12-04 Further modifications by
  201. *> Ralph Byers, University of Kansas, USA
  202. *> This is a modified version of DLAHQR from LAPACK version 3.0.
  203. *> It is (1) more robust against overflow and underflow and
  204. *> (2) adopts the more conservative Ahues & Tisseur stopping
  205. *> criterion (LAWN 122, 1997).
  206. *> \endverbatim
  207. *>
  208. * =====================================================================
  209. SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
  210. $ ILOZ, IHIZ, Z, LDZ, INFO )
  211. *
  212. * -- LAPACK auxiliary routine (version 3.7.0) --
  213. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  214. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  215. * December 2016
  216. *
  217. * .. Scalar Arguments ..
  218. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
  219. LOGICAL WANTT, WANTZ
  220. * ..
  221. * .. Array Arguments ..
  222. REAL*8 H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
  223. * ..
  224. *
  225. * =========================================================
  226. *
  227. * .. Parameters ..
  228. REAL*8 ZERO, ONE, TWO
  229. PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0d0 )
  230. REAL*8 DAT1, DAT2
  231. PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 )
  232. * ..
  233. * .. Local Scalars ..
  234. REAL*8 AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S,
  235. $ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX,
  236. $ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST,
  237. $ ULP, V2, V3
  238. INTEGER I, I1, I2, ITS, ITMAX, J, K, L, M, NH, NR, NZ
  239. * ..
  240. * .. Local Arrays ..
  241. REAL*8 V( 3 )
  242. * ..
  243. * .. External Functions ..
  244. REAL*8 DLAMCH
  245. EXTERNAL DLAMCH
  246. * ..
  247. * .. External Subroutines ..
  248. EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG,
  249. & DROT
  250. * ..
  251. ** .. Intrinsic Functions ..
  252. * INTRINSIC ABS, DBLE, MAX, MIN, SQRT
  253. ** ..
  254. ** .. Executable Statements ..
  255. *
  256. INFO = 0
  257. *
  258. * Quick return if possible
  259. *
  260. IF( N.EQ.0 )
  261. $ RETURN
  262. IF( ILO.EQ.IHI ) THEN
  263. WR( ILO ) = H( ILO, ILO )
  264. WI( ILO ) = ZERO
  265. RETURN
  266. END IF
  267. *
  268. * ==== clear out the trash ====
  269. DO 10 J = ILO, IHI - 3
  270. H( J+2, J ) = ZERO
  271. H( J+3, J ) = ZERO
  272. 10 CONTINUE
  273. IF( ILO.LE.IHI-2 )
  274. $ H( IHI, IHI-2 ) = ZERO
  275. *
  276. NH = IHI - ILO + 1
  277. NZ = IHIZ - ILOZ + 1
  278. *
  279. * Set machine-dependent constants for the stopping criterion.
  280. *
  281. SAFMIN = DLAMCH( 'SAFE MINIMUM' )
  282. SAFMAX = ONE / SAFMIN
  283. CALL DLABAD( SAFMIN, SAFMAX )
  284. ULP = DLAMCH( 'PRECISION' )
  285. SMLNUM = SAFMIN*( DBLE( NH ) / ULP )
  286. *
  287. * I1 and I2 are the indices of the first row and last column of H
  288. * to which transformations must be applied. If eigenvalues only are
  289. * being computed, I1 and I2 are set inside the main loop.
  290. *
  291. IF( WANTT ) THEN
  292. I1 = 1
  293. I2 = N
  294. END IF
  295. *
  296. * ITMAX is the total number of QR iterations allowed.
  297. *
  298. ITMAX = 30 * MAX( 10, NH )
  299. *
  300. * The main loop begins here. I is the loop index and decreases from
  301. * IHI to ILO in steps of 1 or 2. Each iteration of the loop works
  302. * with the active submatrix in rows and columns L to I.
  303. * Eigenvalues I+1 to IHI have already converged. Either L = ILO or
  304. * H(L,L-1) is negligible so that the matrix splits.
  305. *
  306. I = IHI
  307. 20 CONTINUE
  308. L = ILO
  309. IF( I.LT.ILO )
  310. $ GO TO 160
  311. *
  312. * Perform QR iterations on rows and columns ILO to I until a
  313. * submatrix of order 1 or 2 splits off at the bottom because a
  314. * subdiagonal element has become negligible.
  315. *
  316. DO 140 ITS = 0, ITMAX
  317. *
  318. * Look for a single small subdiagonal element.
  319. *
  320. DO 30 K = I, L + 1, -1
  321. IF( ABS( H( K, K-1 ) ).LE.SMLNUM )
  322. $ GO TO 40
  323. TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
  324. IF( TST.EQ.ZERO ) THEN
  325. IF( K-2.GE.ILO )
  326. $ TST = TST + ABS( H( K-1, K-2 ) )
  327. IF( K+1.LE.IHI )
  328. $ TST = TST + ABS( H( K+1, K ) )
  329. END IF
  330. * ==== The following is a conservative small subdiagonal
  331. * . deflation criterion due to Ahues & Tisseur (LAWN 122,
  332. * . 1997). It has better mathematical foundation and
  333. * . improves accuracy in some cases. ====
  334. IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN
  335. AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
  336. BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
  337. AA = MAX( ABS( H( K, K ) ),
  338. $ ABS( H( K-1, K-1 )-H( K, K ) ) )
  339. BB = MIN( ABS( H( K, K ) ),
  340. $ ABS( H( K-1, K-1 )-H( K, K ) ) )
  341. S = AA + AB
  342. IF( BA*( AB / S ).LE.MAX( SMLNUM,
  343. $ ULP*( BB*( AA / S ) ) ) )GO TO 40
  344. END IF
  345. 30 CONTINUE
  346. 40 CONTINUE
  347. L = K
  348. IF( L.GT.ILO ) THEN
  349. *
  350. * H(L,L-1) is negligible
  351. *
  352. H( L, L-1 ) = ZERO
  353. END IF
  354. *
  355. * Exit from loop if a submatrix of order 1 or 2 has split off.
  356. *
  357. IF( L.GE.I-1 )
  358. $ GO TO 150
  359. *
  360. * Now the active submatrix is in rows and columns L to I. If
  361. * eigenvalues only are being computed, only the active submatrix
  362. * need be transformed.
  363. *
  364. IF( .NOT.WANTT ) THEN
  365. I1 = L
  366. I2 = I
  367. END IF
  368. *
  369. IF( ITS.EQ.10 ) THEN
  370. *
  371. * Exceptional shift.
  372. *
  373. S = ABS( H( L+1, L ) ) + ABS( H( L+2, L+1 ) )
  374. H11 = DAT1*S + H( L, L )
  375. H12 = DAT2*S
  376. H21 = S
  377. H22 = H11
  378. ELSE IF( ITS.EQ.20 ) THEN
  379. *
  380. * Exceptional shift.
  381. *
  382. S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
  383. H11 = DAT1*S + H( I, I )
  384. H12 = DAT2*S
  385. H21 = S
  386. H22 = H11
  387. ELSE
  388. *
  389. * Prepare to use Francis' double shift
  390. * (i.e. 2nd degree generalized Rayleigh quotient)
  391. *
  392. H11 = H( I-1, I-1 )
  393. H21 = H( I, I-1 )
  394. H12 = H( I-1, I )
  395. H22 = H( I, I )
  396. END IF
  397. S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 )
  398. IF( S.EQ.ZERO ) THEN
  399. RT1R = ZERO
  400. RT1I = ZERO
  401. RT2R = ZERO
  402. RT2I = ZERO
  403. ELSE
  404. H11 = H11 / S
  405. H21 = H21 / S
  406. H12 = H12 / S
  407. H22 = H22 / S
  408. TR = ( H11+H22 ) / TWO
  409. DET = ( H11-TR )*( H22-TR ) - H12*H21
  410. RTDISC = SQRT( ABS( DET ) )
  411. IF( DET.GE.ZERO ) THEN
  412. *
  413. * ==== complex conjugate shifts ====
  414. *
  415. RT1R = TR*S
  416. RT2R = RT1R
  417. RT1I = RTDISC*S
  418. RT2I = -RT1I
  419. ELSE
  420. *
  421. * ==== real shifts (use only one of them) ====
  422. *
  423. RT1R = TR + RTDISC
  424. RT2R = TR - RTDISC
  425. IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN
  426. RT1R = RT1R*S
  427. RT2R = RT1R
  428. ELSE
  429. RT2R = RT2R*S
  430. RT1R = RT2R
  431. END IF
  432. RT1I = ZERO
  433. RT2I = ZERO
  434. END IF
  435. END IF
  436. *
  437. * Look for two consecutive small subdiagonal elements.
  438. *
  439. DO 50 M = I - 2, L, -1
  440. * Determine the effect of starting the double-shift QR
  441. * iteration at row M, and see if this would make H(M,M-1)
  442. * negligible. (The following uses scaling to avoid
  443. * overflows and most underflows.)
  444. *
  445. H21S = H( M+1, M )
  446. S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S )
  447. H21S = H( M+1, M ) / S
  448. V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )*
  449. $ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S )
  450. V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R )
  451. V( 3 ) = H21S*H( M+2, M+1 )
  452. S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) )
  453. V( 1 ) = V( 1 ) / S
  454. V( 2 ) = V( 2 ) / S
  455. V( 3 ) = V( 3 ) / S
  456. IF( M.EQ.L )
  457. $ GO TO 60
  458. IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE.
  459. $ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M,
  460. $ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60
  461. 50 CONTINUE
  462. 60 CONTINUE
  463. *
  464. * Double-shift QR step
  465. *
  466. DO 130 K = M, I - 1
  467. *
  468. * The first iteration of this loop determines a reflection G
  469. * from the vector V and applies it from left and right to H,
  470. * thus creating a nonzero bulge below the subdiagonal.
  471. *
  472. * Each subsequent iteration determines a reflection G to
  473. * restore the Hessenberg form in the (K-1)th column, and thus
  474. * chases the bulge one step toward the bottom of the active
  475. * submatrix. NR is the order of G.
  476. *
  477. NR = MIN( 3, I-K+1 )
  478. IF( K.GT.M )
  479. $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 )
  480. CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 )
  481. IF( K.GT.M ) THEN
  482. H( K, K-1 ) = V( 1 )
  483. H( K+1, K-1 ) = ZERO
  484. IF( K.LT.I-1 )
  485. $ H( K+2, K-1 ) = ZERO
  486. ELSE IF( M.GT.L ) THEN
  487. * ==== Use the following instead of
  488. * . H( K, K-1 ) = -H( K, K-1 ) to
  489. * . avoid a bug when v(2) and v(3)
  490. * . underflow. ====
  491. H( K, K-1 ) = H( K, K-1 )*( ONE-T1 )
  492. END IF
  493. V2 = V( 2 )
  494. T2 = T1*V2
  495. IF( NR.EQ.3 ) THEN
  496. V3 = V( 3 )
  497. T3 = T1*V3
  498. *
  499. * Apply G from the left to transform the rows of the matrix
  500. * in columns K to I2.
  501. *
  502. DO 70 J = K, I2
  503. SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
  504. H( K, J ) = H( K, J ) - SUM*T1
  505. H( K+1, J ) = H( K+1, J ) - SUM*T2
  506. H( K+2, J ) = H( K+2, J ) - SUM*T3
  507. 70 CONTINUE
  508. *
  509. * Apply G from the right to transform the columns of the
  510. * matrix in rows I1 to min(K+3,I).
  511. *
  512. DO 80 J = I1, MIN( K+3, I )
  513. SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
  514. H( J, K ) = H( J, K ) - SUM*T1
  515. H( J, K+1 ) = H( J, K+1 ) - SUM*T2
  516. H( J, K+2 ) = H( J, K+2 ) - SUM*T3
  517. 80 CONTINUE
  518. *
  519. IF( WANTZ ) THEN
  520. *
  521. * Accumulate transformations in the matrix Z
  522. *
  523. DO 90 J = ILOZ, IHIZ
  524. SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
  525. Z( J, K ) = Z( J, K ) - SUM*T1
  526. Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
  527. Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
  528. 90 CONTINUE
  529. END IF
  530. ELSE IF( NR.EQ.2 ) THEN
  531. *
  532. * Apply G from the left to transform the rows of the matrix
  533. * in columns K to I2.
  534. *
  535. DO 100 J = K, I2
  536. SUM = H( K, J ) + V2*H( K+1, J )
  537. H( K, J ) = H( K, J ) - SUM*T1
  538. H( K+1, J ) = H( K+1, J ) - SUM*T2
  539. 100 CONTINUE
  540. *
  541. * Apply G from the right to transform the columns of the
  542. * matrix in rows I1 to min(K+3,I).
  543. *
  544. DO 110 J = I1, I
  545. SUM = H( J, K ) + V2*H( J, K+1 )
  546. H( J, K ) = H( J, K ) - SUM*T1
  547. H( J, K+1 ) = H( J, K+1 ) - SUM*T2
  548. 110 CONTINUE
  549. *
  550. IF( WANTZ ) THEN
  551. *
  552. * Accumulate transformations in the matrix Z
  553. *
  554. DO 120 J = ILOZ, IHIZ
  555. SUM = Z( J, K ) + V2*Z( J, K+1 )
  556. Z( J, K ) = Z( J, K ) - SUM*T1
  557. Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
  558. 120 CONTINUE
  559. END IF
  560. END IF
  561. 130 CONTINUE
  562. *
  563. 140 CONTINUE
  564. *
  565. * Failure to converge in remaining number of iterations
  566. *
  567. INFO = I
  568. RETURN
  569. *
  570. 150 CONTINUE
  571. *
  572. IF( L.EQ.I ) THEN
  573. *
  574. * H(I,I-1) is negligible: one eigenvalue has converged.
  575. *
  576. WR( I ) = H( I, I )
  577. WI( I ) = ZERO
  578. ELSE IF( L.EQ.I-1 ) THEN
  579. *
  580. * H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
  581. *
  582. * Transform the 2-by-2 submatrix to standard Schur form,
  583. * and compute and store the eigenvalues.
  584. *
  585. CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ),
  586. $ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ),
  587. $ CS, SN )
  588. *
  589. IF( WANTT ) THEN
  590. *
  591. * Apply the transformation to the rest of H.
  592. *
  593. IF( I2.GT.I )
  594. $ CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
  595. $ CS, SN )
  596. CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
  597. END IF
  598. IF( WANTZ ) THEN
  599. *
  600. * Apply the transformation to Z.
  601. *
  602. CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
  603. END IF
  604. END IF
  605. *
  606. * return to start of the main loop with new value of I.
  607. *
  608. I = L - 1
  609. GO TO 20
  610. *
  611. 160 CONTINUE
  612. RETURN
  613. *
  614. * End of DLAHQR
  615. *
  616. END
  617.  
  618.  
  619.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales