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.

cchksy_rk.f 28 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867
  1. *> \brief \b CCHKSY_RK
  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 CCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
  12. * THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
  13. * X, XACT, WORK, RWORK, IWORK, NOUT )
  14. *
  15. * .. Scalar Arguments ..
  16. * LOGICAL TSTERR
  17. * INTEGER NMAX, NN, NNB, NNS, NOUT
  18. * REAL THRESH
  19. * ..
  20. * .. Array Arguments ..
  21. * LOGICAL DOTYPE( * )
  22. * INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
  23. * REAL RWORK( * )
  24. * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
  25. * $ WORK( * ), X( * ), XACT( * )
  26. * ..
  27. *
  28. *
  29. *> \par Purpose:
  30. * =============
  31. *>
  32. *> \verbatim
  33. *>
  34. *> CCHKSY_RK tests CSYTRF_RK, -TRI_3, -TRS_3,
  35. *> and -CON_3.
  36. *> \endverbatim
  37. *
  38. * Arguments:
  39. * ==========
  40. *
  41. *> \param[in] DOTYPE
  42. *> \verbatim
  43. *> DOTYPE is LOGICAL array, dimension (NTYPES)
  44. *> The matrix types to be used for testing. Matrices of type j
  45. *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
  46. *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
  47. *> \endverbatim
  48. *>
  49. *> \param[in] NN
  50. *> \verbatim
  51. *> NN is INTEGER
  52. *> The number of values of N contained in the vector NVAL.
  53. *> \endverbatim
  54. *>
  55. *> \param[in] NVAL
  56. *> \verbatim
  57. *> NVAL is INTEGER array, dimension (NN)
  58. *> The values of the matrix dimension N.
  59. *> \endverbatim
  60. *>
  61. *> \param[in] NNB
  62. *> \verbatim
  63. *> NNB is INTEGER
  64. *> The number of values of NB contained in the vector NBVAL.
  65. *> \endverbatim
  66. *>
  67. *> \param[in] NBVAL
  68. *> \verbatim
  69. *> NBVAL is INTEGER array, dimension (NBVAL)
  70. *> The values of the blocksize NB.
  71. *> \endverbatim
  72. *>
  73. *> \param[in] NNS
  74. *> \verbatim
  75. *> NNS is INTEGER
  76. *> The number of values of NRHS contained in the vector NSVAL.
  77. *> \endverbatim
  78. *>
  79. *> \param[in] NSVAL
  80. *> \verbatim
  81. *> NSVAL is INTEGER array, dimension (NNS)
  82. *> The values of the number of right hand sides NRHS.
  83. *> \endverbatim
  84. *>
  85. *> \param[in] THRESH
  86. *> \verbatim
  87. *> THRESH is REAL
  88. *> The threshold value for the test ratios. A result is
  89. *> included in the output file if RESULT >= THRESH. To have
  90. *> every test ratio printed, use THRESH = 0.
  91. *> \endverbatim
  92. *>
  93. *> \param[in] TSTERR
  94. *> \verbatim
  95. *> TSTERR is LOGICAL
  96. *> Flag that indicates whether error exits are to be tested.
  97. *> \endverbatim
  98. *>
  99. *> \param[in] NMAX
  100. *> \verbatim
  101. *> NMAX is INTEGER
  102. *> The maximum value permitted for N, used in dimensioning the
  103. *> work arrays.
  104. *> \endverbatim
  105. *>
  106. *> \param[out] A
  107. *> \verbatim
  108. *> A is COMPLEX array, dimension (NMAX*NMAX)
  109. *> \endverbatim
  110. *>
  111. *> \param[out] AFAC
  112. *> \verbatim
  113. *> AFAC is COMPLEX array, dimension (NMAX*NMAX)
  114. *> \endverbatim
  115. *>
  116. *> \param[out] E
  117. *> \verbatim
  118. *> E is COMPLEX array, dimension (NMAX)
  119. *> \endverbatim
  120. *>
  121. *> \param[out] AINV
  122. *> \verbatim
  123. *> AINV is COMPLEX array, dimension (NMAX*NMAX)
  124. *> \endverbatim
  125. *>
  126. *> \param[out] B
  127. *> \verbatim
  128. *> B is COMPLEX array, dimension (NMAX*NSMAX)
  129. *> where NSMAX is the largest entry in NSVAL.
  130. *> \endverbatim
  131. *>
  132. *> \param[out] X
  133. *> \verbatim
  134. *> X is COMPLEX array, dimension (NMAX*NSMAX)
  135. *> \endverbatim
  136. *>
  137. *> \param[out] XACT
  138. *> \verbatim
  139. *> XACT is COMPLEX array, dimension (NMAX*NSMAX)
  140. *> \endverbatim
  141. *>
  142. *> \param[out] WORK
  143. *> \verbatim
  144. *> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
  145. *> \endverbatim
  146. *>
  147. *> \param[out] RWORK
  148. *> \verbatim
  149. *> RWORK is REAL array, dimension (max(NMAX,2*NSMAX))
  150. *> \endverbatim
  151. *>
  152. *> \param[out] IWORK
  153. *> \verbatim
  154. *> IWORK is INTEGER array, dimension (2*NMAX)
  155. *> \endverbatim
  156. *>
  157. *> \param[in] NOUT
  158. *> \verbatim
  159. *> NOUT is INTEGER
  160. *> The unit number for output.
  161. *> \endverbatim
  162. *
  163. * Authors:
  164. * ========
  165. *
  166. *> \author Univ. of Tennessee
  167. *> \author Univ. of California Berkeley
  168. *> \author Univ. of Colorado Denver
  169. *> \author NAG Ltd.
  170. *
  171. *> \date December 2016
  172. *
  173. *> \ingroup complex_lin
  174. *
  175. * =====================================================================
  176. SUBROUTINE CCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
  177. $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
  178. $ X, XACT, WORK, RWORK, IWORK, NOUT )
  179. *
  180. * -- LAPACK test routine (version 3.7.0) --
  181. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  182. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  183. * December 2016
  184. *
  185. * .. Scalar Arguments ..
  186. LOGICAL TSTERR
  187. INTEGER NMAX, NN, NNB, NNS, NOUT
  188. REAL THRESH
  189. * ..
  190. * .. Array Arguments ..
  191. LOGICAL DOTYPE( * )
  192. INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
  193. REAL RWORK( * )
  194. COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
  195. $ WORK( * ), X( * ), XACT( * )
  196. * ..
  197. *
  198. * =====================================================================
  199. *
  200. * .. Parameters ..
  201. REAL ZERO, ONE
  202. PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
  203. REAL ONEHALF
  204. PARAMETER ( ONEHALF = 0.5E+0 )
  205. REAL EIGHT, SEVTEN
  206. PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
  207. COMPLEX CZERO
  208. PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
  209. INTEGER NTYPES
  210. PARAMETER ( NTYPES = 11 )
  211. INTEGER NTESTS
  212. PARAMETER ( NTESTS = 7 )
  213. * ..
  214. * .. Local Scalars ..
  215. LOGICAL TRFCON, ZEROT
  216. CHARACTER DIST, TYPE, UPLO, XTYPE
  217. CHARACTER*3 PATH, MATPATH
  218. INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
  219. $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA,
  220. $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS,
  221. $ NRUN, NT
  222. REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
  223. $ SING_MIN, RCOND, RCONDC, STEMP
  224. * ..
  225. * .. Local Arrays ..
  226. CHARACTER UPLOS( 2 )
  227. INTEGER ISEED( 4 ), ISEEDY( 4 )
  228. REAL RESULT( NTESTS )
  229. COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
  230. * ..
  231. * .. External Functions ..
  232. REAL CLANGE, CLANSY, SGET06
  233. EXTERNAL CLANGE, CLANSY, SGET06
  234. * ..
  235. * .. External Subroutines ..
  236. EXTERNAL ALAERH, ALAHD, ALASUM, CERRSY, CGESVD, CGET04,
  237. $ CLACPY, CLARHS, CLATB4, CLATMS, CLATSY, CSYT02,
  238. $ CSYT03, CSYCON_3, CSYT01_3, CSYTRF_RK,
  239. $ CSYTRI_3, CSYTRS_3, XLAENV
  240. * ..
  241. * .. Intrinsic Functions ..
  242. INTRINSIC MAX, MIN, SQRT
  243. * ..
  244. * .. Scalars in Common ..
  245. LOGICAL LERR, OK
  246. CHARACTER*32 SRNAMT
  247. INTEGER INFOT, NUNIT
  248. * ..
  249. * .. Common blocks ..
  250. COMMON / INFOC / INFOT, NUNIT, OK, LERR
  251. COMMON / SRNAMC / SRNAMT
  252. * ..
  253. * .. Data statements ..
  254. DATA ISEEDY / 1988, 1989, 1990, 1991 /
  255. DATA UPLOS / 'U', 'L' /
  256. * ..
  257. * .. Executable Statements ..
  258. *
  259. * Initialize constants and the random number seed.
  260. *
  261. ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
  262. *
  263. * Test path
  264. *
  265. PATH( 1: 1 ) = 'Complex precision'
  266. PATH( 2: 3 ) = 'SK'
  267. *
  268. * Path to generate matrices
  269. *
  270. MATPATH( 1: 1 ) = 'Complex precision'
  271. MATPATH( 2: 3 ) = 'SY'
  272. *
  273. NRUN = 0
  274. NFAIL = 0
  275. NERRS = 0
  276. DO 10 I = 1, 4
  277. ISEED( I ) = ISEEDY( I )
  278. 10 CONTINUE
  279. *
  280. * Test the error exits
  281. *
  282. IF( TSTERR )
  283. $ CALL CERRSY( PATH, NOUT )
  284. INFOT = 0
  285. *
  286. * Set the minimum block size for which the block routine should
  287. * be used, which will be later returned by ILAENV
  288. *
  289. CALL XLAENV( 2, 2 )
  290. *
  291. * Do for each value of N in NVAL
  292. *
  293. DO 270 IN = 1, NN
  294. N = NVAL( IN )
  295. LDA = MAX( N, 1 )
  296. XTYPE = 'N'
  297. NIMAT = NTYPES
  298. IF( N.LE.0 )
  299. $ NIMAT = 1
  300. *
  301. IZERO = 0
  302. *
  303. * Do for each value of matrix type IMAT
  304. *
  305. DO 260 IMAT = 1, NIMAT
  306. *
  307. * Do the tests only if DOTYPE( IMAT ) is true.
  308. *
  309. IF( .NOT.DOTYPE( IMAT ) )
  310. $ GO TO 260
  311. *
  312. * Skip types 3, 4, 5, or 6 if the matrix size is too small.
  313. *
  314. ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
  315. IF( ZEROT .AND. N.LT.IMAT-2 )
  316. $ GO TO 260
  317. *
  318. * Do first for UPLO = 'U', then for UPLO = 'L'
  319. *
  320. DO 250 IUPLO = 1, 2
  321. UPLO = UPLOS( IUPLO )
  322. *
  323. * Begin generate test matrix A.
  324. *
  325. IF( IMAT.NE.NTYPES ) THEN
  326. *
  327. * Set up parameters with CLATB4 for the matrix generator
  328. * based on the type of matrix to be generated.
  329. *
  330. CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
  331. $ MODE, CNDNUM, DIST )
  332. *
  333. * Generate a matrix with CLATMS.
  334. *
  335. SRNAMT = 'CLATMS'
  336. CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
  337. $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
  338. $ WORK, INFO )
  339. *
  340. * Check error code from CLATMS and handle error.
  341. *
  342. IF( INFO.NE.0 ) THEN
  343. CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N,
  344. $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
  345. *
  346. * Skip all tests for this generated matrix
  347. *
  348. GO TO 250
  349. END IF
  350. *
  351. * For matrix types 3-6, zero one or more rows and
  352. * columns of the matrix to test that INFO is returned
  353. * correctly.
  354. *
  355. IF( ZEROT ) THEN
  356. IF( IMAT.EQ.3 ) THEN
  357. IZERO = 1
  358. ELSE IF( IMAT.EQ.4 ) THEN
  359. IZERO = N
  360. ELSE
  361. IZERO = N / 2 + 1
  362. END IF
  363. *
  364. IF( IMAT.LT.6 ) THEN
  365. *
  366. * Set row and column IZERO to zero.
  367. *
  368. IF( IUPLO.EQ.1 ) THEN
  369. IOFF = ( IZERO-1 )*LDA
  370. DO 20 I = 1, IZERO - 1
  371. A( IOFF+I ) = CZERO
  372. 20 CONTINUE
  373. IOFF = IOFF + IZERO
  374. DO 30 I = IZERO, N
  375. A( IOFF ) = CZERO
  376. IOFF = IOFF + LDA
  377. 30 CONTINUE
  378. ELSE
  379. IOFF = IZERO
  380. DO 40 I = 1, IZERO - 1
  381. A( IOFF ) = CZERO
  382. IOFF = IOFF + LDA
  383. 40 CONTINUE
  384. IOFF = IOFF - IZERO
  385. DO 50 I = IZERO, N
  386. A( IOFF+I ) = CZERO
  387. 50 CONTINUE
  388. END IF
  389. ELSE
  390. IF( IUPLO.EQ.1 ) THEN
  391. *
  392. * Set the first IZERO rows and columns to zero.
  393. *
  394. IOFF = 0
  395. DO 70 J = 1, N
  396. I2 = MIN( J, IZERO )
  397. DO 60 I = 1, I2
  398. A( IOFF+I ) = CZERO
  399. 60 CONTINUE
  400. IOFF = IOFF + LDA
  401. 70 CONTINUE
  402. ELSE
  403. *
  404. * Set the last IZERO rows and columns to zero.
  405. *
  406. IOFF = 0
  407. DO 90 J = 1, N
  408. I1 = MAX( J, IZERO )
  409. DO 80 I = I1, N
  410. A( IOFF+I ) = CZERO
  411. 80 CONTINUE
  412. IOFF = IOFF + LDA
  413. 90 CONTINUE
  414. END IF
  415. END IF
  416. ELSE
  417. IZERO = 0
  418. END IF
  419. *
  420. ELSE
  421. *
  422. * For matrix kind IMAT = 11, generate special block
  423. * diagonal matrix to test alternate code
  424. * for the 2 x 2 blocks.
  425. *
  426. CALL CLATSY( UPLO, N, A, LDA, ISEED )
  427. *
  428. END IF
  429. *
  430. * End generate test matrix A.
  431. *
  432. *
  433. * Do for each value of NB in NBVAL
  434. *
  435. DO 240 INB = 1, NNB
  436. *
  437. * Set the optimal blocksize, which will be later
  438. * returned by ILAENV.
  439. *
  440. NB = NBVAL( INB )
  441. CALL XLAENV( 1, NB )
  442. *
  443. * Copy the test matrix A into matrix AFAC which
  444. * will be factorized in place. This is needed to
  445. * preserve the test matrix A for subsequent tests.
  446. *
  447. CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
  448. *
  449. * Compute the L*D*L**T or U*D*U**T factorization of the
  450. * matrix. IWORK stores details of the interchanges and
  451. * the block structure of D. AINV is a work array for
  452. * block factorization, LWORK is the length of AINV.
  453. *
  454. LWORK = MAX( 2, NB )*LDA
  455. SRNAMT = 'CSYTRF_RK'
  456. CALL CSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV,
  457. $ LWORK, INFO )
  458. *
  459. * Adjust the expected value of INFO to account for
  460. * pivoting.
  461. *
  462. K = IZERO
  463. IF( K.GT.0 ) THEN
  464. 100 CONTINUE
  465. IF( IWORK( K ).LT.0 ) THEN
  466. IF( IWORK( K ).NE.-K ) THEN
  467. K = -IWORK( K )
  468. GO TO 100
  469. END IF
  470. ELSE IF( IWORK( K ).NE.K ) THEN
  471. K = IWORK( K )
  472. GO TO 100
  473. END IF
  474. END IF
  475. *
  476. * Check error code from CSYTRF_RK and handle error.
  477. *
  478. IF( INFO.NE.K)
  479. $ CALL ALAERH( PATH, 'CSYTRF_RK', INFO, K,
  480. $ UPLO, N, N, -1, -1, NB, IMAT,
  481. $ NFAIL, NERRS, NOUT )
  482. *
  483. * Set the condition estimate flag if the INFO is not 0.
  484. *
  485. IF( INFO.NE.0 ) THEN
  486. TRFCON = .TRUE.
  487. ELSE
  488. TRFCON = .FALSE.
  489. END IF
  490. *
  491. *+ TEST 1
  492. * Reconstruct matrix from factors and compute residual.
  493. *
  494. CALL CSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK,
  495. $ AINV, LDA, RWORK, RESULT( 1 ) )
  496. NT = 1
  497. *
  498. *+ TEST 2
  499. * Form the inverse and compute the residual,
  500. * if the factorization was competed without INFO > 0
  501. * (i.e. there is no zero rows and columns).
  502. * Do it only for the first block size.
  503. *
  504. IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
  505. CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
  506. SRNAMT = 'CSYTRI_3'
  507. *
  508. * Another reason that we need to compute the invesrse
  509. * is that CSYT03 produces RCONDC which is used later
  510. * in TEST6 and TEST7.
  511. *
  512. LWORK = (N+NB+1)*(NB+3)
  513. CALL CSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK,
  514. $ LWORK, INFO )
  515. *
  516. * Check error code from CSYTRI_3 and handle error.
  517. *
  518. IF( INFO.NE.0 )
  519. $ CALL ALAERH( PATH, 'CSYTRI_3', INFO, -1,
  520. $ UPLO, N, N, -1, -1, -1, IMAT,
  521. $ NFAIL, NERRS, NOUT )
  522. *
  523. * Compute the residual for a symmetric matrix times
  524. * its inverse.
  525. *
  526. CALL CSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
  527. $ RWORK, RCONDC, RESULT( 2 ) )
  528. NT = 2
  529. END IF
  530. *
  531. * Print information about the tests that did not pass
  532. * the threshold.
  533. *
  534. DO 110 K = 1, NT
  535. IF( RESULT( K ).GE.THRESH ) THEN
  536. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  537. $ CALL ALAHD( NOUT, PATH )
  538. WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
  539. $ RESULT( K )
  540. NFAIL = NFAIL + 1
  541. END IF
  542. 110 CONTINUE
  543. NRUN = NRUN + NT
  544. *
  545. *+ TEST 3
  546. * Compute largest element in U or L
  547. *
  548. RESULT( 3 ) = ZERO
  549. STEMP = ZERO
  550. *
  551. CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) /
  552. $ ( ONE-ALPHA )
  553. *
  554. IF( IUPLO.EQ.1 ) THEN
  555. *
  556. * Compute largest element in U
  557. *
  558. K = N
  559. 120 CONTINUE
  560. IF( K.LE.1 )
  561. $ GO TO 130
  562. *
  563. IF( IWORK( K ).GT.ZERO ) THEN
  564. *
  565. * Get max absolute value from elements
  566. * in column k in in U
  567. *
  568. STEMP = CLANGE( 'M', K-1, 1,
  569. $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
  570. ELSE
  571. *
  572. * Get max absolute value from elements
  573. * in columns k and k-1 in U
  574. *
  575. STEMP = CLANGE( 'M', K-2, 2,
  576. $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
  577. K = K - 1
  578. *
  579. END IF
  580. *
  581. * STEMP should be bounded by CONST
  582. *
  583. STEMP = STEMP - CONST + THRESH
  584. IF( STEMP.GT.RESULT( 3 ) )
  585. $ RESULT( 3 ) = STEMP
  586. *
  587. K = K - 1
  588. *
  589. GO TO 120
  590. 130 CONTINUE
  591. *
  592. ELSE
  593. *
  594. * Compute largest element in L
  595. *
  596. K = 1
  597. 140 CONTINUE
  598. IF( K.GE.N )
  599. $ GO TO 150
  600. *
  601. IF( IWORK( K ).GT.ZERO ) THEN
  602. *
  603. * Get max absolute value from elements
  604. * in column k in in L
  605. *
  606. STEMP = CLANGE( 'M', N-K, 1,
  607. $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
  608. ELSE
  609. *
  610. * Get max absolute value from elements
  611. * in columns k and k+1 in L
  612. *
  613. STEMP = CLANGE( 'M', N-K-1, 2,
  614. $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
  615. K = K + 1
  616. *
  617. END IF
  618. *
  619. * STEMP should be bounded by CONST
  620. *
  621. STEMP = STEMP - CONST + THRESH
  622. IF( STEMP.GT.RESULT( 3 ) )
  623. $ RESULT( 3 ) = STEMP
  624. *
  625. K = K + 1
  626. *
  627. GO TO 140
  628. 150 CONTINUE
  629. END IF
  630. *
  631. *
  632. *+ TEST 4
  633. * Compute largest 2-Norm (condition number)
  634. * of 2-by-2 diag blocks
  635. *
  636. RESULT( 4 ) = ZERO
  637. STEMP = ZERO
  638. *
  639. CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )*
  640. $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) )
  641. *
  642. IF( IUPLO.EQ.1 ) THEN
  643. *
  644. * Loop backward for UPLO = 'U'
  645. *
  646. K = N
  647. 160 CONTINUE
  648. IF( K.LE.1 )
  649. $ GO TO 170
  650. *
  651. IF( IWORK( K ).LT.ZERO ) THEN
  652. *
  653. * Get the two singular values
  654. * (real and non-negative) of a 2-by-2 block,
  655. * store them in RWORK array
  656. *
  657. BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 )
  658. BLOCK( 1, 2 ) = E( K )
  659. BLOCK( 2, 1 ) = BLOCK( 1, 2 )
  660. BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K )
  661. *
  662. CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
  663. $ CDUMMY, 1, CDUMMY, 1,
  664. $ WORK, 6, RWORK( 3 ), INFO )
  665. *
  666. *
  667. SING_MAX = RWORK( 1 )
  668. SING_MIN = RWORK( 2 )
  669. *
  670. STEMP = SING_MAX / SING_MIN
  671. *
  672. * STEMP should be bounded by CONST
  673. *
  674. STEMP = STEMP - CONST + THRESH
  675. IF( STEMP.GT.RESULT( 4 ) )
  676. $ RESULT( 4 ) = STEMP
  677. K = K - 1
  678. *
  679. END IF
  680. *
  681. K = K - 1
  682. *
  683. GO TO 160
  684. 170 CONTINUE
  685. *
  686. ELSE
  687. *
  688. * Loop forward for UPLO = 'L'
  689. *
  690. K = 1
  691. 180 CONTINUE
  692. IF( K.GE.N )
  693. $ GO TO 190
  694. *
  695. IF( IWORK( K ).LT.ZERO ) THEN
  696. *
  697. * Get the two singular values
  698. * (real and non-negative) of a 2-by-2 block,
  699. * store them in RWORK array
  700. *
  701. BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K )
  702. BLOCK( 2, 1 ) = E( K )
  703. BLOCK( 1, 2 ) = BLOCK( 2, 1 )
  704. BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 )
  705. *
  706. CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
  707. $ CDUMMY, 1, CDUMMY, 1,
  708. $ WORK, 6, RWORK(3), INFO )
  709. *
  710. SING_MAX = RWORK( 1 )
  711. SING_MIN = RWORK( 2 )
  712. *
  713. STEMP = SING_MAX / SING_MIN
  714. *
  715. * STEMP should be bounded by CONST
  716. *
  717. STEMP = STEMP - CONST + THRESH
  718. IF( STEMP.GT.RESULT( 4 ) )
  719. $ RESULT( 4 ) = STEMP
  720. K = K + 1
  721. *
  722. END IF
  723. *
  724. K = K + 1
  725. *
  726. GO TO 180
  727. 190 CONTINUE
  728. END IF
  729. *
  730. * Print information about the tests that did not pass
  731. * the threshold.
  732. *
  733. DO 200 K = 3, 4
  734. IF( RESULT( K ).GE.THRESH ) THEN
  735. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  736. $ CALL ALAHD( NOUT, PATH )
  737. WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
  738. $ RESULT( K )
  739. NFAIL = NFAIL + 1
  740. END IF
  741. 200 CONTINUE
  742. NRUN = NRUN + 2
  743. *
  744. * Skip the other tests if this is not the first block
  745. * size.
  746. *
  747. IF( INB.GT.1 )
  748. $ GO TO 240
  749. *
  750. * Do only the condition estimate if INFO is not 0.
  751. *
  752. IF( TRFCON ) THEN
  753. RCONDC = ZERO
  754. GO TO 230
  755. END IF
  756. *
  757. * Do for each value of NRHS in NSVAL.
  758. *
  759. DO 220 IRHS = 1, NNS
  760. NRHS = NSVAL( IRHS )
  761. *
  762. *+ TEST 5 ( Using TRS_3)
  763. * Solve and compute residual for A * X = B.
  764. *
  765. * Choose a set of NRHS random solution vectors
  766. * stored in XACT and set up the right hand side B
  767. *
  768. SRNAMT = 'CLARHS'
  769. CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
  770. $ KL, KU, NRHS, A, LDA, XACT, LDA,
  771. $ B, LDA, ISEED, INFO )
  772. CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
  773. *
  774. SRNAMT = 'CSYTRS_3'
  775. CALL CSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
  776. $ X, LDA, INFO )
  777. *
  778. * Check error code from CSYTRS_3 and handle error.
  779. *
  780. IF( INFO.NE.0 )
  781. $ CALL ALAERH( PATH, 'CSYTRS_3', INFO, 0,
  782. $ UPLO, N, N, -1, -1, NRHS, IMAT,
  783. $ NFAIL, NERRS, NOUT )
  784. *
  785. CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
  786. *
  787. * Compute the residual for the solution
  788. *
  789. CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
  790. $ LDA, RWORK, RESULT( 5 ) )
  791. *
  792. *+ TEST 6
  793. * Check solution from generated exact solution.
  794. *
  795. CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
  796. $ RESULT( 6 ) )
  797. *
  798. * Print information about the tests that did not pass
  799. * the threshold.
  800. *
  801. DO 210 K = 5, 6
  802. IF( RESULT( K ).GE.THRESH ) THEN
  803. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  804. $ CALL ALAHD( NOUT, PATH )
  805. WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
  806. $ IMAT, K, RESULT( K )
  807. NFAIL = NFAIL + 1
  808. END IF
  809. 210 CONTINUE
  810. NRUN = NRUN + 2
  811. *
  812. * End do for each value of NRHS in NSVAL.
  813. *
  814. 220 CONTINUE
  815. *
  816. *+ TEST 7
  817. * Get an estimate of RCOND = 1/CNDNUM.
  818. *
  819. 230 CONTINUE
  820. ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK )
  821. SRNAMT = 'CSYCON_3'
  822. CALL CSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM,
  823. $ RCOND, WORK, INFO )
  824. *
  825. * Check error code from CSYCON_3 and handle error.
  826. *
  827. IF( INFO.NE.0 )
  828. $ CALL ALAERH( PATH, 'CSYCON_3', INFO, 0,
  829. $ UPLO, N, N, -1, -1, -1, IMAT,
  830. $ NFAIL, NERRS, NOUT )
  831. *
  832. * Compute the test ratio to compare values of RCOND
  833. *
  834. RESULT( 7 ) = SGET06( RCOND, RCONDC )
  835. *
  836. * Print information about the tests that did not pass
  837. * the threshold.
  838. *
  839. IF( RESULT( 7 ).GE.THRESH ) THEN
  840. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  841. $ CALL ALAHD( NOUT, PATH )
  842. WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7,
  843. $ RESULT( 7 )
  844. NFAIL = NFAIL + 1
  845. END IF
  846. NRUN = NRUN + 1
  847. 240 CONTINUE
  848. *
  849. 250 CONTINUE
  850. 260 CONTINUE
  851. 270 CONTINUE
  852. *
  853. * Print a summary of the results.
  854. *
  855. CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
  856. *
  857. 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
  858. $ I2, ', test ', I2, ', ratio =', G12.5 )
  859. 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
  860. $ I2, ', test(', I2, ') =', G12.5 )
  861. 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
  862. $ ', test(', I2, ') =', G12.5 )
  863. RETURN
  864. *
  865. * End of CCHKSY_RK
  866. *
  867. END