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.

sdrvsy_rk.f 16 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531
  1. *> \brief \b SDRVSY_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 SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
  12. * $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
  13. * $ RWORK, IWORK, NOUT )
  14. *
  15. * .. Scalar Arguments ..
  16. * LOGICAL TSTERR
  17. * INTEGER NMAX, NN, NOUT, NRHS
  18. * REAL THRESH
  19. * ..
  20. * .. Array Arguments ..
  21. * LOGICAL DOTYPE( * )
  22. * INTEGER IWORK( * ), NVAL( * )
  23. * REAL A( * ), AFAC( * ), E( * ), AINV( * ), B( * ),
  24. * $ RWORK( * ), WORK( * ), X( * ), XACT( * )
  25. * ..
  26. *
  27. *
  28. *> \par Purpose:
  29. * =============
  30. *>
  31. *> \verbatim
  32. *> SDRVSY_RK tests the driver routines SSYSV_RK.
  33. *> \endverbatim
  34. *
  35. * Arguments:
  36. * ==========
  37. *
  38. *> \param[in] DOTYPE
  39. *> \verbatim
  40. *> DOTYPE is LOGICAL array, dimension (NTYPES)
  41. *> The matrix types to be used for testing. Matrices of type j
  42. *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
  43. *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
  44. *> \endverbatim
  45. *>
  46. *> \param[in] NN
  47. *> \verbatim
  48. *> NN is INTEGER
  49. *> The number of values of N contained in the vector NVAL.
  50. *> \endverbatim
  51. *>
  52. *> \param[in] NVAL
  53. *> \verbatim
  54. *> NVAL is INTEGER array, dimension (NN)
  55. *> The values of the matrix dimension N.
  56. *> \endverbatim
  57. *>
  58. *> \param[in] NRHS
  59. *> \verbatim
  60. *> NRHS is INTEGER
  61. *> The number of right hand side vectors to be generated for
  62. *> each linear system.
  63. *> \endverbatim
  64. *>
  65. *> \param[in] THRESH
  66. *> \verbatim
  67. *> THRESH is REAL
  68. *> The threshold value for the test ratios. A result is
  69. *> included in the output file if RESULT >= THRESH. To have
  70. *> every test ratio printed, use THRESH = 0.
  71. *> \endverbatim
  72. *>
  73. *> \param[in] TSTERR
  74. *> \verbatim
  75. *> TSTERR is LOGICAL
  76. *> Flag that indicates whether error exits are to be tested.
  77. *> \endverbatim
  78. *>
  79. *> \param[in] NMAX
  80. *> \verbatim
  81. *> NMAX is INTEGER
  82. *> The maximum value permitted for N, used in dimensioning the
  83. *> work arrays.
  84. *> \endverbatim
  85. *>
  86. *> \param[out] A
  87. *> \verbatim
  88. *> A is REAL array, dimension (NMAX*NMAX)
  89. *> \endverbatim
  90. *>
  91. *> \param[out] AFAC
  92. *> \verbatim
  93. *> AFAC is REAL array, dimension (NMAX*NMAX)
  94. *> \endverbatim
  95. *>
  96. *> \param[out] E
  97. *> \verbatim
  98. *> E is REAL array, dimension (NMAX)
  99. *> \endverbatim
  100. *>
  101. *> \param[out] AINV
  102. *> \verbatim
  103. *> AINV is REAL array, dimension (NMAX*NMAX)
  104. *> \endverbatim
  105. *>
  106. *> \param[out] B
  107. *> \verbatim
  108. *> B is REAL array, dimension (NMAX*NRHS)
  109. *> \endverbatim
  110. *>
  111. *> \param[out] X
  112. *> \verbatim
  113. *> X is REAL array, dimension (NMAX*NRHS)
  114. *> \endverbatim
  115. *>
  116. *> \param[out] XACT
  117. *> \verbatim
  118. *> XACT is REAL array, dimension (NMAX*NRHS)
  119. *> \endverbatim
  120. *>
  121. *> \param[out] WORK
  122. *> \verbatim
  123. *> WORK is REAL array, dimension (NMAX*max(2,NRHS))
  124. *> \endverbatim
  125. *>
  126. *> \param[out] RWORK
  127. *> \verbatim
  128. *> RWORK is REAL array, dimension (NMAX+2*NRHS)
  129. *> \endverbatim
  130. *>
  131. *> \param[out] IWORK
  132. *> \verbatim
  133. *> IWORK is INTEGER array, dimension (2*NMAX)
  134. *> \endverbatim
  135. *>
  136. *> \param[in] NOUT
  137. *> \verbatim
  138. *> NOUT is INTEGER
  139. *> The unit number for output.
  140. *> \endverbatim
  141. *
  142. * Authors:
  143. * ========
  144. *
  145. *> \author Univ. of Tennessee
  146. *> \author Univ. of California Berkeley
  147. *> \author Univ. of Colorado Denver
  148. *> \author NAG Ltd.
  149. *
  150. *> \date December 2016
  151. *
  152. *> \ingroup single_lin
  153. *
  154. * =====================================================================
  155. SUBROUTINE SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
  156. $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
  157. $ RWORK, IWORK, NOUT )
  158. *
  159. * -- LAPACK test routine (version 3.7.0) --
  160. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  161. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  162. * December 2016
  163. *
  164. * .. Scalar Arguments ..
  165. LOGICAL TSTERR
  166. INTEGER NMAX, NN, NOUT, NRHS
  167. REAL THRESH
  168. * ..
  169. * .. Array Arguments ..
  170. LOGICAL DOTYPE( * )
  171. INTEGER IWORK( * ), NVAL( * )
  172. REAL A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
  173. $ RWORK( * ), WORK( * ), X( * ), XACT( * )
  174. * ..
  175. *
  176. * =====================================================================
  177. *
  178. * .. Parameters ..
  179. REAL ONE, ZERO
  180. PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
  181. INTEGER NTYPES, NTESTS
  182. PARAMETER ( NTYPES = 10, NTESTS = 3 )
  183. INTEGER NFACT
  184. PARAMETER ( NFACT = 2 )
  185. * ..
  186. * .. Local Scalars ..
  187. LOGICAL ZEROT
  188. CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
  189. CHARACTER*3 PATH, MATPATH
  190. INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
  191. $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
  192. $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
  193. REAL AINVNM, ANORM, CNDNUM, RCONDC
  194. * ..
  195. * .. Local Arrays ..
  196. CHARACTER FACTS( NFACT ), UPLOS( 2 )
  197. INTEGER ISEED( 4 ), ISEEDY( 4 )
  198. REAL RESULT( NTESTS )
  199. * ..
  200. * .. External Functions ..
  201. REAL SLANSY
  202. EXTERNAL SLANSY
  203. * ..
  204. * .. External Subroutines ..
  205. EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY,
  206. $ SLARHS, SLATB4, SLATMS, SPOT02, SSYSV_RK,
  207. $ SSYT01_3, SSYTRF_RK, SSYTRI_3, XLAENV
  208. * ..
  209. * .. Scalars in Common ..
  210. LOGICAL LERR, OK
  211. CHARACTER*32 SRNAMT
  212. INTEGER INFOT, NUNIT
  213. * ..
  214. * .. Common blocks ..
  215. COMMON / INFOC / INFOT, NUNIT, OK, LERR
  216. COMMON / SRNAMC / SRNAMT
  217. * ..
  218. * .. Intrinsic Functions ..
  219. INTRINSIC MAX, MIN
  220. * ..
  221. * .. Data statements ..
  222. DATA ISEEDY / 1988, 1989, 1990, 1991 /
  223. DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
  224. * ..
  225. * .. Executable Statements ..
  226. *
  227. * Initialize constants and the random number seed.
  228. *
  229. * Test path
  230. *
  231. PATH( 1: 1 ) = 'Single precision'
  232. PATH( 2: 3 ) = 'SK'
  233. *
  234. * Path to generate matrices
  235. *
  236. MATPATH( 1: 1 ) = 'Single precision'
  237. MATPATH( 2: 3 ) = 'SY'
  238. *
  239. NRUN = 0
  240. NFAIL = 0
  241. NERRS = 0
  242. DO 10 I = 1, 4
  243. ISEED( I ) = ISEEDY( I )
  244. 10 CONTINUE
  245. LWORK = MAX( 2*NMAX, NMAX*NRHS )
  246. *
  247. * Test the error exits
  248. *
  249. IF( TSTERR )
  250. $ CALL SERRVX( PATH, NOUT )
  251. INFOT = 0
  252. *
  253. * Set the block size and minimum block size for which the block
  254. * routine should be used, which will be later returned by ILAENV.
  255. *
  256. NB = 1
  257. NBMIN = 2
  258. CALL XLAENV( 1, NB )
  259. CALL XLAENV( 2, NBMIN )
  260. *
  261. * Do for each value of N in NVAL
  262. *
  263. DO 180 IN = 1, NN
  264. N = NVAL( IN )
  265. LDA = MAX( N, 1 )
  266. XTYPE = 'N'
  267. NIMAT = NTYPES
  268. IF( N.LE.0 )
  269. $ NIMAT = 1
  270. *
  271. DO 170 IMAT = 1, NIMAT
  272. *
  273. * Do the tests only if DOTYPE( IMAT ) is true.
  274. *
  275. IF( .NOT.DOTYPE( IMAT ) )
  276. $ GO TO 170
  277. *
  278. * Skip types 3, 4, 5, or 6 if the matrix size is too small.
  279. *
  280. ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
  281. IF( ZEROT .AND. N.LT.IMAT-2 )
  282. $ GO TO 170
  283. *
  284. * Do first for UPLO = 'U', then for UPLO = 'L'
  285. *
  286. DO 160 IUPLO = 1, 2
  287. UPLO = UPLOS( IUPLO )
  288. *
  289. * Begin generate the test matrix A.
  290. *
  291. * Set up parameters with SLATB4 for the matrix generator
  292. * based on the type of matrix to be generated.
  293. *
  294. CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
  295. $ MODE, CNDNUM, DIST )
  296. *
  297. * Generate a matrix with SLATMS.
  298. *
  299. SRNAMT = 'SLATMS'
  300. CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
  301. $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
  302. $ INFO )
  303. *
  304. * Check error code from SLATMS and handle error.
  305. *
  306. IF( INFO.NE.0 ) THEN
  307. CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
  308. $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
  309. *
  310. * Skip all tests for this generated matrix
  311. *
  312. GO TO 160
  313. END IF
  314. *
  315. * For types 3-6, zero one or more rows and columns of the
  316. * matrix to test that INFO is returned correctly.
  317. *
  318. IF( ZEROT ) THEN
  319. IF( IMAT.EQ.3 ) THEN
  320. IZERO = 1
  321. ELSE IF( IMAT.EQ.4 ) THEN
  322. IZERO = N
  323. ELSE
  324. IZERO = N / 2 + 1
  325. END IF
  326. *
  327. IF( IMAT.LT.6 ) THEN
  328. *
  329. * Set row and column IZERO to zero.
  330. *
  331. IF( IUPLO.EQ.1 ) THEN
  332. IOFF = ( IZERO-1 )*LDA
  333. DO 20 I = 1, IZERO - 1
  334. A( IOFF+I ) = ZERO
  335. 20 CONTINUE
  336. IOFF = IOFF + IZERO
  337. DO 30 I = IZERO, N
  338. A( IOFF ) = ZERO
  339. IOFF = IOFF + LDA
  340. 30 CONTINUE
  341. ELSE
  342. IOFF = IZERO
  343. DO 40 I = 1, IZERO - 1
  344. A( IOFF ) = ZERO
  345. IOFF = IOFF + LDA
  346. 40 CONTINUE
  347. IOFF = IOFF - IZERO
  348. DO 50 I = IZERO, N
  349. A( IOFF+I ) = ZERO
  350. 50 CONTINUE
  351. END IF
  352. ELSE
  353. IOFF = 0
  354. IF( IUPLO.EQ.1 ) THEN
  355. *
  356. * Set the first IZERO rows and columns to zero.
  357. *
  358. DO 70 J = 1, N
  359. I2 = MIN( J, IZERO )
  360. DO 60 I = 1, I2
  361. A( IOFF+I ) = ZERO
  362. 60 CONTINUE
  363. IOFF = IOFF + LDA
  364. 70 CONTINUE
  365. ELSE
  366. *
  367. * Set the last IZERO rows and columns to zero.
  368. *
  369. DO 90 J = 1, N
  370. I1 = MAX( J, IZERO )
  371. DO 80 I = I1, N
  372. A( IOFF+I ) = ZERO
  373. 80 CONTINUE
  374. IOFF = IOFF + LDA
  375. 90 CONTINUE
  376. END IF
  377. END IF
  378. ELSE
  379. IZERO = 0
  380. END IF
  381. *
  382. * End generate the test matrix A.
  383. *
  384. DO 150 IFACT = 1, NFACT
  385. *
  386. * Do first for FACT = 'F', then for other values.
  387. *
  388. FACT = FACTS( IFACT )
  389. *
  390. * Compute the condition number
  391. *
  392. IF( ZEROT ) THEN
  393. IF( IFACT.EQ.1 )
  394. $ GO TO 150
  395. RCONDC = ZERO
  396. *
  397. ELSE IF( IFACT.EQ.1 ) THEN
  398. *
  399. * Compute the 1-norm of A.
  400. *
  401. ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
  402. *
  403. * Factor the matrix A.
  404. *
  405. CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
  406. CALL SSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK,
  407. $ LWORK, INFO )
  408. *
  409. * Compute inv(A) and take its norm.
  410. *
  411. CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
  412. LWORK = (N+NB+1)*(NB+3)
  413. *
  414. * We need to copute the invesrse to compute
  415. * RCONDC that is used later in TEST3.
  416. *
  417. CALL SSYTRI_3( UPLO, N, AINV, LDA, E, IWORK,
  418. $ WORK, LWORK, INFO )
  419. AINVNM = SLANSY( '1', UPLO, N, AINV, LDA, RWORK )
  420. *
  421. * Compute the 1-norm condition number of A.
  422. *
  423. IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
  424. RCONDC = ONE
  425. ELSE
  426. RCONDC = ( ONE / ANORM ) / AINVNM
  427. END IF
  428. END IF
  429. *
  430. * Form an exact solution and set the right hand side.
  431. *
  432. SRNAMT = 'SLARHS'
  433. CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
  434. $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
  435. $ INFO )
  436. XTYPE = 'C'
  437. *
  438. * --- Test SSYSV_RK ---
  439. *
  440. IF( IFACT.EQ.2 ) THEN
  441. CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
  442. CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
  443. *
  444. * Factor the matrix and solve the system using
  445. * SSYSV_RK.
  446. *
  447. SRNAMT = 'SSYSV_RK'
  448. CALL SSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
  449. $ X, LDA, WORK, LWORK, INFO )
  450. *
  451. * Adjust the expected value of INFO to account for
  452. * pivoting.
  453. *
  454. K = IZERO
  455. IF( K.GT.0 ) THEN
  456. 100 CONTINUE
  457. IF( IWORK( K ).LT.0 ) THEN
  458. IF( IWORK( K ).NE.-K ) THEN
  459. K = -IWORK( K )
  460. GO TO 100
  461. END IF
  462. ELSE IF( IWORK( K ).NE.K ) THEN
  463. K = IWORK( K )
  464. GO TO 100
  465. END IF
  466. END IF
  467. *
  468. * Check error code from SSYSV_RK and handle error.
  469. *
  470. IF( INFO.NE.K ) THEN
  471. CALL ALAERH( PATH, 'SSYSV_RK', INFO, K, UPLO,
  472. $ N, N, -1, -1, NRHS, IMAT, NFAIL,
  473. $ NERRS, NOUT )
  474. GO TO 120
  475. ELSE IF( INFO.NE.0 ) THEN
  476. GO TO 120
  477. END IF
  478. *
  479. *+ TEST 1 Reconstruct matrix from factors and compute
  480. * residual.
  481. *
  482. CALL SSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E,
  483. $ IWORK, AINV, LDA, RWORK,
  484. $ RESULT( 1 ) )
  485. *
  486. *+ TEST 2 Compute residual of the computed solution.
  487. *
  488. CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
  489. CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
  490. $ LDA, RWORK, RESULT( 2 ) )
  491. *
  492. *+ TEST 3
  493. * Check solution from generated exact solution.
  494. *
  495. CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
  496. $ RESULT( 3 ) )
  497. NT = 3
  498. *
  499. * Print information about the tests that did not pass
  500. * the threshold.
  501. *
  502. DO 110 K = 1, NT
  503. IF( RESULT( K ).GE.THRESH ) THEN
  504. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  505. $ CALL ALADHD( NOUT, PATH )
  506. WRITE( NOUT, FMT = 9999 )'SSYSV_RK', UPLO,
  507. $ N, IMAT, K, RESULT( K )
  508. NFAIL = NFAIL + 1
  509. END IF
  510. 110 CONTINUE
  511. NRUN = NRUN + NT
  512. 120 CONTINUE
  513. END IF
  514. *
  515. 150 CONTINUE
  516. *
  517. 160 CONTINUE
  518. 170 CONTINUE
  519. 180 CONTINUE
  520. *
  521. * Print a summary of the results.
  522. *
  523. CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
  524. *
  525. 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
  526. $ ', test ', I2, ', ratio =', G12.5 )
  527. RETURN
  528. *
  529. * End of SDRVSY_RK
  530. *
  531. END