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.

zdrvac.f 14 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457
  1. *> \brief \b ZDRVAC
  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 ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX,
  12. * A, AFAC, B, X, WORK,
  13. * RWORK, SWORK, NOUT )
  14. *
  15. * .. Scalar Arguments ..
  16. * INTEGER NMAX, NM, NNS, NOUT
  17. * DOUBLE PRECISION THRESH
  18. * ..
  19. * .. Array Arguments ..
  20. * LOGICAL DOTYPE( * )
  21. * INTEGER MVAL( * ), NSVAL( * )
  22. * DOUBLE PRECISION RWORK( * )
  23. * COMPLEX SWORK(*)
  24. * COMPLEX*16 A( * ), AFAC( * ), B( * ),
  25. * $ WORK( * ), X( * )
  26. * ..
  27. *
  28. *
  29. *> \par Purpose:
  30. * =============
  31. *>
  32. *> \verbatim
  33. *>
  34. *> ZDRVAC tests ZCPOSV.
  35. *> \endverbatim
  36. *
  37. * Arguments:
  38. * ==========
  39. *
  40. *> \param[in] DOTYPE
  41. *> \verbatim
  42. *> DOTYPE is LOGICAL array, dimension (NTYPES)
  43. *> The matrix types to be used for testing. Matrices of type j
  44. *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
  45. *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
  46. *> \endverbatim
  47. *>
  48. *> \param[in] NM
  49. *> \verbatim
  50. *> NM is INTEGER
  51. *> The number of values of N contained in the vector MVAL.
  52. *> \endverbatim
  53. *>
  54. *> \param[in] MVAL
  55. *> \verbatim
  56. *> MVAL is INTEGER array, dimension (NM)
  57. *> The values of the matrix dimension N.
  58. *> \endverbatim
  59. *>
  60. *> \param[in] NNS
  61. *> \verbatim
  62. *> NNS is INTEGER
  63. *> The number of values of NRHS contained in the vector NSVAL.
  64. *> \endverbatim
  65. *>
  66. *> \param[in] NSVAL
  67. *> \verbatim
  68. *> NSVAL is INTEGER array, dimension (NNS)
  69. *> The values of the number of right hand sides NRHS.
  70. *> \endverbatim
  71. *>
  72. *> \param[in] THRESH
  73. *> \verbatim
  74. *> THRESH is DOUBLE PRECISION
  75. *> The threshold value for the test ratios. A result is
  76. *> included in the output file if RESULT >= THRESH. To have
  77. *> every test ratio printed, use THRESH = 0.
  78. *> \endverbatim
  79. *>
  80. *> \param[in] NMAX
  81. *> \verbatim
  82. *> NMAX is INTEGER
  83. *> The maximum value permitted for N, used in dimensioning the
  84. *> work arrays.
  85. *> \endverbatim
  86. *>
  87. *> \param[out] A
  88. *> \verbatim
  89. *> A is COMPLEX*16 array, dimension (NMAX*NMAX)
  90. *> \endverbatim
  91. *>
  92. *> \param[out] AFAC
  93. *> \verbatim
  94. *> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
  95. *> \endverbatim
  96. *>
  97. *> \param[out] B
  98. *> \verbatim
  99. *> B is COMPLEX*16 array, dimension (NMAX*NSMAX)
  100. *> \endverbatim
  101. *>
  102. *> \param[out] X
  103. *> \verbatim
  104. *> X is COMPLEX*16 array, dimension (NMAX*NSMAX)
  105. *> \endverbatim
  106. *>
  107. *> \param[out] WORK
  108. *> \verbatim
  109. *> WORK is COMPLEX*16 array, dimension
  110. *> (NMAX*max(3,NSMAX))
  111. *> \endverbatim
  112. *>
  113. *> \param[out] RWORK
  114. *> \verbatim
  115. *> RWORK is DOUBLE PRECISION array, dimension
  116. *> (max(2*NMAX,2*NSMAX+NWORK))
  117. *> \endverbatim
  118. *>
  119. *> \param[out] SWORK
  120. *> \verbatim
  121. *> SWORK is COMPLEX array, dimension
  122. *> (NMAX*(NSMAX+NMAX))
  123. *> \endverbatim
  124. *>
  125. *> \param[in] NOUT
  126. *> \verbatim
  127. *> NOUT is INTEGER
  128. *> The unit number for output.
  129. *> \endverbatim
  130. *
  131. * Authors:
  132. * ========
  133. *
  134. *> \author Univ. of Tennessee
  135. *> \author Univ. of California Berkeley
  136. *> \author Univ. of Colorado Denver
  137. *> \author NAG Ltd.
  138. *
  139. *> \ingroup complex16_lin
  140. *
  141. * =====================================================================
  142. SUBROUTINE ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX,
  143. $ A, AFAC, B, X, WORK,
  144. $ RWORK, SWORK, NOUT )
  145. *
  146. * -- LAPACK test routine --
  147. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  148. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  149. *
  150. * .. Scalar Arguments ..
  151. INTEGER NMAX, NM, NNS, NOUT
  152. DOUBLE PRECISION THRESH
  153. * ..
  154. * .. Array Arguments ..
  155. LOGICAL DOTYPE( * )
  156. INTEGER MVAL( * ), NSVAL( * )
  157. DOUBLE PRECISION RWORK( * )
  158. COMPLEX SWORK(*)
  159. COMPLEX*16 A( * ), AFAC( * ), B( * ),
  160. $ WORK( * ), X( * )
  161. * ..
  162. *
  163. * =====================================================================
  164. *
  165. * .. Parameters ..
  166. DOUBLE PRECISION ZERO
  167. PARAMETER ( ZERO = 0.0D+0 )
  168. INTEGER NTYPES
  169. PARAMETER ( NTYPES = 9 )
  170. INTEGER NTESTS
  171. PARAMETER ( NTESTS = 1 )
  172. * ..
  173. * .. Local Scalars ..
  174. LOGICAL ZEROT
  175. CHARACTER DIST, TYPE, UPLO, XTYPE
  176. CHARACTER*3 PATH
  177. INTEGER I, IM, IMAT, INFO, IOFF, IRHS, IUPLO,
  178. $ IZERO, KL, KU, LDA, MODE, N,
  179. $ NERRS, NFAIL, NIMAT, NRHS, NRUN
  180. DOUBLE PRECISION ANORM, CNDNUM
  181. * ..
  182. * .. Local Arrays ..
  183. CHARACTER UPLOS( 2 )
  184. INTEGER ISEED( 4 ), ISEEDY( 4 )
  185. DOUBLE PRECISION RESULT( NTESTS )
  186. * ..
  187. * .. Local Variables ..
  188. INTEGER ITER, KASE
  189. * ..
  190. * .. External Subroutines ..
  191. EXTERNAL ALAERH, ZLACPY, ZLAIPD,
  192. $ ZLARHS, ZLATB4, ZLATMS,
  193. $ ZPOT06, ZCPOSV
  194. * ..
  195. * .. Intrinsic Functions ..
  196. INTRINSIC DBLE, MAX, SQRT
  197. * ..
  198. * .. Scalars in Common ..
  199. LOGICAL LERR, OK
  200. CHARACTER*32 SRNAMT
  201. INTEGER INFOT, NUNIT
  202. * ..
  203. * .. Common blocks ..
  204. COMMON / INFOC / INFOT, NUNIT, OK, LERR
  205. COMMON / SRNAMC / SRNAMT
  206. * ..
  207. * .. Data statements ..
  208. DATA ISEEDY / 1988, 1989, 1990, 1991 /
  209. DATA UPLOS / 'U', 'L' /
  210. * ..
  211. * .. Executable Statements ..
  212. *
  213. * Initialize constants and the random number seed.
  214. *
  215. KASE = 0
  216. PATH( 1: 1 ) = 'Zomplex precision'
  217. PATH( 2: 3 ) = 'PO'
  218. NRUN = 0
  219. NFAIL = 0
  220. NERRS = 0
  221. DO 10 I = 1, 4
  222. ISEED( I ) = ISEEDY( I )
  223. 10 CONTINUE
  224. *
  225. INFOT = 0
  226. *
  227. * Do for each value of N in MVAL
  228. *
  229. DO 120 IM = 1, NM
  230. N = MVAL( IM )
  231. LDA = MAX( N, 1 )
  232. NIMAT = NTYPES
  233. IF( N.LE.0 )
  234. $ NIMAT = 1
  235. *
  236. DO 110 IMAT = 1, NIMAT
  237. *
  238. * Do the tests only if DOTYPE( IMAT ) is true.
  239. *
  240. IF( .NOT.DOTYPE( IMAT ) )
  241. $ GO TO 110
  242. *
  243. * Skip types 3, 4, or 5 if the matrix size is too small.
  244. *
  245. ZEROT = IMAT.GE.3 .AND. IMAT.LE.5
  246. IF( ZEROT .AND. N.LT.IMAT-2 )
  247. $ GO TO 110
  248. *
  249. * Do first for UPLO = 'U', then for UPLO = 'L'
  250. *
  251. DO 100 IUPLO = 1, 2
  252. UPLO = UPLOS( IUPLO )
  253. *
  254. * Set up parameters with ZLATB4 and generate a test matrix
  255. * with ZLATMS.
  256. *
  257. CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
  258. $ CNDNUM, DIST )
  259. *
  260. SRNAMT = 'ZLATMS'
  261. CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
  262. $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
  263. $ INFO )
  264. *
  265. * Check error code from ZLATMS.
  266. *
  267. IF( INFO.NE.0 ) THEN
  268. CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1,
  269. $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
  270. GO TO 100
  271. END IF
  272. *
  273. * For types 3-5, zero one row and column of the matrix to
  274. * test that INFO is returned correctly.
  275. *
  276. IF( ZEROT ) THEN
  277. IF( IMAT.EQ.3 ) THEN
  278. IZERO = 1
  279. ELSE IF( IMAT.EQ.4 ) THEN
  280. IZERO = N
  281. ELSE
  282. IZERO = N / 2 + 1
  283. END IF
  284. IOFF = ( IZERO-1 )*LDA
  285. *
  286. * Set row and column IZERO of A to 0.
  287. *
  288. IF( IUPLO.EQ.1 ) THEN
  289. DO 20 I = 1, IZERO - 1
  290. A( IOFF+I ) = ZERO
  291. 20 CONTINUE
  292. IOFF = IOFF + IZERO
  293. DO 30 I = IZERO, N
  294. A( IOFF ) = ZERO
  295. IOFF = IOFF + LDA
  296. 30 CONTINUE
  297. ELSE
  298. IOFF = IZERO
  299. DO 40 I = 1, IZERO - 1
  300. A( IOFF ) = ZERO
  301. IOFF = IOFF + LDA
  302. 40 CONTINUE
  303. IOFF = IOFF - IZERO
  304. DO 50 I = IZERO, N
  305. A( IOFF+I ) = ZERO
  306. 50 CONTINUE
  307. END IF
  308. ELSE
  309. IZERO = 0
  310. END IF
  311. *
  312. * Set the imaginary part of the diagonals.
  313. *
  314. CALL ZLAIPD( N, A, LDA+1, 0 )
  315. *
  316. DO 60 IRHS = 1, NNS
  317. NRHS = NSVAL( IRHS )
  318. XTYPE = 'N'
  319. *
  320. * Form an exact solution and set the right hand side.
  321. *
  322. SRNAMT = 'ZLARHS'
  323. CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
  324. $ NRHS, A, LDA, X, LDA, B, LDA,
  325. $ ISEED, INFO )
  326. *
  327. * Compute the L*L' or U'*U factorization of the
  328. * matrix and solve the system.
  329. *
  330. SRNAMT = 'ZCPOSV '
  331. KASE = KASE + 1
  332. *
  333. CALL ZLACPY( 'All', N, N, A, LDA, AFAC, LDA)
  334. *
  335. CALL ZCPOSV( UPLO, N, NRHS, AFAC, LDA, B, LDA, X, LDA,
  336. $ WORK, SWORK, RWORK, ITER, INFO )
  337. *
  338. IF (ITER.LT.0) THEN
  339. CALL ZLACPY( 'All', N, N, A, LDA, AFAC, LDA )
  340. ENDIF
  341. *
  342. * Check error code from ZCPOSV .
  343. *
  344. IF( INFO.NE.IZERO ) THEN
  345. *
  346. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  347. $ CALL ALAHD( NOUT, PATH )
  348. NERRS = NERRS + 1
  349. *
  350. IF( INFO.NE.IZERO .AND. IZERO.NE.0 ) THEN
  351. WRITE( NOUT, FMT = 9988 )'ZCPOSV',INFO,IZERO,N,
  352. $ IMAT
  353. ELSE
  354. WRITE( NOUT, FMT = 9975 )'ZCPOSV',INFO,N,IMAT
  355. END IF
  356. END IF
  357. *
  358. * Skip the remaining test if the matrix is singular.
  359. *
  360. IF( INFO.NE.0 )
  361. $ GO TO 110
  362. *
  363. * Check the quality of the solution
  364. *
  365. CALL ZLACPY( 'All', N, NRHS, B, LDA, WORK, LDA )
  366. *
  367. CALL ZPOT06( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
  368. $ LDA, RWORK, RESULT( 1 ) )
  369. *
  370. * Check if the test passes the tesing.
  371. * Print information about the tests that did not
  372. * pass the testing.
  373. *
  374. * If iterative refinement has been used and claimed to
  375. * be successful (ITER>0), we want
  376. * NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1
  377. *
  378. * If double precision has been used (ITER<0), we want
  379. * NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES
  380. * (Cf. the linear solver testing routines)
  381. *
  382. IF ((THRESH.LE.0.0E+00)
  383. $ .OR.((ITER.GE.0).AND.(N.GT.0)
  384. $ .AND.(RESULT(1).GE.SQRT(DBLE(N))))
  385. $ .OR.((ITER.LT.0).AND.(RESULT(1).GE.THRESH))) THEN
  386. *
  387. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN
  388. WRITE( NOUT, FMT = 8999 )'ZPO'
  389. WRITE( NOUT, FMT = '( '' Matrix types:'' )' )
  390. WRITE( NOUT, FMT = 8979 )
  391. WRITE( NOUT, FMT = '( '' Test ratios:'' )' )
  392. WRITE( NOUT, FMT = 8960 )1
  393. WRITE( NOUT, FMT = '( '' Messages:'' )' )
  394. END IF
  395. *
  396. WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT, 1,
  397. $ RESULT( 1 )
  398. *
  399. NFAIL = NFAIL + 1
  400. *
  401. END IF
  402. *
  403. NRUN = NRUN + 1
  404. *
  405. 60 CONTINUE
  406. 100 CONTINUE
  407. 110 CONTINUE
  408. 120 CONTINUE
  409. *
  410. * Print a summary of the results.
  411. *
  412. IF( NFAIL.GT.0 ) THEN
  413. WRITE( NOUT, FMT = 9996 )'ZCPOSV', NFAIL, NRUN
  414. ELSE
  415. WRITE( NOUT, FMT = 9995 )'ZCPOSV', NRUN
  416. END IF
  417. IF( NERRS.GT.0 ) THEN
  418. WRITE( NOUT, FMT = 9994 )NERRS
  419. END IF
  420. *
  421. 9998 FORMAT( ' UPLO=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
  422. $ I2, ', test(', I2, ') =', G12.5 )
  423. 9996 FORMAT( 1X, A6, ': ', I6, ' out of ', I6,
  424. $ ' tests failed to pass the threshold' )
  425. 9995 FORMAT( /1X, 'All tests for ', A6,
  426. $ ' routines passed the threshold ( ', I6, ' tests run)' )
  427. 9994 FORMAT( 6X, I6, ' error messages recorded' )
  428. *
  429. * SUBNAM, INFO, INFOE, N, IMAT
  430. *
  431. 9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
  432. $ I5, / ' ==> N =', I5, ', type ',
  433. $ I2 )
  434. *
  435. * SUBNAM, INFO, N, IMAT
  436. *
  437. 9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5,
  438. $ ', type ', I2 )
  439. 8999 FORMAT( / 1X, A3, ': positive definite dense matrices' )
  440. 8979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X,
  441. $ '2. Upper triangular', 16X,
  442. $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
  443. $ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS',
  444. $ / 4X, '4. Random, CNDNUM = 2', 13X,
  445. $ '10. Scaled near underflow', / 4X, '5. First column zero',
  446. $ 14X, '11. Scaled near overflow', / 4X,
  447. $ '6. Last column zero' )
  448. 8960 FORMAT( 3X, I2, ': norm_1( B - A * X ) / ',
  449. $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF',
  450. $ / 4x, 'or norm_1( B - A * X ) / ',
  451. $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if ZPOTRF' )
  452. RETURN
  453. *
  454. * End of ZDRVAC
  455. *
  456. END