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

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358
  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. *> \date June 2017
  110. *
  111. *> \ingroup complex16_lin
  112. *
  113. * =====================================================================
  114. SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
  115. + LDA, D_WORK_ZLANGE )
  116. *
  117. * -- LAPACK test routine (version 3.7.1) --
  118. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  119. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  120. * June 2017
  121. *
  122. * .. Scalar Arguments ..
  123. INTEGER LDA, LDC, NN, NOUT
  124. DOUBLE PRECISION THRESH
  125. * ..
  126. * .. Array Arguments ..
  127. INTEGER NVAL( NN )
  128. DOUBLE PRECISION D_WORK_ZLANGE( * )
  129. COMPLEX*16 A( LDA, * ), C1( LDC, * ), C2( LDC, *),
  130. + CRF( * )
  131. * ..
  132. *
  133. * =====================================================================
  134. * ..
  135. * .. Parameters ..
  136. DOUBLE PRECISION ZERO, ONE
  137. PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
  138. INTEGER NTESTS
  139. PARAMETER ( NTESTS = 1 )
  140. * ..
  141. * .. Local Scalars ..
  142. CHARACTER UPLO, CFORM, TRANS
  143. INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N,
  144. + NFAIL, NRUN, IALPHA, ITRANS
  145. DOUBLE PRECISION ALPHA, BETA, EPS, NORMA, NORMC
  146. * ..
  147. * .. Local Arrays ..
  148. CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
  149. INTEGER ISEED( 4 ), ISEEDY( 4 )
  150. DOUBLE PRECISION RESULT( NTESTS )
  151. * ..
  152. * .. External Functions ..
  153. DOUBLE PRECISION DLAMCH, DLARND, ZLANGE
  154. COMPLEX*16 ZLARND
  155. EXTERNAL DLAMCH, DLARND, ZLANGE, ZLARND
  156. * ..
  157. * .. External Subroutines ..
  158. EXTERNAL ZHERK, ZHFRK, ZTFTTR, ZTRTTF
  159. * ..
  160. * .. Intrinsic Functions ..
  161. INTRINSIC DABS, MAX
  162. * ..
  163. * .. Scalars in Common ..
  164. CHARACTER*32 SRNAMT
  165. * ..
  166. * .. Common blocks ..
  167. COMMON / SRNAMC / SRNAMT
  168. * ..
  169. * .. Data statements ..
  170. DATA ISEEDY / 1988, 1989, 1990, 1991 /
  171. DATA UPLOS / 'U', 'L' /
  172. DATA FORMS / 'N', 'C' /
  173. DATA TRANSS / 'N', 'C' /
  174. * ..
  175. * .. Executable Statements ..
  176. *
  177. * Initialize constants and the random number seed.
  178. *
  179. NRUN = 0
  180. NFAIL = 0
  181. INFO = 0
  182. DO 10 I = 1, 4
  183. ISEED( I ) = ISEEDY( I )
  184. 10 CONTINUE
  185. EPS = DLAMCH( 'Precision' )
  186. *
  187. DO 150 IIN = 1, NN
  188. *
  189. N = NVAL( IIN )
  190. *
  191. DO 140 IIK = 1, NN
  192. *
  193. K = NVAL( IIN )
  194. *
  195. DO 130 IFORM = 1, 2
  196. *
  197. CFORM = FORMS( IFORM )
  198. *
  199. DO 120 IUPLO = 1, 2
  200. *
  201. UPLO = UPLOS( IUPLO )
  202. *
  203. DO 110 ITRANS = 1, 2
  204. *
  205. TRANS = TRANSS( ITRANS )
  206. *
  207. DO 100 IALPHA = 1, 4
  208. *
  209. IF ( IALPHA.EQ. 1) THEN
  210. ALPHA = ZERO
  211. BETA = ZERO
  212. ELSE IF ( IALPHA.EQ. 2) THEN
  213. ALPHA = ONE
  214. BETA = ZERO
  215. ELSE IF ( IALPHA.EQ. 3) THEN
  216. ALPHA = ZERO
  217. BETA = ONE
  218. ELSE
  219. ALPHA = DLARND( 2, ISEED )
  220. BETA = DLARND( 2, ISEED )
  221. END IF
  222. *
  223. * All the parameters are set:
  224. * CFORM, UPLO, TRANS, M, N,
  225. * ALPHA, and BETA
  226. * READY TO TEST!
  227. *
  228. NRUN = NRUN + 1
  229. *
  230. IF ( ITRANS.EQ.1 ) THEN
  231. *
  232. * In this case we are NOTRANS, so A is N-by-K
  233. *
  234. DO J = 1, K
  235. DO I = 1, N
  236. A( I, J) = ZLARND( 4, ISEED )
  237. END DO
  238. END DO
  239. *
  240. NORMA = ZLANGE( 'I', N, K, A, LDA,
  241. + D_WORK_ZLANGE )
  242. *
  243. ELSE
  244. *
  245. * In this case we are TRANS, so A is K-by-N
  246. *
  247. DO J = 1,N
  248. DO I = 1, K
  249. A( I, J) = ZLARND( 4, ISEED )
  250. END DO
  251. END DO
  252. *
  253. NORMA = ZLANGE( 'I', K, N, A, LDA,
  254. + D_WORK_ZLANGE )
  255. *
  256. END IF
  257. *
  258. *
  259. * Generate C1 our N--by--N Hermitian matrix.
  260. * Make sure C2 has the same upper/lower part,
  261. * (the one that we do not touch), so
  262. * copy the initial C1 in C2 in it.
  263. *
  264. DO J = 1, N
  265. DO I = 1, N
  266. C1( I, J) = ZLARND( 4, ISEED )
  267. C2(I,J) = C1(I,J)
  268. END DO
  269. END DO
  270. *
  271. * (See comment later on for why we use ZLANGE and
  272. * not ZLANHE for C1.)
  273. *
  274. NORMC = ZLANGE( 'I', N, N, C1, LDC,
  275. + D_WORK_ZLANGE )
  276. *
  277. SRNAMT = 'ZTRTTF'
  278. CALL ZTRTTF( CFORM, UPLO, N, C1, LDC, CRF,
  279. + INFO )
  280. *
  281. * call zherk the BLAS routine -> gives C1
  282. *
  283. SRNAMT = 'ZHERK '
  284. CALL ZHERK( UPLO, TRANS, N, K, ALPHA, A, LDA,
  285. + BETA, C1, LDC )
  286. *
  287. * call zhfrk the RFP routine -> gives CRF
  288. *
  289. SRNAMT = 'ZHFRK '
  290. CALL ZHFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A,
  291. + LDA, BETA, CRF )
  292. *
  293. * convert CRF in full format -> gives C2
  294. *
  295. SRNAMT = 'ZTFTTR'
  296. CALL ZTFTTR( CFORM, UPLO, N, CRF, C2, LDC,
  297. + INFO )
  298. *
  299. * compare C1 and C2
  300. *
  301. DO J = 1, N
  302. DO I = 1, N
  303. C1(I,J) = C1(I,J)-C2(I,J)
  304. END DO
  305. END DO
  306. *
  307. * Yes, C1 is Hermitian so we could call ZLANHE,
  308. * but we want to check the upper part that is
  309. * supposed to be unchanged and the diagonal that
  310. * is supposed to be real -> ZLANGE
  311. *
  312. RESULT(1) = ZLANGE( 'I', N, N, C1, LDC,
  313. + D_WORK_ZLANGE )
  314. RESULT(1) = RESULT(1)
  315. + / MAX( DABS( ALPHA ) * NORMA * NORMA
  316. + + DABS( BETA ) * NORMC, ONE )
  317. + / MAX( N , 1 ) / EPS
  318. *
  319. IF( RESULT(1).GE.THRESH ) THEN
  320. IF( NFAIL.EQ.0 ) THEN
  321. WRITE( NOUT, * )
  322. WRITE( NOUT, FMT = 9999 )
  323. END IF
  324. WRITE( NOUT, FMT = 9997 ) 'ZHFRK',
  325. + CFORM, UPLO, TRANS, N, K, RESULT(1)
  326. NFAIL = NFAIL + 1
  327. END IF
  328. *
  329. 100 CONTINUE
  330. 110 CONTINUE
  331. 120 CONTINUE
  332. 130 CONTINUE
  333. 140 CONTINUE
  334. 150 CONTINUE
  335. *
  336. * Print a summary of the results.
  337. *
  338. IF ( NFAIL.EQ.0 ) THEN
  339. WRITE( NOUT, FMT = 9996 ) 'ZHFRK', NRUN
  340. ELSE
  341. WRITE( NOUT, FMT = 9995 ) 'ZHFRK', NFAIL, NRUN
  342. END IF
  343. *
  344. 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing ZHFRK
  345. + ***')
  346. 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',',
  347. + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3,
  348. + ', test=',G12.5)
  349. 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ',
  350. + 'threshold ( ',I6,' tests run)')
  351. 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I6,' out of ',I6,
  352. + ' tests failed to pass the threshold')
  353. *
  354. RETURN
  355. *
  356. * End of ZDRVRF4
  357. *
  358. END