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.

zdrvrf4.f 11 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355
  1. *> \brief \b ZDRVRF4
  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 ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
  12. * + LDA, D_WORK_ZLANGE )
  13. *
  14. * .. Scalar Arguments ..
  15. * INTEGER LDA, LDC, NN, NOUT
  16. * DOUBLE PRECISION THRESH
  17. * ..
  18. * .. Array Arguments ..
  19. * INTEGER NVAL( NN )
  20. * DOUBLE PRECISION D_WORK_ZLANGE( * )
  21. * COMPLEX*16 A( LDA, * ), C1( LDC, * ), C2( LDC, *),
  22. * + CRF( * )
  23. * ..
  24. *
  25. *
  26. *> \par Purpose:
  27. * =============
  28. *>
  29. *> \verbatim
  30. *>
  31. *> ZDRVRF4 tests the LAPACK RFP routines:
  32. *> ZHFRK
  33. *> \endverbatim
  34. *
  35. * Arguments:
  36. * ==========
  37. *
  38. *> \param[in] NOUT
  39. *> \verbatim
  40. *> NOUT is INTEGER
  41. *> The unit number for output.
  42. *> \endverbatim
  43. *>
  44. *> \param[in] NN
  45. *> \verbatim
  46. *> NN is INTEGER
  47. *> The number of values of N contained in the vector NVAL.
  48. *> \endverbatim
  49. *>
  50. *> \param[in] NVAL
  51. *> \verbatim
  52. *> NVAL is INTEGER array, dimension (NN)
  53. *> The values of the matrix dimension N.
  54. *> \endverbatim
  55. *>
  56. *> \param[in] THRESH
  57. *> \verbatim
  58. *> THRESH is DOUBLE PRECISION
  59. *> The threshold value for the test ratios. A result is
  60. *> included in the output file if RESULT >= THRESH. To have
  61. *> every test ratio printed, use THRESH = 0.
  62. *> \endverbatim
  63. *>
  64. *> \param[out] C1
  65. *> \verbatim
  66. *> C1 is COMPLEX*16 array, dimension (LDC,NMAX)
  67. *> \endverbatim
  68. *>
  69. *> \param[out] C2
  70. *> \verbatim
  71. *> C2 is COMPLEX*16 array, dimension (LDC,NMAX)
  72. *> \endverbatim
  73. *>
  74. *> \param[in] LDC
  75. *> \verbatim
  76. *> LDC is INTEGER
  77. *> The leading dimension of the array A. LDA >= max(1,NMAX).
  78. *> \endverbatim
  79. *>
  80. *> \param[out] CRF
  81. *> \verbatim
  82. *> CRF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
  83. *> \endverbatim
  84. *>
  85. *> \param[out] A
  86. *> \verbatim
  87. *> A is COMPLEX*16 array, dimension (LDA,NMAX)
  88. *> \endverbatim
  89. *>
  90. *> \param[in] LDA
  91. *> \verbatim
  92. *> LDA is INTEGER
  93. *> The leading dimension of the array A. LDA >= max(1,NMAX).
  94. *> \endverbatim
  95. *>
  96. *> \param[out] D_WORK_ZLANGE
  97. *> \verbatim
  98. *> D_WORK_ZLANGE is DOUBLE PRECISION array, dimension (NMAX)
  99. *> \endverbatim
  100. *
  101. * Authors:
  102. * ========
  103. *
  104. *> \author Univ. of Tennessee
  105. *> \author Univ. of California Berkeley
  106. *> \author Univ. of Colorado Denver
  107. *> \author NAG Ltd.
  108. *
  109. *> \ingroup complex16_lin
  110. *
  111. * =====================================================================
  112. SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
  113. + LDA, D_WORK_ZLANGE )
  114. *
  115. * -- LAPACK test routine --
  116. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  117. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  118. *
  119. * .. Scalar Arguments ..
  120. INTEGER LDA, LDC, NN, NOUT
  121. DOUBLE PRECISION THRESH
  122. * ..
  123. * .. Array Arguments ..
  124. INTEGER NVAL( NN )
  125. DOUBLE PRECISION D_WORK_ZLANGE( * )
  126. COMPLEX*16 A( LDA, * ), C1( LDC, * ), C2( LDC, *),
  127. + CRF( * )
  128. * ..
  129. *
  130. * =====================================================================
  131. * ..
  132. * .. Parameters ..
  133. DOUBLE PRECISION ZERO, ONE
  134. PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
  135. INTEGER NTESTS
  136. PARAMETER ( NTESTS = 1 )
  137. * ..
  138. * .. Local Scalars ..
  139. CHARACTER UPLO, CFORM, TRANS
  140. INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N,
  141. + NFAIL, NRUN, IALPHA, ITRANS
  142. DOUBLE PRECISION ALPHA, BETA, EPS, NORMA, NORMC
  143. * ..
  144. * .. Local Arrays ..
  145. CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
  146. INTEGER ISEED( 4 ), ISEEDY( 4 )
  147. DOUBLE PRECISION RESULT( NTESTS )
  148. * ..
  149. * .. External Functions ..
  150. DOUBLE PRECISION DLAMCH, DLARND, ZLANGE
  151. COMPLEX*16 ZLARND
  152. EXTERNAL DLAMCH, DLARND, ZLANGE, ZLARND
  153. * ..
  154. * .. External Subroutines ..
  155. EXTERNAL ZHERK, ZHFRK, ZTFTTR, ZTRTTF
  156. * ..
  157. * .. Intrinsic Functions ..
  158. INTRINSIC DABS, MAX
  159. * ..
  160. * .. Scalars in Common ..
  161. CHARACTER*32 SRNAMT
  162. * ..
  163. * .. Common blocks ..
  164. COMMON / SRNAMC / SRNAMT
  165. * ..
  166. * .. Data statements ..
  167. DATA ISEEDY / 1988, 1989, 1990, 1991 /
  168. DATA UPLOS / 'U', 'L' /
  169. DATA FORMS / 'N', 'C' /
  170. DATA TRANSS / 'N', 'C' /
  171. * ..
  172. * .. Executable Statements ..
  173. *
  174. * Initialize constants and the random number seed.
  175. *
  176. NRUN = 0
  177. NFAIL = 0
  178. INFO = 0
  179. DO 10 I = 1, 4
  180. ISEED( I ) = ISEEDY( I )
  181. 10 CONTINUE
  182. EPS = DLAMCH( 'Precision' )
  183. *
  184. DO 150 IIN = 1, NN
  185. *
  186. N = NVAL( IIN )
  187. *
  188. DO 140 IIK = 1, NN
  189. *
  190. K = NVAL( IIN )
  191. *
  192. DO 130 IFORM = 1, 2
  193. *
  194. CFORM = FORMS( IFORM )
  195. *
  196. DO 120 IUPLO = 1, 2
  197. *
  198. UPLO = UPLOS( IUPLO )
  199. *
  200. DO 110 ITRANS = 1, 2
  201. *
  202. TRANS = TRANSS( ITRANS )
  203. *
  204. DO 100 IALPHA = 1, 4
  205. *
  206. IF ( IALPHA.EQ. 1) THEN
  207. ALPHA = ZERO
  208. BETA = ZERO
  209. ELSE IF ( IALPHA.EQ. 2) THEN
  210. ALPHA = ONE
  211. BETA = ZERO
  212. ELSE IF ( IALPHA.EQ. 3) THEN
  213. ALPHA = ZERO
  214. BETA = ONE
  215. ELSE
  216. ALPHA = DLARND( 2, ISEED )
  217. BETA = DLARND( 2, ISEED )
  218. END IF
  219. *
  220. * All the parameters are set:
  221. * CFORM, UPLO, TRANS, M, N,
  222. * ALPHA, and BETA
  223. * READY TO TEST!
  224. *
  225. NRUN = NRUN + 1
  226. *
  227. IF ( ITRANS.EQ.1 ) THEN
  228. *
  229. * In this case we are NOTRANS, so A is N-by-K
  230. *
  231. DO J = 1, K
  232. DO I = 1, N
  233. A( I, J) = ZLARND( 4, ISEED )
  234. END DO
  235. END DO
  236. *
  237. NORMA = ZLANGE( 'I', N, K, A, LDA,
  238. + D_WORK_ZLANGE )
  239. *
  240. ELSE
  241. *
  242. * In this case we are TRANS, so A is K-by-N
  243. *
  244. DO J = 1,N
  245. DO I = 1, K
  246. A( I, J) = ZLARND( 4, ISEED )
  247. END DO
  248. END DO
  249. *
  250. NORMA = ZLANGE( 'I', K, N, A, LDA,
  251. + D_WORK_ZLANGE )
  252. *
  253. END IF
  254. *
  255. *
  256. * Generate C1 our N--by--N Hermitian matrix.
  257. * Make sure C2 has the same upper/lower part,
  258. * (the one that we do not touch), so
  259. * copy the initial C1 in C2 in it.
  260. *
  261. DO J = 1, N
  262. DO I = 1, N
  263. C1( I, J) = ZLARND( 4, ISEED )
  264. C2(I,J) = C1(I,J)
  265. END DO
  266. END DO
  267. *
  268. * (See comment later on for why we use ZLANGE and
  269. * not ZLANHE for C1.)
  270. *
  271. NORMC = ZLANGE( 'I', N, N, C1, LDC,
  272. + D_WORK_ZLANGE )
  273. *
  274. SRNAMT = 'ZTRTTF'
  275. CALL ZTRTTF( CFORM, UPLO, N, C1, LDC, CRF,
  276. + INFO )
  277. *
  278. * call zherk the BLAS routine -> gives C1
  279. *
  280. SRNAMT = 'ZHERK '
  281. CALL ZHERK( UPLO, TRANS, N, K, ALPHA, A, LDA,
  282. + BETA, C1, LDC )
  283. *
  284. * call zhfrk the RFP routine -> gives CRF
  285. *
  286. SRNAMT = 'ZHFRK '
  287. CALL ZHFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A,
  288. + LDA, BETA, CRF )
  289. *
  290. * convert CRF in full format -> gives C2
  291. *
  292. SRNAMT = 'ZTFTTR'
  293. CALL ZTFTTR( CFORM, UPLO, N, CRF, C2, LDC,
  294. + INFO )
  295. *
  296. * compare C1 and C2
  297. *
  298. DO J = 1, N
  299. DO I = 1, N
  300. C1(I,J) = C1(I,J)-C2(I,J)
  301. END DO
  302. END DO
  303. *
  304. * Yes, C1 is Hermitian so we could call ZLANHE,
  305. * but we want to check the upper part that is
  306. * supposed to be unchanged and the diagonal that
  307. * is supposed to be real -> ZLANGE
  308. *
  309. RESULT(1) = ZLANGE( 'I', N, N, C1, LDC,
  310. + D_WORK_ZLANGE )
  311. RESULT(1) = RESULT(1)
  312. + / MAX( DABS( ALPHA ) * NORMA * NORMA
  313. + + DABS( BETA ) * NORMC, ONE )
  314. + / MAX( N , 1 ) / EPS
  315. *
  316. IF( RESULT(1).GE.THRESH ) THEN
  317. IF( NFAIL.EQ.0 ) THEN
  318. WRITE( NOUT, * )
  319. WRITE( NOUT, FMT = 9999 )
  320. END IF
  321. WRITE( NOUT, FMT = 9997 ) 'ZHFRK',
  322. + CFORM, UPLO, TRANS, N, K, RESULT(1)
  323. NFAIL = NFAIL + 1
  324. END IF
  325. *
  326. 100 CONTINUE
  327. 110 CONTINUE
  328. 120 CONTINUE
  329. 130 CONTINUE
  330. 140 CONTINUE
  331. 150 CONTINUE
  332. *
  333. * Print a summary of the results.
  334. *
  335. IF ( NFAIL.EQ.0 ) THEN
  336. WRITE( NOUT, FMT = 9996 ) 'ZHFRK', NRUN
  337. ELSE
  338. WRITE( NOUT, FMT = 9995 ) 'ZHFRK', NFAIL, NRUN
  339. END IF
  340. *
  341. 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing ZHFRK
  342. + ***')
  343. 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',',
  344. + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3,
  345. + ', test=',G12.5)
  346. 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ',
  347. + 'threshold ( ',I6,' tests run)')
  348. 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I6,' out of ',I6,
  349. + ' tests failed to pass the threshold')
  350. *
  351. RETURN
  352. *
  353. * End of ZDRVRF4
  354. *
  355. END