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.

cchkqp3rk.f 30 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836
  1. *> \brief \b CCHKQP3RK
  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 CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
  12. * $ NNB, NBVAL, NXVAL, THRESH, A, COPYA,
  13. * $ B, COPYB, S, TAU,
  14. * $ WORK, RWORK, IWORK, NOUT )
  15. * IMPLICIT NONE
  16. *
  17. * .. Scalar Arguments ..
  18. * INTEGER NM, NN, NNB, NOUT
  19. * REAL THRESH
  20. * ..
  21. * .. Array Arguments ..
  22. * LOGICAL DOTYPE( * )
  23. * INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
  24. * $ NXVAL( * )
  25. * REAL S( * ), RWORK( * )
  26. * COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * )
  27. * ..
  28. *
  29. *
  30. *> \par Purpose:
  31. * =============
  32. *>
  33. *> \verbatim
  34. *>
  35. *> CCHKQP3RK tests CGEQP3RK.
  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] NM
  50. *> \verbatim
  51. *> NM is INTEGER
  52. *> The number of values of M contained in the vector MVAL.
  53. *> \endverbatim
  54. *>
  55. *> \param[in] MVAL
  56. *> \verbatim
  57. *> MVAL is INTEGER array, dimension (NM)
  58. *> The values of the matrix row dimension M.
  59. *> \endverbatim
  60. *>
  61. *> \param[in] NN
  62. *> \verbatim
  63. *> NN is INTEGER
  64. *> The number of values of N contained in the vector NVAL.
  65. *> \endverbatim
  66. *>
  67. *> \param[in] NVAL
  68. *> \verbatim
  69. *> NVAL is INTEGER array, dimension (NN)
  70. *> The values of the matrix column dimension N.
  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. *> \param[in] NNB
  85. *> \verbatim
  86. *> NNB is INTEGER
  87. *> The number of values of NB and NX contained in the
  88. *> vectors NBVAL and NXVAL. The blocking parameters are used
  89. *> in pairs (NB,NX).
  90. *> \endverbatim
  91. *>
  92. *> \param[in] NBVAL
  93. *> \verbatim
  94. *> NBVAL is INTEGER array, dimension (NNB)
  95. *> The values of the blocksize NB.
  96. *> \endverbatim
  97. *>
  98. *> \param[in] NXVAL
  99. *> \verbatim
  100. *> NXVAL is INTEGER array, dimension (NNB)
  101. *> The values of the crossover point NX.
  102. *> \endverbatim
  103. *>
  104. *> \param[in] THRESH
  105. *> \verbatim
  106. *> THRESH is REAL
  107. *> The threshold value for the test ratios. A result is
  108. *> included in the output file if RESULT >= THRESH. To have
  109. *> every test ratio printed, use THRESH = 0.
  110. *> \endverbatim
  111. *>
  112. *> \param[out] A
  113. *> \verbatim
  114. *> A is COMPLEX array, dimension (MMAX*NMAX)
  115. *> where MMAX is the maximum value of M in MVAL and NMAX is the
  116. *> maximum value of N in NVAL.
  117. *> \endverbatim
  118. *>
  119. *> \param[out] COPYA
  120. *> \verbatim
  121. *> COPYA is COMPLEX array, dimension (MMAX*NMAX)
  122. *> \endverbatim
  123. *>
  124. *> \param[out] B
  125. *> \verbatim
  126. *> B is COMPLEX array, dimension (MMAX*NSMAX)
  127. *> where MMAX is the maximum value of M in MVAL and NSMAX is the
  128. *> maximum value of NRHS in NSVAL.
  129. *> \endverbatim
  130. *>
  131. *> \param[out] COPYB
  132. *> \verbatim
  133. *> COPYB is COMPLEX array, dimension (MMAX*NSMAX)
  134. *> \endverbatim
  135. *>
  136. *> \param[out] S
  137. *> \verbatim
  138. *> S is REAL array, dimension
  139. *> (min(MMAX,NMAX))
  140. *> \endverbatim
  141. *>
  142. *> \param[out] TAU
  143. *> \verbatim
  144. *> TAU is COMPLEX array, dimension (MMAX)
  145. *> \endverbatim
  146. *>
  147. *> \param[out] WORK
  148. *> \verbatim
  149. *> WORK is COMPLEX array, dimension
  150. *> (max(M*max(M,N) + 4*min(M,N) + max(M,N)))
  151. *> \endverbatim
  152. *>
  153. *> \param[out] RWORK
  154. *> \verbatim
  155. *> RWORK is REAL array, dimension (4*NMAX)
  156. *> \endverbatim
  157. *>
  158. *> \param[out] IWORK
  159. *> \verbatim
  160. *> IWORK is INTEGER array, dimension (2*NMAX)
  161. *> \endverbatim
  162. *>
  163. *> \param[in] NOUT
  164. *> \verbatim
  165. *> NOUT is INTEGER
  166. *> The unit number for output.
  167. *> \endverbatim
  168. *
  169. * Authors:
  170. * ========
  171. *
  172. *> \author Univ. of Tennessee
  173. *> \author Univ. of California Berkeley
  174. *> \author Univ. of Colorado Denver
  175. *> \author NAG Ltd.
  176. *
  177. *> \ingroup complex_lin
  178. *
  179. * =====================================================================
  180. SUBROUTINE CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
  181. $ NNB, NBVAL, NXVAL, THRESH, A, COPYA,
  182. $ B, COPYB, S, TAU,
  183. $ WORK, RWORK, IWORK, NOUT )
  184. IMPLICIT NONE
  185. *
  186. * -- LAPACK test routine --
  187. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  188. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  189. *
  190. * .. Scalar Arguments ..
  191. INTEGER NM, NN, NNB, NNS, NOUT
  192. REAL THRESH
  193. * ..
  194. * .. Array Arguments ..
  195. LOGICAL DOTYPE( * )
  196. INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ),
  197. $ NSVAL( * ), NXVAL( * )
  198. REAL S( * ), RWORK( * )
  199. COMPLEX A( * ), COPYA( * ), B( * ), COPYB( * ),
  200. $ TAU( * ), WORK( * )
  201. * ..
  202. *
  203. * =====================================================================
  204. *
  205. * .. Parameters ..
  206. INTEGER NTYPES
  207. PARAMETER ( NTYPES = 19 )
  208. INTEGER NTESTS
  209. PARAMETER ( NTESTS = 5 )
  210. REAL ONE, ZERO, BIGNUM
  211. COMPLEX CONE, CZERO
  212. PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0,
  213. $ CZERO = ( 0.0E+0, 0.0E+0 ),
  214. $ CONE = ( 1.0E+0, 0.0E+0 ),
  215. $ BIGNUM = 1.0E+38 )
  216. * ..
  217. * .. Local Scalars ..
  218. CHARACTER DIST, TYPE
  219. CHARACTER*3 PATH
  220. INTEGER I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO,
  221. $ INB, IND_OFFSET_GEN,
  222. $ IND_IN, IND_OUT, INS, INFO,
  223. $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO,
  224. $ KFACT, KL, KMAX, KU, LDA, LW, LWORK,
  225. $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N,
  226. $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS,
  227. $ NRUN, NX, T
  228. REAL ANORM, CNDNUM, EPS, ABSTOL, RELTOL,
  229. $ DTEMP, MAXC2NRMK, RELMAXC2NRMK
  230. * ..
  231. * .. Local Arrays ..
  232. INTEGER ISEED( 4 ), ISEEDY( 4 )
  233. REAL RESULT( NTESTS ), RDUMMY( 1 )
  234. * ..
  235. * .. External Functions ..
  236. REAL SLAMCH, CQPT01, CQRT11, CQRT12, CLANGE
  237. EXTERNAL SLAMCH, CQPT01, CQRT11, CQRT12, CLANGE
  238. * ..
  239. * .. External Subroutines ..
  240. EXTERNAL ALAERH, ALAHD, ALASUM, SLAORD, ICOPY, CAXPY,
  241. $ XLAENV, CGEQP3RK, CLACPY, CLASET, CLATB4,
  242. $ CLATMS, CUNMQR, CSWAP
  243. * ..
  244. * .. Intrinsic Functions ..
  245. INTRINSIC ABS, MAX, MIN, MOD, REAL
  246. * ..
  247. * .. Scalars in Common ..
  248. LOGICAL LERR, OK
  249. CHARACTER*32 SRNAMT
  250. INTEGER INFOT, IOUNIT, CUNMQR_LWORK
  251. * ..
  252. * .. Common blocks ..
  253. COMMON / INFOC / INFOT, IOUNIT, OK, LERR
  254. COMMON / SRNAMC / SRNAMT
  255. * ..
  256. * .. Data statements ..
  257. DATA ISEEDY / 1988, 1989, 1990, 1991 /
  258. * ..
  259. * .. Executable Statements ..
  260. *
  261. * Initialize constants and the random number seed.
  262. *
  263. PATH( 1: 1 ) = 'Complex precision'
  264. PATH( 2: 3 ) = 'QK'
  265. NRUN = 0
  266. NFAIL = 0
  267. NERRS = 0
  268. DO I = 1, 4
  269. ISEED( I ) = ISEEDY( I )
  270. END DO
  271. EPS = SLAMCH( 'Epsilon' )
  272. INFOT = 0
  273. *
  274. DO IM = 1, NM
  275. *
  276. * Do for each value of M in MVAL.
  277. *
  278. M = MVAL( IM )
  279. LDA = MAX( 1, M )
  280. *
  281. DO IN = 1, NN
  282. *
  283. * Do for each value of N in NVAL.
  284. *
  285. N = NVAL( IN )
  286. MINMN = MIN( M, N )
  287. LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ),
  288. $ M*N + 2*MINMN + 4*N )
  289. *
  290. DO INS = 1, NNS
  291. NRHS = NSVAL( INS )
  292. *
  293. * Set up parameters with CLATB4 and generate
  294. * M-by-NRHS B matrix with CLATMS.
  295. * IMAT = 14:
  296. * Random matrix, CNDNUM = 2, NORM = ONE,
  297. * MODE = 3 (geometric distribution of singular values).
  298. *
  299. CALL CLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM,
  300. $ MODE, CNDNUM, DIST )
  301. *
  302. SRNAMT = 'CLATMS'
  303. CALL CLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE,
  304. $ CNDNUM, ANORM, KL, KU, 'No packing',
  305. $ COPYB, LDA, WORK, INFO )
  306. *
  307. * Check error code from CLATMS.
  308. *
  309. IF( INFO.NE.0 ) THEN
  310. CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M,
  311. $ NRHS, -1, -1, -1, 6, NFAIL, NERRS,
  312. $ NOUT )
  313. CYCLE
  314. END IF
  315. *
  316. DO IMAT = 1, NTYPES
  317. *
  318. * Do the tests only if DOTYPE( IMAT ) is true.
  319. *
  320. IF( .NOT.DOTYPE( IMAT ) )
  321. $ CYCLE
  322. *
  323. * The type of distribution used to generate the random
  324. * eigen-/singular values:
  325. * ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 )
  326. *
  327. * Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE
  328. * 1. Zero matrix
  329. * 2. Random, Diagonal, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  330. * 3. Random, Upper triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  331. * 4. Random, Lower triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  332. * 5. Random, First column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  333. * 6. Random, Last MINMN column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  334. * 7. Random, Last N column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  335. * 8. Random, Middle column in MINMN is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  336. * 9. Random, First half of MINMN columns are zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  337. * 10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  338. * 11. Random, Half MINMN columns in the middle are zero starting
  339. * from MINMN/2-(MINMN/2)/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  340. * 12. Random, Odd columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  341. * 13. Random, Even columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  342. * 14. Random, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
  343. * 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) ONE 3 ( geometric distribution of singular values )
  344. * 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS ONE 3 ( geometric distribution of singular values )
  345. * 17. Random, CNDNUM = 0.1/EPS, CNDNUM = BADC2 = 0.1/EPS ONE 2 ( one small singular value, S(N)=1/CNDNUM )
  346. * one small singular value S(N)=1/CNDNUM
  347. * 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN
  348. * 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values )
  349. *
  350. IF( IMAT.EQ.1 ) THEN
  351. *
  352. * Matrix 1: Zero matrix
  353. *
  354. CALL CLASET( 'Full', M, N, CZERO, CZERO, COPYA, LDA )
  355. DO I = 1, MINMN
  356. S( I ) = ZERO
  357. END DO
  358. *
  359. ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 )
  360. $ .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN
  361. *
  362. * Matrices 2-5.
  363. *
  364. * Set up parameters with DLATB4 and generate a test
  365. * matrix with CLATMS.
  366. *
  367. CALL CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM,
  368. $ MODE, CNDNUM, DIST )
  369. *
  370. SRNAMT = 'CLATMS'
  371. CALL CLATMS( M, N, DIST, ISEED, TYPE, S, MODE,
  372. $ CNDNUM, ANORM, KL, KU, 'No packing',
  373. $ COPYA, LDA, WORK, INFO )
  374. *
  375. * Check error code from CLATMS.
  376. *
  377. IF( INFO.NE.0 ) THEN
  378. CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M, N,
  379. $ -1, -1, -1, IMAT, NFAIL, NERRS,
  380. $ NOUT )
  381. CYCLE
  382. END IF
  383. *
  384. CALL SLAORD( 'Decreasing', MINMN, S, 1 )
  385. *
  386. ELSE IF( MINMN.GE.2
  387. $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN
  388. *
  389. * Rectangular matrices 5-13 that contain zero columns,
  390. * only for matrices MINMN >=2.
  391. *
  392. * JB_ZERO is the column index of ZERO block.
  393. * NB_ZERO is the column block size of ZERO block.
  394. * NB_GEN is the column blcok size of the
  395. * generated block.
  396. * J_INC in the non_zero column index increment
  397. * for matrix 12 and 13.
  398. * J_FIRS_NZ is the index of the first non-zero
  399. * column.
  400. *
  401. IF( IMAT.EQ.5 ) THEN
  402. *
  403. * First column is zero.
  404. *
  405. JB_ZERO = 1
  406. NB_ZERO = 1
  407. NB_GEN = N - NB_ZERO
  408. *
  409. ELSE IF( IMAT.EQ.6 ) THEN
  410. *
  411. * Last column MINMN is zero.
  412. *
  413. JB_ZERO = MINMN
  414. NB_ZERO = 1
  415. NB_GEN = N - NB_ZERO
  416. *
  417. ELSE IF( IMAT.EQ.7 ) THEN
  418. *
  419. * Last column N is zero.
  420. *
  421. JB_ZERO = N
  422. NB_ZERO = 1
  423. NB_GEN = N - NB_ZERO
  424. *
  425. ELSE IF( IMAT.EQ.8 ) THEN
  426. *
  427. * Middle column in MINMN is zero.
  428. *
  429. JB_ZERO = MINMN / 2 + 1
  430. NB_ZERO = 1
  431. NB_GEN = N - NB_ZERO
  432. *
  433. ELSE IF( IMAT.EQ.9 ) THEN
  434. *
  435. * First half of MINMN columns is zero.
  436. *
  437. JB_ZERO = 1
  438. NB_ZERO = MINMN / 2
  439. NB_GEN = N - NB_ZERO
  440. *
  441. ELSE IF( IMAT.EQ.10 ) THEN
  442. *
  443. * Last columns are zero columns,
  444. * starting from (MINMN / 2 + 1) column.
  445. *
  446. JB_ZERO = MINMN / 2 + 1
  447. NB_ZERO = N - JB_ZERO + 1
  448. NB_GEN = N - NB_ZERO
  449. *
  450. ELSE IF( IMAT.EQ.11 ) THEN
  451. *
  452. * Half of the columns in the middle of MINMN
  453. * columns is zero, starting from
  454. * MINMN/2 - (MINMN/2)/2 + 1 column.
  455. *
  456. JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1
  457. NB_ZERO = MINMN / 2
  458. NB_GEN = N - NB_ZERO
  459. *
  460. ELSE IF( IMAT.EQ.12 ) THEN
  461. *
  462. * Odd-numbered columns are zero,
  463. *
  464. NB_GEN = N / 2
  465. NB_ZERO = N - NB_GEN
  466. J_INC = 2
  467. J_FIRST_NZ = 2
  468. *
  469. ELSE IF( IMAT.EQ.13 ) THEN
  470. *
  471. * Even-numbered columns are zero.
  472. *
  473. NB_ZERO = N / 2
  474. NB_GEN = N - NB_ZERO
  475. J_INC = 2
  476. J_FIRST_NZ = 1
  477. *
  478. END IF
  479. *
  480. *
  481. * 1) Set the first NB_ZERO columns in COPYA(1:M,1:N)
  482. * to zero.
  483. *
  484. CALL CLASET( 'Full', M, NB_ZERO, CZERO, CZERO,
  485. $ COPYA, LDA )
  486. *
  487. * 2) Generate an M-by-(N-NB_ZERO) matrix with the
  488. * chosen singular value distribution
  489. * in COPYA(1:M,NB_ZERO+1:N).
  490. *
  491. CALL CLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU,
  492. $ ANORM, MODE, CNDNUM, DIST )
  493. *
  494. SRNAMT = 'CLATMS'
  495. *
  496. IND_OFFSET_GEN = NB_ZERO * LDA
  497. *
  498. CALL CLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE,
  499. $ CNDNUM, ANORM, KL, KU, 'No packing',
  500. $ COPYA( IND_OFFSET_GEN + 1 ), LDA,
  501. $ WORK, INFO )
  502. *
  503. * Check error code from CLATMS.
  504. *
  505. IF( INFO.NE.0 ) THEN
  506. CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M,
  507. $ NB_GEN, -1, -1, -1, IMAT, NFAIL,
  508. $ NERRS, NOUT )
  509. CYCLE
  510. END IF
  511. *
  512. * 3) Swap the gererated colums from the right side
  513. * NB_GEN-size block in COPYA into correct column
  514. * positions.
  515. *
  516. IF( IMAT.EQ.6
  517. $ .OR. IMAT.EQ.7
  518. $ .OR. IMAT.EQ.8
  519. $ .OR. IMAT.EQ.10
  520. $ .OR. IMAT.EQ.11 ) THEN
  521. *
  522. * Move by swapping the generated columns
  523. * from the right NB_GEN-size block from
  524. * (NB_ZERO+1:NB_ZERO+JB_ZERO)
  525. * into columns (1:JB_ZERO-1).
  526. *
  527. DO J = 1, JB_ZERO-1, 1
  528. CALL CSWAP( M,
  529. $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1,
  530. $ COPYA( (J-1)*LDA + 1 ), 1 )
  531. END DO
  532. *
  533. ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN
  534. *
  535. * ( IMAT = 12, Odd-numbered ZERO columns. )
  536. * Swap the generated columns from the right
  537. * NB_GEN-size block into the even zero colums in the
  538. * left NB_ZERO-size block.
  539. *
  540. * ( IMAT = 13, Even-numbered ZERO columns. )
  541. * Swap the generated columns from the right
  542. * NB_GEN-size block into the odd zero colums in the
  543. * left NB_ZERO-size block.
  544. *
  545. DO J = 1, NB_GEN, 1
  546. IND_OUT = ( NB_ZERO+J-1 )*LDA + 1
  547. IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA
  548. $ + 1
  549. CALL CSWAP( M,
  550. $ COPYA( IND_OUT ), 1,
  551. $ COPYA( IND_IN), 1 )
  552. END DO
  553. *
  554. END IF
  555. *
  556. * 5) Order the singular values generated by
  557. * DLAMTS in decreasing order and add trailing zeros
  558. * that correspond to zero columns.
  559. * The total number of singular values is MINMN.
  560. *
  561. MINMNB_GEN = MIN( M, NB_GEN )
  562. *
  563. CALL SLAORD( 'Decreasing', MINMNB_GEN, S, 1 )
  564. DO I = MINMNB_GEN+1, MINMN
  565. S( I ) = ZERO
  566. END DO
  567. *
  568. ELSE
  569. *
  570. * IF(MINMN.LT.2) skip this size for this matrix type.
  571. *
  572. CYCLE
  573. END IF
  574. *
  575. * Initialize a copy array for a pivot array for DGEQP3RK.
  576. *
  577. DO I = 1, N
  578. IWORK( I ) = 0
  579. END DO
  580. *
  581. DO INB = 1, NNB
  582. *
  583. * Do for each pair of values (NB,NX) in NBVAL and NXVAL.
  584. *
  585. NB = NBVAL( INB )
  586. CALL XLAENV( 1, NB )
  587. NX = NXVAL( INB )
  588. CALL XLAENV( 3, NX )
  589. *
  590. * We do MIN(M,N)+1 because we need a test for KMAX > N,
  591. * when KMAX is larger than MIN(M,N), KMAX should be
  592. * KMAX = MIN(M,N)
  593. *
  594. DO KMAX = 0, MIN(M,N)+1
  595. *
  596. * Get a working copy of COPYA into A( 1:M,1:N ).
  597. * Get a working copy of COPYB into A( 1:M, (N+1):NRHS ).
  598. * Get a working copy of COPYB into into B( 1:M, 1:NRHS ).
  599. * Get a working copy of IWORK(1:N) awith zeroes into
  600. * which is going to be used as pivot array IWORK( N+1:2N ).
  601. * NOTE: IWORK(2N+1:3N) is going to be used as a WORK array
  602. * for the routine.
  603. *
  604. CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA )
  605. CALL CLACPY( 'All', M, NRHS, COPYB, LDA,
  606. $ A( LDA*N + 1 ), LDA )
  607. CALL CLACPY( 'All', M, NRHS, COPYB, LDA,
  608. $ B, LDA )
  609. CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 )
  610. *
  611. ABSTOL = -1.0
  612. RELTOl = -1.0
  613. *
  614. * Compute the QR factorization with pivoting of A
  615. *
  616. LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ),
  617. $ 3*N + NRHS - 1 ) )
  618. *
  619. * Compute CGEQP3RK factorization of A.
  620. *
  621. SRNAMT = 'CGEQP3RK'
  622. CALL CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL,
  623. $ A, LDA, KFACT, MAXC2NRMK,
  624. $ RELMAXC2NRMK, IWORK( N+1 ), TAU,
  625. $ WORK, LW, RWORK, IWORK( 2*N+1 ),
  626. $ INFO )
  627. *
  628. * Check error code from CGEQP3RK.
  629. *
  630. IF( INFO.LT.0 )
  631. $ CALL ALAERH( PATH, 'CGEQP3RK', INFO, 0, ' ',
  632. $ M, N, NX, -1, NB, IMAT,
  633. $ NFAIL, NERRS, NOUT )
  634. *
  635. IF( KFACT.EQ.MINMN ) THEN
  636. *
  637. * Compute test 1:
  638. *
  639. * This test in only for the full rank factorization of
  640. * the matrix A.
  641. *
  642. * Array S(1:min(M,N)) contains svd(A) the sigular values
  643. * of the original matrix A in decreasing absolute value
  644. * order. The test computes svd(R), the vector sigular
  645. * values of the upper trapezoid of A(1:M,1:N) that
  646. * contains the factor R, in decreasing order. The test
  647. * returns the ratio:
  648. *
  649. * 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS )
  650. *
  651. RESULT( 1 ) = CQRT12( M, N, A, LDA, S, WORK,
  652. $ LWORK , RWORK )
  653. *
  654. DO T = 1, 1
  655. IF( RESULT( T ).GE.THRESH ) THEN
  656. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  657. $ CALL ALAHD( NOUT, PATH )
  658. WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N,
  659. $ NRHS, KMAX, ABSTOL, RELTOL, NB, NX,
  660. $ IMAT, T, RESULT( T )
  661. NFAIL = NFAIL + 1
  662. END IF
  663. END DO
  664. NRUN = NRUN + 1
  665. *
  666. * End test 1
  667. *
  668. END IF
  669. * Compute test 2:
  670. *
  671. * The test returns the ratio:
  672. *
  673. * 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS )
  674. *
  675. RESULT( 2 ) = CQPT01( M, N, KFACT, COPYA, A, LDA, TAU,
  676. $ IWORK( N+1 ), WORK, LWORK )
  677. *
  678. * Compute test 3:
  679. *
  680. * The test returns the ratio:
  681. *
  682. * 1-norm( Q**T * Q - I ) / ( M * EPS )
  683. *
  684. RESULT( 3 ) = CQRT11( M, KFACT, A, LDA, TAU, WORK,
  685. $ LWORK )
  686. *
  687. * Print information about the tests that did not pass
  688. * the threshold.
  689. *
  690. DO T = 2, 3
  691. IF( RESULT( T ).GE.THRESH ) THEN
  692. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  693. $ CALL ALAHD( NOUT, PATH )
  694. WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N,
  695. $ NRHS, KMAX, ABSTOL, RELTOL,
  696. $ NB, NX, IMAT, T, RESULT( T )
  697. NFAIL = NFAIL + 1
  698. END IF
  699. END DO
  700. NRUN = NRUN + 2
  701. *
  702. * Compute test 4:
  703. *
  704. * This test is only for the factorizations with the
  705. * rank greater than 2.
  706. * The elements on the diagonal of R should be non-
  707. * increasing.
  708. *
  709. * The test returns the ratio:
  710. *
  711. * Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)),
  712. * K=1:KFACT-1
  713. *
  714. IF( MIN(KFACT, MINMN).GE.2 ) THEN
  715. *
  716. DO J = 1, KFACT-1, 1
  717. *
  718. DTEMP = (( ABS( A( (J-1)*M+J ) ) -
  719. $ ABS( A( (J)*M+J+1 ) ) ) /
  720. $ ABS( A(1) ) )
  721. *
  722. IF( DTEMP.LT.ZERO ) THEN
  723. RESULT( 4 ) = BIGNUM
  724. END IF
  725. *
  726. END DO
  727. *
  728. * Print information about the tests that did not
  729. * pass the threshold.
  730. *
  731. DO T = 4, 4
  732. IF( RESULT( T ).GE.THRESH ) THEN
  733. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  734. $ CALL ALAHD( NOUT, PATH )
  735. WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK',
  736. $ M, N, NRHS, KMAX, ABSTOL, RELTOL,
  737. $ NB, NX, IMAT, T,
  738. $ RESULT( T )
  739. NFAIL = NFAIL + 1
  740. END IF
  741. END DO
  742. NRUN = NRUN + 1
  743. *
  744. * End test 4.
  745. *
  746. END IF
  747. *
  748. * Compute test 5:
  749. *
  750. * This test in only for matrix A with min(M,N) > 0.
  751. *
  752. * The test returns the ratio:
  753. *
  754. * 1-norm(Q**T * B - Q**T * B ) /
  755. * ( M * EPS )
  756. *
  757. * (1) Compute B:=Q**T * B in the matrix B.
  758. *
  759. IF( MINMN.GT.0 ) THEN
  760. *
  761. LWORK_MQR = MAX(1, NRHS)
  762. CALL CUNMQR( 'Left', 'Conjugate transpose',
  763. $ M, NRHS, KFACT, A, LDA, TAU, B, LDA,
  764. $ WORK, LWORK_MQR, INFO )
  765. *
  766. DO I = 1, NRHS
  767. *
  768. * Compare N+J-th column of A and J-column of B.
  769. *
  770. CALL CAXPY( M, -CONE, A( ( N+I-1 )*LDA+1 ), 1,
  771. $ B( ( I-1 )*LDA+1 ), 1 )
  772. END DO
  773. *
  774. RESULT( 5 ) =
  775. $ ABS(
  776. $ CLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) /
  777. $ ( REAL( M )*SLAMCH( 'Epsilon' ) )
  778. $ )
  779. *
  780. * Print information about the tests that did not pass
  781. * the threshold.
  782. *
  783. DO T = 5, 5
  784. IF( RESULT( T ).GE.THRESH ) THEN
  785. IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
  786. $ CALL ALAHD( NOUT, PATH )
  787. WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N,
  788. $ NRHS, KMAX, ABSTOL, RELTOL,
  789. $ NB, NX, IMAT, T, RESULT( T )
  790. NFAIL = NFAIL + 1
  791. END IF
  792. END DO
  793. NRUN = NRUN + 1
  794. *
  795. * End compute test 5.
  796. *
  797. END IF
  798. *
  799. * END DO KMAX = 1, MIN(M,N)+1
  800. *
  801. END DO
  802. *
  803. * END DO for INB = 1, NNB
  804. *
  805. END DO
  806. *
  807. * END DO for IMAT = 1, NTYPES
  808. *
  809. END DO
  810. *
  811. * END DO for INS = 1, NNS
  812. *
  813. END DO
  814. *
  815. * END DO for IN = 1, NN
  816. *
  817. END DO
  818. *
  819. * END DO for IM = 1, NM
  820. *
  821. END DO
  822. *
  823. * Print a summary of the results.
  824. *
  825. CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
  826. *
  827. 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NRHS =', I5,
  828. $ ', KMAX =', I5, ', ABSTOL =', G12.5,
  829. $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4,
  830. $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
  831. *
  832. * End of CCHKQP3RK
  833. *
  834. END