PageRenderTime 48ms CodeModel.GetById 21ms RepoModel.GetById 0ms app.codeStats 0ms

/TESTING/EIG/ddrgvx.f

https://bitbucket.org/iricpt/lapack
FORTRAN Legacy | 759 lines | 295 code | 0 blank | 464 comment | 0 complexity | a3dcbf9e4ddddb0f61b92521813c8bee MD5 | raw file
Possible License(s): BSD-3-Clause
  1. *> \brief \b DDRGVX
  2. *
  3. * =========== DOCUMENTATION ===========
  4. *
  5. * Online html documentation available at
  6. * http://www.netlib.org/lapack/explore-html/
  7. *
  8. * Definition:
  9. * ===========
  10. *
  11. * SUBROUTINE DDRGVX( NSIZE, THRESH, NIN, NOUT, A, LDA, B, AI, BI,
  12. * ALPHAR, ALPHAI, BETA, VL, VR, ILO, IHI, LSCALE,
  13. * RSCALE, S, DTRU, DIF, DIFTRU, WORK, LWORK,
  14. * IWORK, LIWORK, RESULT, BWORK, INFO )
  15. *
  16. * .. Scalar Arguments ..
  17. * INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT,
  18. * $ NSIZE
  19. * DOUBLE PRECISION THRESH
  20. * ..
  21. * .. Array Arguments ..
  22. * LOGICAL BWORK( * )
  23. * INTEGER IWORK( * )
  24. * DOUBLE PRECISION A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
  25. * $ ALPHAR( * ), B( LDA, * ), BETA( * ),
  26. * $ BI( LDA, * ), DIF( * ), DIFTRU( * ), DTRU( * ),
  27. * $ LSCALE( * ), RESULT( 4 ), RSCALE( * ), S( * ),
  28. * $ VL( LDA, * ), VR( LDA, * ), WORK( * )
  29. * ..
  30. *
  31. *
  32. *> \par Purpose:
  33. * =============
  34. *>
  35. *> \verbatim
  36. *>
  37. *> DDRGVX checks the nonsymmetric generalized eigenvalue problem
  38. *> expert driver DGGEVX.
  39. *>
  40. *> DGGEVX computes the generalized eigenvalues, (optionally) the left
  41. *> and/or right eigenvectors, (optionally) computes a balancing
  42. *> transformation to improve the conditioning, and (optionally)
  43. *> reciprocal condition numbers for the eigenvalues and eigenvectors.
  44. *>
  45. *> When DDRGVX is called with NSIZE > 0, two types of test matrix pairs
  46. *> are generated by the subroutine DLATM6 and test the driver DGGEVX.
  47. *> The test matrices have the known exact condition numbers for
  48. *> eigenvalues. For the condition numbers of the eigenvectors
  49. *> corresponding the first and last eigenvalues are also know
  50. *> ``exactly'' (see DLATM6).
  51. *>
  52. *> For each matrix pair, the following tests will be performed and
  53. *> compared with the threshold THRESH.
  54. *>
  55. *> (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
  56. *>
  57. *> | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
  58. *>
  59. *> where l**H is the conjugate tranpose of l.
  60. *>
  61. *> (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
  62. *>
  63. *> | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
  64. *>
  65. *> (3) The condition number S(i) of eigenvalues computed by DGGEVX
  66. *> differs less than a factor THRESH from the exact S(i) (see
  67. *> DLATM6).
  68. *>
  69. *> (4) DIF(i) computed by DTGSNA differs less than a factor 10*THRESH
  70. *> from the exact value (for the 1st and 5th vectors only).
  71. *>
  72. *> Test Matrices
  73. *> =============
  74. *>
  75. *> Two kinds of test matrix pairs
  76. *>
  77. *> (A, B) = inverse(YH) * (Da, Db) * inverse(X)
  78. *>
  79. *> are used in the tests:
  80. *>
  81. *> 1: Da = 1+a 0 0 0 0 Db = 1 0 0 0 0
  82. *> 0 2+a 0 0 0 0 1 0 0 0
  83. *> 0 0 3+a 0 0 0 0 1 0 0
  84. *> 0 0 0 4+a 0 0 0 0 1 0
  85. *> 0 0 0 0 5+a , 0 0 0 0 1 , and
  86. *>
  87. *> 2: Da = 1 -1 0 0 0 Db = 1 0 0 0 0
  88. *> 1 1 0 0 0 0 1 0 0 0
  89. *> 0 0 1 0 0 0 0 1 0 0
  90. *> 0 0 0 1+a 1+b 0 0 0 1 0
  91. *> 0 0 0 -1-b 1+a , 0 0 0 0 1 .
  92. *>
  93. *> In both cases the same inverse(YH) and inverse(X) are used to compute
  94. *> (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
  95. *>
  96. *> YH: = 1 0 -y y -y X = 1 0 -x -x x
  97. *> 0 1 -y y -y 0 1 x -x -x
  98. *> 0 0 1 0 0 0 0 1 0 0
  99. *> 0 0 0 1 0 0 0 0 1 0
  100. *> 0 0 0 0 1, 0 0 0 0 1 , where
  101. *>
  102. *> a, b, x and y will have all values independently of each other from
  103. *> { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }.
  104. *> \endverbatim
  105. *
  106. * Arguments:
  107. * ==========
  108. *
  109. *> \param[in] NSIZE
  110. *> \verbatim
  111. *> NSIZE is INTEGER
  112. *> The number of sizes of matrices to use. NSIZE must be at
  113. *> least zero. If it is zero, no randomly generated matrices
  114. *> are tested, but any test matrices read from NIN will be
  115. *> tested.
  116. *> \endverbatim
  117. *>
  118. *> \param[in] THRESH
  119. *> \verbatim
  120. *> THRESH is DOUBLE PRECISION
  121. *> A test will count as "failed" if the "error", computed as
  122. *> described above, exceeds THRESH. Note that the error
  123. *> is scaled to be O(1), so THRESH should be a reasonably
  124. *> small multiple of 1, e.g., 10 or 100. In particular,
  125. *> it should not depend on the precision (single vs. double)
  126. *> or the size of the matrix. It must be at least zero.
  127. *> \endverbatim
  128. *>
  129. *> \param[in] NIN
  130. *> \verbatim
  131. *> NIN is INTEGER
  132. *> The FORTRAN unit number for reading in the data file of
  133. *> problems to solve.
  134. *> \endverbatim
  135. *>
  136. *> \param[in] NOUT
  137. *> \verbatim
  138. *> NOUT is INTEGER
  139. *> The FORTRAN unit number for printing out error messages
  140. *> (e.g., if a routine returns IINFO not equal to 0.)
  141. *> \endverbatim
  142. *>
  143. *> \param[out] A
  144. *> \verbatim
  145. *> A is DOUBLE PRECISION array, dimension (LDA, NSIZE)
  146. *> Used to hold the matrix whose eigenvalues are to be
  147. *> computed. On exit, A contains the last matrix actually used.
  148. *> \endverbatim
  149. *>
  150. *> \param[in] LDA
  151. *> \verbatim
  152. *> LDA is INTEGER
  153. *> The leading dimension of A, B, AI, BI, Ao, and Bo.
  154. *> It must be at least 1 and at least NSIZE.
  155. *> \endverbatim
  156. *>
  157. *> \param[out] B
  158. *> \verbatim
  159. *> B is DOUBLE PRECISION array, dimension (LDA, NSIZE)
  160. *> Used to hold the matrix whose eigenvalues are to be
  161. *> computed. On exit, B contains the last matrix actually used.
  162. *> \endverbatim
  163. *>
  164. *> \param[out] AI
  165. *> \verbatim
  166. *> AI is DOUBLE PRECISION array, dimension (LDA, NSIZE)
  167. *> Copy of A, modified by DGGEVX.
  168. *> \endverbatim
  169. *>
  170. *> \param[out] BI
  171. *> \verbatim
  172. *> BI is DOUBLE PRECISION array, dimension (LDA, NSIZE)
  173. *> Copy of B, modified by DGGEVX.
  174. *> \endverbatim
  175. *>
  176. *> \param[out] ALPHAR
  177. *> \verbatim
  178. *> ALPHAR is DOUBLE PRECISION array, dimension (NSIZE)
  179. *> \endverbatim
  180. *>
  181. *> \param[out] ALPHAI
  182. *> \verbatim
  183. *> ALPHAI is DOUBLE PRECISION array, dimension (NSIZE)
  184. *> \endverbatim
  185. *>
  186. *> \param[out] BETA
  187. *> \verbatim
  188. *> BETA is DOUBLE PRECISION array, dimension (NSIZE)
  189. *>
  190. *> On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
  191. *> \endverbatim
  192. *>
  193. *> \param[out] VL
  194. *> \verbatim
  195. *> VL is DOUBLE PRECISION array, dimension (LDA, NSIZE)
  196. *> VL holds the left eigenvectors computed by DGGEVX.
  197. *> \endverbatim
  198. *>
  199. *> \param[out] VR
  200. *> \verbatim
  201. *> VR is DOUBLE PRECISION array, dimension (LDA, NSIZE)
  202. *> VR holds the right eigenvectors computed by DGGEVX.
  203. *> \endverbatim
  204. *>
  205. *> \param[out] ILO
  206. *> \verbatim
  207. *> ILO is INTEGER
  208. *> \endverbatim
  209. *>
  210. *> \param[out] IHI
  211. *> \verbatim
  212. *> IHI is INTEGER
  213. *> \endverbatim
  214. *>
  215. *> \param[out] LSCALE
  216. *> \verbatim
  217. *> LSCALE is DOUBLE PRECISION array, dimension (N)
  218. *> \endverbatim
  219. *>
  220. *> \param[out] RSCALE
  221. *> \verbatim
  222. *> RSCALE is DOUBLE PRECISION array, dimension (N)
  223. *> \endverbatim
  224. *>
  225. *> \param[out] S
  226. *> \verbatim
  227. *> S is DOUBLE PRECISION array, dimension (N)
  228. *> \endverbatim
  229. *>
  230. *> \param[out] DTRU
  231. *> \verbatim
  232. *> DTRU is DOUBLE PRECISION array, dimension (N)
  233. *> \endverbatim
  234. *>
  235. *> \param[out] DIF
  236. *> \verbatim
  237. *> DIF is DOUBLE PRECISION array, dimension (N)
  238. *> \endverbatim
  239. *>
  240. *> \param[out] DIFTRU
  241. *> \verbatim
  242. *> DIFTRU is DOUBLE PRECISION array, dimension (N)
  243. *> \endverbatim
  244. *>
  245. *> \param[out] WORK
  246. *> \verbatim
  247. *> WORK is DOUBLE PRECISION array, dimension (LWORK)
  248. *> \endverbatim
  249. *>
  250. *> \param[in] LWORK
  251. *> \verbatim
  252. *> LWORK is INTEGER
  253. *> Leading dimension of WORK. LWORK >= 2*N*N+12*N+16.
  254. *> \endverbatim
  255. *>
  256. *> \param[out] IWORK
  257. *> \verbatim
  258. *> IWORK is INTEGER array, dimension (LIWORK)
  259. *> \endverbatim
  260. *>
  261. *> \param[in] LIWORK
  262. *> \verbatim
  263. *> LIWORK is INTEGER
  264. *> Leading dimension of IWORK. Must be at least N+6.
  265. *> \endverbatim
  266. *>
  267. *> \param[out] RESULT
  268. *> \verbatim
  269. *> RESULT is DOUBLE PRECISION array, dimension (4)
  270. *> \endverbatim
  271. *>
  272. *> \param[out] BWORK
  273. *> \verbatim
  274. *> BWORK is LOGICAL array, dimension (N)
  275. *> \endverbatim
  276. *>
  277. *> \param[out] INFO
  278. *> \verbatim
  279. *> INFO is INTEGER
  280. *> = 0: successful exit
  281. *> < 0: if INFO = -i, the i-th argument had an illegal value.
  282. *> > 0: A routine returned an error code.
  283. *> \endverbatim
  284. *
  285. * Authors:
  286. * ========
  287. *
  288. *> \author Univ. of Tennessee
  289. *> \author Univ. of California Berkeley
  290. *> \author Univ. of Colorado Denver
  291. *> \author NAG Ltd.
  292. *
  293. *> \ingroup double_eig
  294. *
  295. * =====================================================================
  296. SUBROUTINE DDRGVX( NSIZE, THRESH, NIN, NOUT, A, LDA, B, AI, BI,
  297. $ ALPHAR, ALPHAI, BETA, VL, VR, ILO, IHI, LSCALE,
  298. $ RSCALE, S, DTRU, DIF, DIFTRU, WORK, LWORK,
  299. $ IWORK, LIWORK, RESULT, BWORK, INFO )
  300. *
  301. * -- LAPACK test routine --
  302. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  303. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  304. *
  305. * .. Scalar Arguments ..
  306. INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT,
  307. $ NSIZE
  308. DOUBLE PRECISION THRESH
  309. * ..
  310. * .. Array Arguments ..
  311. LOGICAL BWORK( * )
  312. INTEGER IWORK( * )
  313. DOUBLE PRECISION A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
  314. $ ALPHAR( * ), B( LDA, * ), BETA( * ),
  315. $ BI( LDA, * ), DIF( * ), DIFTRU( * ), DTRU( * ),
  316. $ LSCALE( * ), RESULT( 4 ), RSCALE( * ), S( * ),
  317. $ VL( LDA, * ), VR( LDA, * ), WORK( * )
  318. * ..
  319. *
  320. * =====================================================================
  321. *
  322. * .. Parameters ..
  323. DOUBLE PRECISION ZERO, ONE, TEN, TNTH, HALF
  324. PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
  325. $ TNTH = 1.0D-1, HALF = 0.5D+0 )
  326. * ..
  327. * .. Local Scalars ..
  328. INTEGER I, IPTYPE, IWA, IWB, IWX, IWY, J, LINFO,
  329. $ MAXWRK, MINWRK, N, NERRS, NMAX, NPTKNT, NTESTT
  330. DOUBLE PRECISION ABNORM, ANORM, BNORM, RATIO1, RATIO2, THRSH2,
  331. $ ULP, ULPINV
  332. * ..
  333. * .. Local Arrays ..
  334. DOUBLE PRECISION WEIGHT( 5 )
  335. * ..
  336. * .. External Functions ..
  337. INTEGER ILAENV
  338. DOUBLE PRECISION DLAMCH, DLANGE
  339. EXTERNAL ILAENV, DLAMCH, DLANGE
  340. * ..
  341. * .. External Subroutines ..
  342. EXTERNAL ALASVM, DGET52, DGGEVX, DLACPY, DLATM6, XERBLA
  343. * ..
  344. * .. Intrinsic Functions ..
  345. INTRINSIC ABS, MAX, SQRT
  346. * ..
  347. * .. Executable Statements ..
  348. *
  349. * Check for errors
  350. *
  351. INFO = 0
  352. *
  353. NMAX = 5
  354. *
  355. IF( NSIZE.LT.0 ) THEN
  356. INFO = -1
  357. ELSE IF( THRESH.LT.ZERO ) THEN
  358. INFO = -2
  359. ELSE IF( NIN.LE.0 ) THEN
  360. INFO = -3
  361. ELSE IF( NOUT.LE.0 ) THEN
  362. INFO = -4
  363. ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
  364. INFO = -6
  365. ELSE IF( LIWORK.LT.NMAX+6 ) THEN
  366. INFO = -26
  367. END IF
  368. *
  369. * Compute workspace
  370. * (Note: Comments in the code beginning "Workspace:" describe the
  371. * minimal amount of workspace needed at that point in the code,
  372. * as well as the preferred amount for good performance.
  373. * NB refers to the optimal block size for the immediately
  374. * following subroutine, as returned by ILAENV.)
  375. *
  376. MINWRK = 1
  377. IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
  378. MINWRK = 2*NMAX*NMAX + 12*NMAX + 16
  379. MAXWRK = 6*NMAX + NMAX*ILAENV( 1, 'DGEQRF', ' ', NMAX, 1, NMAX,
  380. $ 0 )
  381. MAXWRK = MAX( MAXWRK, 2*NMAX*NMAX+12*NMAX+16 )
  382. WORK( 1 ) = MAXWRK
  383. END IF
  384. *
  385. IF( LWORK.LT.MINWRK )
  386. $ INFO = -24
  387. *
  388. IF( INFO.NE.0 ) THEN
  389. CALL XERBLA( 'DDRGVX', -INFO )
  390. RETURN
  391. END IF
  392. *
  393. N = 5
  394. ULP = DLAMCH( 'P' )
  395. ULPINV = ONE / ULP
  396. THRSH2 = TEN*THRESH
  397. NERRS = 0
  398. NPTKNT = 0
  399. NTESTT = 0
  400. *
  401. IF( NSIZE.EQ.0 )
  402. $ GO TO 90
  403. *
  404. * Parameters used for generating test matrices.
  405. *
  406. WEIGHT( 1 ) = TNTH
  407. WEIGHT( 2 ) = HALF
  408. WEIGHT( 3 ) = ONE
  409. WEIGHT( 4 ) = ONE / WEIGHT( 2 )
  410. WEIGHT( 5 ) = ONE / WEIGHT( 1 )
  411. *
  412. DO 80 IPTYPE = 1, 2
  413. DO 70 IWA = 1, 5
  414. DO 60 IWB = 1, 5
  415. DO 50 IWX = 1, 5
  416. DO 40 IWY = 1, 5
  417. *
  418. * generated a test matrix pair
  419. *
  420. CALL DLATM6( IPTYPE, 5, A, LDA, B, VR, LDA, VL,
  421. $ LDA, WEIGHT( IWA ), WEIGHT( IWB ),
  422. $ WEIGHT( IWX ), WEIGHT( IWY ), DTRU,
  423. $ DIFTRU )
  424. *
  425. * Compute eigenvalues/eigenvectors of (A, B).
  426. * Compute eigenvalue/eigenvector condition numbers
  427. * using computed eigenvectors.
  428. *
  429. CALL DLACPY( 'F', N, N, A, LDA, AI, LDA )
  430. CALL DLACPY( 'F', N, N, B, LDA, BI, LDA )
  431. *
  432. CALL DGGEVX( 'N', 'V', 'V', 'B', N, AI, LDA, BI,
  433. $ LDA, ALPHAR, ALPHAI, BETA, VL, LDA,
  434. $ VR, LDA, ILO, IHI, LSCALE, RSCALE,
  435. $ ANORM, BNORM, S, DIF, WORK, LWORK,
  436. $ IWORK, BWORK, LINFO )
  437. IF( LINFO.NE.0 ) THEN
  438. RESULT( 1 ) = ULPINV
  439. WRITE( NOUT, FMT = 9999 )'DGGEVX', LINFO, N,
  440. $ IPTYPE
  441. GO TO 30
  442. END IF
  443. *
  444. * Compute the norm(A, B)
  445. *
  446. CALL DLACPY( 'Full', N, N, AI, LDA, WORK, N )
  447. CALL DLACPY( 'Full', N, N, BI, LDA, WORK( N*N+1 ),
  448. $ N )
  449. ABNORM = DLANGE( 'Fro', N, 2*N, WORK, N, WORK )
  450. *
  451. * Tests (1) and (2)
  452. *
  453. RESULT( 1 ) = ZERO
  454. CALL DGET52( .TRUE., N, A, LDA, B, LDA, VL, LDA,
  455. $ ALPHAR, ALPHAI, BETA, WORK,
  456. $ RESULT( 1 ) )
  457. IF( RESULT( 2 ).GT.THRESH ) THEN
  458. WRITE( NOUT, FMT = 9998 )'Left', 'DGGEVX',
  459. $ RESULT( 2 ), N, IPTYPE, IWA, IWB, IWX, IWY
  460. END IF
  461. *
  462. RESULT( 2 ) = ZERO
  463. CALL DGET52( .FALSE., N, A, LDA, B, LDA, VR, LDA,
  464. $ ALPHAR, ALPHAI, BETA, WORK,
  465. $ RESULT( 2 ) )
  466. IF( RESULT( 3 ).GT.THRESH ) THEN
  467. WRITE( NOUT, FMT = 9998 )'Right', 'DGGEVX',
  468. $ RESULT( 3 ), N, IPTYPE, IWA, IWB, IWX, IWY
  469. END IF
  470. *
  471. * Test (3)
  472. *
  473. RESULT( 3 ) = ZERO
  474. DO 10 I = 1, N
  475. IF( S( I ).EQ.ZERO ) THEN
  476. IF( DTRU( I ).GT.ABNORM*ULP )
  477. $ RESULT( 3 ) = ULPINV
  478. ELSE IF( DTRU( I ).EQ.ZERO ) THEN
  479. IF( S( I ).GT.ABNORM*ULP )
  480. $ RESULT( 3 ) = ULPINV
  481. ELSE
  482. WORK( I ) = MAX( ABS( DTRU( I ) / S( I ) ),
  483. $ ABS( S( I ) / DTRU( I ) ) )
  484. RESULT( 3 ) = MAX( RESULT( 3 ), WORK( I ) )
  485. END IF
  486. 10 CONTINUE
  487. *
  488. * Test (4)
  489. *
  490. RESULT( 4 ) = ZERO
  491. IF( DIF( 1 ).EQ.ZERO ) THEN
  492. IF( DIFTRU( 1 ).GT.ABNORM*ULP )
  493. $ RESULT( 4 ) = ULPINV
  494. ELSE IF( DIFTRU( 1 ).EQ.ZERO ) THEN
  495. IF( DIF( 1 ).GT.ABNORM*ULP )
  496. $ RESULT( 4 ) = ULPINV
  497. ELSE IF( DIF( 5 ).EQ.ZERO ) THEN
  498. IF( DIFTRU( 5 ).GT.ABNORM*ULP )
  499. $ RESULT( 4 ) = ULPINV
  500. ELSE IF( DIFTRU( 5 ).EQ.ZERO ) THEN
  501. IF( DIF( 5 ).GT.ABNORM*ULP )
  502. $ RESULT( 4 ) = ULPINV
  503. ELSE
  504. RATIO1 = MAX( ABS( DIFTRU( 1 ) / DIF( 1 ) ),
  505. $ ABS( DIF( 1 ) / DIFTRU( 1 ) ) )
  506. RATIO2 = MAX( ABS( DIFTRU( 5 ) / DIF( 5 ) ),
  507. $ ABS( DIF( 5 ) / DIFTRU( 5 ) ) )
  508. RESULT( 4 ) = MAX( RATIO1, RATIO2 )
  509. END IF
  510. *
  511. NTESTT = NTESTT + 4
  512. *
  513. * Print out tests which fail.
  514. *
  515. DO 20 J = 1, 4
  516. IF( ( RESULT( J ).GE.THRSH2 .AND. J.GE.4 ) .OR.
  517. $ ( RESULT( J ).GE.THRESH .AND. J.LE.3 ) )
  518. $ THEN
  519. *
  520. * If this is the first test to fail,
  521. * print a header to the data file.
  522. *
  523. IF( NERRS.EQ.0 ) THEN
  524. WRITE( NOUT, FMT = 9997 )'DXV'
  525. *
  526. * Print out messages for built-in examples
  527. *
  528. * Matrix types
  529. *
  530. WRITE( NOUT, FMT = 9995 )
  531. WRITE( NOUT, FMT = 9994 )
  532. WRITE( NOUT, FMT = 9993 )
  533. *
  534. * Tests performed
  535. *
  536. WRITE( NOUT, FMT = 9992 )'''',
  537. $ 'transpose', ''''
  538. *
  539. END IF
  540. NERRS = NERRS + 1
  541. IF( RESULT( J ).LT.10000.0D0 ) THEN
  542. WRITE( NOUT, FMT = 9991 )IPTYPE, IWA,
  543. $ IWB, IWX, IWY, J, RESULT( J )
  544. ELSE
  545. WRITE( NOUT, FMT = 9990 )IPTYPE, IWA,
  546. $ IWB, IWX, IWY, J, RESULT( J )
  547. END IF
  548. END IF
  549. 20 CONTINUE
  550. *
  551. 30 CONTINUE
  552. *
  553. 40 CONTINUE
  554. 50 CONTINUE
  555. 60 CONTINUE
  556. 70 CONTINUE
  557. 80 CONTINUE
  558. *
  559. GO TO 150
  560. *
  561. 90 CONTINUE
  562. *
  563. * Read in data from file to check accuracy of condition estimation
  564. * Read input data until N=0
  565. *
  566. READ( NIN, FMT = *, END = 150 )N
  567. IF( N.EQ.0 )
  568. $ GO TO 150
  569. DO 100 I = 1, N
  570. READ( NIN, FMT = * )( A( I, J ), J = 1, N )
  571. 100 CONTINUE
  572. DO 110 I = 1, N
  573. READ( NIN, FMT = * )( B( I, J ), J = 1, N )
  574. 110 CONTINUE
  575. READ( NIN, FMT = * )( DTRU( I ), I = 1, N )
  576. READ( NIN, FMT = * )( DIFTRU( I ), I = 1, N )
  577. *
  578. NPTKNT = NPTKNT + 1
  579. *
  580. * Compute eigenvalues/eigenvectors of (A, B).
  581. * Compute eigenvalue/eigenvector condition numbers
  582. * using computed eigenvectors.
  583. *
  584. CALL DLACPY( 'F', N, N, A, LDA, AI, LDA )
  585. CALL DLACPY( 'F', N, N, B, LDA, BI, LDA )
  586. *
  587. CALL DGGEVX( 'N', 'V', 'V', 'B', N, AI, LDA, BI, LDA, ALPHAR,
  588. $ ALPHAI, BETA, VL, LDA, VR, LDA, ILO, IHI, LSCALE,
  589. $ RSCALE, ANORM, BNORM, S, DIF, WORK, LWORK, IWORK,
  590. $ BWORK, LINFO )
  591. *
  592. IF( LINFO.NE.0 ) THEN
  593. RESULT( 1 ) = ULPINV
  594. WRITE( NOUT, FMT = 9987 )'DGGEVX', LINFO, N, NPTKNT
  595. GO TO 140
  596. END IF
  597. *
  598. * Compute the norm(A, B)
  599. *
  600. CALL DLACPY( 'Full', N, N, AI, LDA, WORK, N )
  601. CALL DLACPY( 'Full', N, N, BI, LDA, WORK( N*N+1 ), N )
  602. ABNORM = DLANGE( 'Fro', N, 2*N, WORK, N, WORK )
  603. *
  604. * Tests (1) and (2)
  605. *
  606. RESULT( 1 ) = ZERO
  607. CALL DGET52( .TRUE., N, A, LDA, B, LDA, VL, LDA, ALPHAR, ALPHAI,
  608. $ BETA, WORK, RESULT( 1 ) )
  609. IF( RESULT( 2 ).GT.THRESH ) THEN
  610. WRITE( NOUT, FMT = 9986 )'Left', 'DGGEVX', RESULT( 2 ), N,
  611. $ NPTKNT
  612. END IF
  613. *
  614. RESULT( 2 ) = ZERO
  615. CALL DGET52( .FALSE., N, A, LDA, B, LDA, VR, LDA, ALPHAR, ALPHAI,
  616. $ BETA, WORK, RESULT( 2 ) )
  617. IF( RESULT( 3 ).GT.THRESH ) THEN
  618. WRITE( NOUT, FMT = 9986 )'Right', 'DGGEVX', RESULT( 3 ), N,
  619. $ NPTKNT
  620. END IF
  621. *
  622. * Test (3)
  623. *
  624. RESULT( 3 ) = ZERO
  625. DO 120 I = 1, N
  626. IF( S( I ).EQ.ZERO ) THEN
  627. IF( DTRU( I ).GT.ABNORM*ULP )
  628. $ RESULT( 3 ) = ULPINV
  629. ELSE IF( DTRU( I ).EQ.ZERO ) THEN
  630. IF( S( I ).GT.ABNORM*ULP )
  631. $ RESULT( 3 ) = ULPINV
  632. ELSE
  633. WORK( I ) = MAX( ABS( DTRU( I ) / S( I ) ),
  634. $ ABS( S( I ) / DTRU( I ) ) )
  635. RESULT( 3 ) = MAX( RESULT( 3 ), WORK( I ) )
  636. END IF
  637. 120 CONTINUE
  638. *
  639. * Test (4)
  640. *
  641. RESULT( 4 ) = ZERO
  642. IF( DIF( 1 ).EQ.ZERO ) THEN
  643. IF( DIFTRU( 1 ).GT.ABNORM*ULP )
  644. $ RESULT( 4 ) = ULPINV
  645. ELSE IF( DIFTRU( 1 ).EQ.ZERO ) THEN
  646. IF( DIF( 1 ).GT.ABNORM*ULP )
  647. $ RESULT( 4 ) = ULPINV
  648. ELSE IF( DIF( 5 ).EQ.ZERO ) THEN
  649. IF( DIFTRU( 5 ).GT.ABNORM*ULP )
  650. $ RESULT( 4 ) = ULPINV
  651. ELSE IF( DIFTRU( 5 ).EQ.ZERO ) THEN
  652. IF( DIF( 5 ).GT.ABNORM*ULP )
  653. $ RESULT( 4 ) = ULPINV
  654. ELSE
  655. RATIO1 = MAX( ABS( DIFTRU( 1 ) / DIF( 1 ) ),
  656. $ ABS( DIF( 1 ) / DIFTRU( 1 ) ) )
  657. RATIO2 = MAX( ABS( DIFTRU( 5 ) / DIF( 5 ) ),
  658. $ ABS( DIF( 5 ) / DIFTRU( 5 ) ) )
  659. RESULT( 4 ) = MAX( RATIO1, RATIO2 )
  660. END IF
  661. *
  662. NTESTT = NTESTT + 4
  663. *
  664. * Print out tests which fail.
  665. *
  666. DO 130 J = 1, 4
  667. IF( RESULT( J ).GE.THRSH2 ) THEN
  668. *
  669. * If this is the first test to fail,
  670. * print a header to the data file.
  671. *
  672. IF( NERRS.EQ.0 ) THEN
  673. WRITE( NOUT, FMT = 9997 )'DXV'
  674. *
  675. * Print out messages for built-in examples
  676. *
  677. * Matrix types
  678. *
  679. WRITE( NOUT, FMT = 9996 )
  680. *
  681. * Tests performed
  682. *
  683. WRITE( NOUT, FMT = 9992 )'''', 'transpose', ''''
  684. *
  685. END IF
  686. NERRS = NERRS + 1
  687. IF( RESULT( J ).LT.10000.0D0 ) THEN
  688. WRITE( NOUT, FMT = 9989 )NPTKNT, N, J, RESULT( J )
  689. ELSE
  690. WRITE( NOUT, FMT = 9988 )NPTKNT, N, J, RESULT( J )
  691. END IF
  692. END IF
  693. 130 CONTINUE
  694. *
  695. 140 CONTINUE
  696. *
  697. GO TO 90
  698. 150 CONTINUE
  699. *
  700. * Summary
  701. *
  702. CALL ALASVM( 'DXV', NOUT, NERRS, NTESTT, 0 )
  703. *
  704. WORK( 1 ) = MAXWRK
  705. *
  706. RETURN
  707. *
  708. 9999 FORMAT( ' DDRGVX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
  709. $ I6, ', JTYPE=', I6, ')' )
  710. *
  711. 9998 FORMAT( ' DDRGVX: ', A, ' Eigenvectors from ', A, ' incorrectly ',
  712. $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
  713. $ 'N=', I6, ', JTYPE=', I6, ', IWA=', I5, ', IWB=', I5,
  714. $ ', IWX=', I5, ', IWY=', I5 )
  715. *
  716. 9997 FORMAT( / 1X, A3, ' -- Real Expert Eigenvalue/vector',
  717. $ ' problem driver' )
  718. *
  719. 9996 FORMAT( ' Input Example' )
  720. *
  721. 9995 FORMAT( ' Matrix types: ', / )
  722. *
  723. 9994 FORMAT( ' TYPE 1: Da is diagonal, Db is identity, ',
  724. $ / ' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
  725. $ / ' YH and X are left and right eigenvectors. ', / )
  726. *
  727. 9993 FORMAT( ' TYPE 2: Da is quasi-diagonal, Db is identity, ',
  728. $ / ' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
  729. $ / ' YH and X are left and right eigenvectors. ', / )
  730. *
  731. 9992 FORMAT( / ' Tests performed: ', / 4X,
  732. $ ' a is alpha, b is beta, l is a left eigenvector, ', / 4X,
  733. $ ' r is a right eigenvector and ', A, ' means ', A, '.',
  734. $ / ' 1 = max | ( b A - a B )', A, ' l | / const.',
  735. $ / ' 2 = max | ( b A - a B ) r | / const.',
  736. $ / ' 3 = max ( Sest/Stru, Stru/Sest ) ',
  737. $ ' over all eigenvalues', /
  738. $ ' 4 = max( DIFest/DIFtru, DIFtru/DIFest ) ',
  739. $ ' over the 1st and 5th eigenvectors', / )
  740. *
  741. 9991 FORMAT( ' Type=', I2, ',', ' IWA=', I2, ', IWB=', I2, ', IWX=',
  742. $ I2, ', IWY=', I2, ', result ', I2, ' is', 0P, F8.2 )
  743. 9990 FORMAT( ' Type=', I2, ',', ' IWA=', I2, ', IWB=', I2, ', IWX=',
  744. $ I2, ', IWY=', I2, ', result ', I2, ' is', 1P, D10.3 )
  745. 9989 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
  746. $ ' result ', I2, ' is', 0P, F8.2 )
  747. 9988 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
  748. $ ' result ', I2, ' is', 1P, D10.3 )
  749. 9987 FORMAT( ' DDRGVX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
  750. $ I6, ', Input example #', I2, ')' )
  751. *
  752. 9986 FORMAT( ' DDRGVX: ', A, ' Eigenvectors from ', A, ' incorrectly ',
  753. $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
  754. $ 'N=', I6, ', Input Example #', I2, ')' )
  755. *
  756. *
  757. * End of DDRGVX
  758. *
  759. END