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.

dlavsp.f 16 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543
  1. *> \brief \b DLAVSP
  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 DLAVSP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB,
  12. * INFO )
  13. *
  14. * .. Scalar Arguments ..
  15. * CHARACTER DIAG, TRANS, UPLO
  16. * INTEGER INFO, LDB, N, NRHS
  17. * ..
  18. * .. Array Arguments ..
  19. * INTEGER IPIV( * )
  20. * DOUBLE PRECISION A( * ), B( LDB, * )
  21. * ..
  22. *
  23. *
  24. *> \par Purpose:
  25. * =============
  26. *>
  27. *> \verbatim
  28. *>
  29. *> DLAVSP performs one of the matrix-vector operations
  30. *> x := A*x or x := A'*x,
  31. *> where x is an N element vector and A is one of the factors
  32. *> from the block U*D*U' or L*D*L' factorization computed by DSPTRF.
  33. *>
  34. *> If TRANS = 'N', multiplies by U or U * D (or L or L * D)
  35. *> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L' )
  36. *> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L' )
  37. *> \endverbatim
  38. *
  39. * Arguments:
  40. * ==========
  41. *
  42. *> \param[in] UPLO
  43. *> \verbatim
  44. *> UPLO is CHARACTER*1
  45. *> Specifies whether the factor stored in A is upper or lower
  46. *> triangular.
  47. *> = 'U': Upper triangular
  48. *> = 'L': Lower triangular
  49. *> \endverbatim
  50. *>
  51. *> \param[in] TRANS
  52. *> \verbatim
  53. *> TRANS is CHARACTER*1
  54. *> Specifies the operation to be performed:
  55. *> = 'N': x := A*x
  56. *> = 'T': x := A'*x
  57. *> = 'C': x := A'*x
  58. *> \endverbatim
  59. *>
  60. *> \param[in] DIAG
  61. *> \verbatim
  62. *> DIAG is CHARACTER*1
  63. *> Specifies whether or not the diagonal blocks are unit
  64. *> matrices. If the diagonal blocks are assumed to be unit,
  65. *> then A = U or A = L, otherwise A = U*D or A = L*D.
  66. *> = 'U': Diagonal blocks are assumed to be unit matrices.
  67. *> = 'N': Diagonal blocks are assumed to be non-unit matrices.
  68. *> \endverbatim
  69. *>
  70. *> \param[in] N
  71. *> \verbatim
  72. *> N is INTEGER
  73. *> The number of rows and columns of the matrix A. N >= 0.
  74. *> \endverbatim
  75. *>
  76. *> \param[in] NRHS
  77. *> \verbatim
  78. *> NRHS is INTEGER
  79. *> The number of right hand sides, i.e., the number of vectors
  80. *> x to be multiplied by A. NRHS >= 0.
  81. *> \endverbatim
  82. *>
  83. *> \param[in] A
  84. *> \verbatim
  85. *> A is DOUBLE PRECISION array, dimension (N*(N+1)/2)
  86. *> The block diagonal matrix D and the multipliers used to
  87. *> obtain the factor U or L, stored as a packed triangular
  88. *> matrix as computed by DSPTRF.
  89. *> \endverbatim
  90. *>
  91. *> \param[in] IPIV
  92. *> \verbatim
  93. *> IPIV is INTEGER array, dimension (N)
  94. *> The pivot indices from DSPTRF.
  95. *> \endverbatim
  96. *>
  97. *> \param[in,out] B
  98. *> \verbatim
  99. *> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
  100. *> On entry, B contains NRHS vectors of length N.
  101. *> On exit, B is overwritten with the product A * B.
  102. *> \endverbatim
  103. *>
  104. *> \param[in] LDB
  105. *> \verbatim
  106. *> LDB is INTEGER
  107. *> The leading dimension of the array B. LDB >= max(1,N).
  108. *> \endverbatim
  109. *>
  110. *> \param[out] INFO
  111. *> \verbatim
  112. *> INFO is INTEGER
  113. *> = 0: successful exit
  114. *> < 0: if INFO = -k, the k-th argument had an illegal value
  115. *> \endverbatim
  116. *
  117. * Authors:
  118. * ========
  119. *
  120. *> \author Univ. of Tennessee
  121. *> \author Univ. of California Berkeley
  122. *> \author Univ. of Colorado Denver
  123. *> \author NAG Ltd.
  124. *
  125. *> \date December 2016
  126. *
  127. *> \ingroup double_lin
  128. *
  129. * =====================================================================
  130. SUBROUTINE DLAVSP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB,
  131. $ INFO )
  132. *
  133. * -- LAPACK test routine (version 3.7.0) --
  134. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  135. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  136. * December 2016
  137. *
  138. * .. Scalar Arguments ..
  139. CHARACTER DIAG, TRANS, UPLO
  140. INTEGER INFO, LDB, N, NRHS
  141. * ..
  142. * .. Array Arguments ..
  143. INTEGER IPIV( * )
  144. DOUBLE PRECISION A( * ), B( LDB, * )
  145. * ..
  146. *
  147. * =====================================================================
  148. *
  149. * .. Parameters ..
  150. DOUBLE PRECISION ONE
  151. PARAMETER ( ONE = 1.0D+0 )
  152. * ..
  153. * .. Local Scalars ..
  154. LOGICAL NOUNIT
  155. INTEGER J, K, KC, KCNEXT, KP
  156. DOUBLE PRECISION D11, D12, D21, D22, T1, T2
  157. * ..
  158. * .. External Functions ..
  159. LOGICAL LSAME
  160. EXTERNAL LSAME
  161. * ..
  162. * .. External Subroutines ..
  163. EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA
  164. * ..
  165. * .. Intrinsic Functions ..
  166. INTRINSIC ABS, MAX
  167. * ..
  168. * .. Executable Statements ..
  169. *
  170. * Test the input parameters.
  171. *
  172. INFO = 0
  173. IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
  174. INFO = -1
  175. ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
  176. $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
  177. INFO = -2
  178. ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) )
  179. $ THEN
  180. INFO = -3
  181. ELSE IF( N.LT.0 ) THEN
  182. INFO = -4
  183. ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
  184. INFO = -8
  185. END IF
  186. IF( INFO.NE.0 ) THEN
  187. CALL XERBLA( 'DLAVSP ', -INFO )
  188. RETURN
  189. END IF
  190. *
  191. * Quick return if possible.
  192. *
  193. IF( N.EQ.0 )
  194. $ RETURN
  195. *
  196. NOUNIT = LSAME( DIAG, 'N' )
  197. *------------------------------------------
  198. *
  199. * Compute B := A * B (No transpose)
  200. *
  201. *------------------------------------------
  202. IF( LSAME( TRANS, 'N' ) ) THEN
  203. *
  204. * Compute B := U*B
  205. * where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
  206. *
  207. IF( LSAME( UPLO, 'U' ) ) THEN
  208. *
  209. * Loop forward applying the transformations.
  210. *
  211. K = 1
  212. KC = 1
  213. 10 CONTINUE
  214. IF( K.GT.N )
  215. $ GO TO 30
  216. *
  217. * 1 x 1 pivot block
  218. *
  219. IF( IPIV( K ).GT.0 ) THEN
  220. *
  221. * Multiply by the diagonal element if forming U * D.
  222. *
  223. IF( NOUNIT )
  224. $ CALL DSCAL( NRHS, A( KC+K-1 ), B( K, 1 ), LDB )
  225. *
  226. * Multiply by P(K) * inv(U(K)) if K > 1.
  227. *
  228. IF( K.GT.1 ) THEN
  229. *
  230. * Apply the transformation.
  231. *
  232. CALL DGER( K-1, NRHS, ONE, A( KC ), 1, B( K, 1 ), LDB,
  233. $ B( 1, 1 ), LDB )
  234. *
  235. * Interchange if P(K) != I.
  236. *
  237. KP = IPIV( K )
  238. IF( KP.NE.K )
  239. $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
  240. END IF
  241. KC = KC + K
  242. K = K + 1
  243. ELSE
  244. *
  245. * 2 x 2 pivot block
  246. *
  247. KCNEXT = KC + K
  248. *
  249. * Multiply by the diagonal block if forming U * D.
  250. *
  251. IF( NOUNIT ) THEN
  252. D11 = A( KCNEXT-1 )
  253. D22 = A( KCNEXT+K )
  254. D12 = A( KCNEXT+K-1 )
  255. D21 = D12
  256. DO 20 J = 1, NRHS
  257. T1 = B( K, J )
  258. T2 = B( K+1, J )
  259. B( K, J ) = D11*T1 + D12*T2
  260. B( K+1, J ) = D21*T1 + D22*T2
  261. 20 CONTINUE
  262. END IF
  263. *
  264. * Multiply by P(K) * inv(U(K)) if K > 1.
  265. *
  266. IF( K.GT.1 ) THEN
  267. *
  268. * Apply the transformations.
  269. *
  270. CALL DGER( K-1, NRHS, ONE, A( KC ), 1, B( K, 1 ), LDB,
  271. $ B( 1, 1 ), LDB )
  272. CALL DGER( K-1, NRHS, ONE, A( KCNEXT ), 1,
  273. $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
  274. *
  275. * Interchange if P(K) != I.
  276. *
  277. KP = ABS( IPIV( K ) )
  278. IF( KP.NE.K )
  279. $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
  280. END IF
  281. KC = KCNEXT + K + 1
  282. K = K + 2
  283. END IF
  284. GO TO 10
  285. 30 CONTINUE
  286. *
  287. * Compute B := L*B
  288. * where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
  289. *
  290. ELSE
  291. *
  292. * Loop backward applying the transformations to B.
  293. *
  294. K = N
  295. KC = N*( N+1 ) / 2 + 1
  296. 40 CONTINUE
  297. IF( K.LT.1 )
  298. $ GO TO 60
  299. KC = KC - ( N-K+1 )
  300. *
  301. * Test the pivot index. If greater than zero, a 1 x 1
  302. * pivot was used, otherwise a 2 x 2 pivot was used.
  303. *
  304. IF( IPIV( K ).GT.0 ) THEN
  305. *
  306. * 1 x 1 pivot block:
  307. *
  308. * Multiply by the diagonal element if forming L * D.
  309. *
  310. IF( NOUNIT )
  311. $ CALL DSCAL( NRHS, A( KC ), B( K, 1 ), LDB )
  312. *
  313. * Multiply by P(K) * inv(L(K)) if K < N.
  314. *
  315. IF( K.NE.N ) THEN
  316. KP = IPIV( K )
  317. *
  318. * Apply the transformation.
  319. *
  320. CALL DGER( N-K, NRHS, ONE, A( KC+1 ), 1, B( K, 1 ),
  321. $ LDB, B( K+1, 1 ), LDB )
  322. *
  323. * Interchange if a permutation was applied at the
  324. * K-th step of the factorization.
  325. *
  326. IF( KP.NE.K )
  327. $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
  328. END IF
  329. K = K - 1
  330. *
  331. ELSE
  332. *
  333. * 2 x 2 pivot block:
  334. *
  335. KCNEXT = KC - ( N-K+2 )
  336. *
  337. * Multiply by the diagonal block if forming L * D.
  338. *
  339. IF( NOUNIT ) THEN
  340. D11 = A( KCNEXT )
  341. D22 = A( KC )
  342. D21 = A( KCNEXT+1 )
  343. D12 = D21
  344. DO 50 J = 1, NRHS
  345. T1 = B( K-1, J )
  346. T2 = B( K, J )
  347. B( K-1, J ) = D11*T1 + D12*T2
  348. B( K, J ) = D21*T1 + D22*T2
  349. 50 CONTINUE
  350. END IF
  351. *
  352. * Multiply by P(K) * inv(L(K)) if K < N.
  353. *
  354. IF( K.NE.N ) THEN
  355. *
  356. * Apply the transformation.
  357. *
  358. CALL DGER( N-K, NRHS, ONE, A( KC+1 ), 1, B( K, 1 ),
  359. $ LDB, B( K+1, 1 ), LDB )
  360. CALL DGER( N-K, NRHS, ONE, A( KCNEXT+2 ), 1,
  361. $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
  362. *
  363. * Interchange if a permutation was applied at the
  364. * K-th step of the factorization.
  365. *
  366. KP = ABS( IPIV( K ) )
  367. IF( KP.NE.K )
  368. $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
  369. END IF
  370. KC = KCNEXT
  371. K = K - 2
  372. END IF
  373. GO TO 40
  374. 60 CONTINUE
  375. END IF
  376. *----------------------------------------
  377. *
  378. * Compute B := A' * B (transpose)
  379. *
  380. *----------------------------------------
  381. ELSE
  382. *
  383. * Form B := U'*B
  384. * where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
  385. * and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
  386. *
  387. IF( LSAME( UPLO, 'U' ) ) THEN
  388. *
  389. * Loop backward applying the transformations.
  390. *
  391. K = N
  392. KC = N*( N+1 ) / 2 + 1
  393. 70 CONTINUE
  394. IF( K.LT.1 )
  395. $ GO TO 90
  396. KC = KC - K
  397. *
  398. * 1 x 1 pivot block.
  399. *
  400. IF( IPIV( K ).GT.0 ) THEN
  401. IF( K.GT.1 ) THEN
  402. *
  403. * Interchange if P(K) != I.
  404. *
  405. KP = IPIV( K )
  406. IF( KP.NE.K )
  407. $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
  408. *
  409. * Apply the transformation
  410. *
  411. CALL DGEMV( 'Transpose', K-1, NRHS, ONE, B, LDB,
  412. $ A( KC ), 1, ONE, B( K, 1 ), LDB )
  413. END IF
  414. IF( NOUNIT )
  415. $ CALL DSCAL( NRHS, A( KC+K-1 ), B( K, 1 ), LDB )
  416. K = K - 1
  417. *
  418. * 2 x 2 pivot block.
  419. *
  420. ELSE
  421. KCNEXT = KC - ( K-1 )
  422. IF( K.GT.2 ) THEN
  423. *
  424. * Interchange if P(K) != I.
  425. *
  426. KP = ABS( IPIV( K ) )
  427. IF( KP.NE.K-1 )
  428. $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
  429. $ LDB )
  430. *
  431. * Apply the transformations
  432. *
  433. CALL DGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
  434. $ A( KC ), 1, ONE, B( K, 1 ), LDB )
  435. CALL DGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
  436. $ A( KCNEXT ), 1, ONE, B( K-1, 1 ), LDB )
  437. END IF
  438. *
  439. * Multiply by the diagonal block if non-unit.
  440. *
  441. IF( NOUNIT ) THEN
  442. D11 = A( KC-1 )
  443. D22 = A( KC+K-1 )
  444. D12 = A( KC+K-2 )
  445. D21 = D12
  446. DO 80 J = 1, NRHS
  447. T1 = B( K-1, J )
  448. T2 = B( K, J )
  449. B( K-1, J ) = D11*T1 + D12*T2
  450. B( K, J ) = D21*T1 + D22*T2
  451. 80 CONTINUE
  452. END IF
  453. KC = KCNEXT
  454. K = K - 2
  455. END IF
  456. GO TO 70
  457. 90 CONTINUE
  458. *
  459. * Form B := L'*B
  460. * where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
  461. * and L' = inv(L(m))*P(m)* ... *inv(L(1))*P(1)
  462. *
  463. ELSE
  464. *
  465. * Loop forward applying the L-transformations.
  466. *
  467. K = 1
  468. KC = 1
  469. 100 CONTINUE
  470. IF( K.GT.N )
  471. $ GO TO 120
  472. *
  473. * 1 x 1 pivot block
  474. *
  475. IF( IPIV( K ).GT.0 ) THEN
  476. IF( K.LT.N ) THEN
  477. *
  478. * Interchange if P(K) != I.
  479. *
  480. KP = IPIV( K )
  481. IF( KP.NE.K )
  482. $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
  483. *
  484. * Apply the transformation
  485. *
  486. CALL DGEMV( 'Transpose', N-K, NRHS, ONE, B( K+1, 1 ),
  487. $ LDB, A( KC+1 ), 1, ONE, B( K, 1 ), LDB )
  488. END IF
  489. IF( NOUNIT )
  490. $ CALL DSCAL( NRHS, A( KC ), B( K, 1 ), LDB )
  491. KC = KC + N - K + 1
  492. K = K + 1
  493. *
  494. * 2 x 2 pivot block.
  495. *
  496. ELSE
  497. KCNEXT = KC + N - K + 1
  498. IF( K.LT.N-1 ) THEN
  499. *
  500. * Interchange if P(K) != I.
  501. *
  502. KP = ABS( IPIV( K ) )
  503. IF( KP.NE.K+1 )
  504. $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
  505. $ LDB )
  506. *
  507. * Apply the transformation
  508. *
  509. CALL DGEMV( 'Transpose', N-K-1, NRHS, ONE,
  510. $ B( K+2, 1 ), LDB, A( KCNEXT+1 ), 1, ONE,
  511. $ B( K+1, 1 ), LDB )
  512. CALL DGEMV( 'Transpose', N-K-1, NRHS, ONE,
  513. $ B( K+2, 1 ), LDB, A( KC+2 ), 1, ONE,
  514. $ B( K, 1 ), LDB )
  515. END IF
  516. *
  517. * Multiply by the diagonal block if non-unit.
  518. *
  519. IF( NOUNIT ) THEN
  520. D11 = A( KC )
  521. D22 = A( KCNEXT )
  522. D21 = A( KC+1 )
  523. D12 = D21
  524. DO 110 J = 1, NRHS
  525. T1 = B( K, J )
  526. T2 = B( K+1, J )
  527. B( K, J ) = D11*T1 + D12*T2
  528. B( K+1, J ) = D21*T1 + D22*T2
  529. 110 CONTINUE
  530. END IF
  531. KC = KCNEXT + ( N-K )
  532. K = K + 2
  533. END IF
  534. GO TO 100
  535. 120 CONTINUE
  536. END IF
  537. *
  538. END IF
  539. RETURN
  540. *
  541. * End of DLAVSP
  542. *
  543. END