Télécharger dlarfb.eso

Retour à la liste

Numérotation des lignes :

  1. C DLARFB SOURCE BP208322 20/09/18 21:16:04 10718
  2. *> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix.
  3. *
  4. * =========== DOCUMENTATION ===========
  5. *
  6. * Online html documentation available at
  7. * http://www.netlib.org/lapack/explore-html/
  8. *
  9. *> \htmlonly
  10. *> Download DLARFB + dependencies
  11. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarfb.f">
  12. *> [TGZ]</a>
  13. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarfb.f">
  14. *> [ZIP]</a>
  15. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarfb.f">
  16. *> [TXT]</a>
  17. *> \endhtmlonly
  18. *
  19. * Definition:
  20. * ===========
  21. *
  22. * SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
  23. * T, LDT, C, LDC, WORK, LDWORK )
  24. *
  25. * .. Scalar Arguments ..
  26. * CHARACTER DIRECT, SIDE, STOREV, TRANS
  27. * INTEGER K, LDC, LDT, LDV, LDWORK, M, N
  28. * ..
  29. * .. Array Arguments ..
  30. * REAL*8 C( LDC, * ), T( LDT, * ), V( LDV, * ),
  31. * $ WORK( LDWORK, * )
  32. * ..
  33. *
  34. *
  35. *> \par Purpose:
  36. * =============
  37. *>
  38. *> \verbatim
  39. *>
  40. *> DLARFB applies a real block reflector H or its transpose H**T to a
  41. *> real m by n matrix C, from either the left or the right.
  42. *> \endverbatim
  43. *
  44. * Arguments:
  45. * ==========
  46. *
  47. *> \param[in] SIDE
  48. *> \verbatim
  49. *> SIDE is CHARACTER*1
  50. *> = 'L': apply H or H**T from the Left
  51. *> = 'R': apply H or H**T from the Right
  52. *> \endverbatim
  53. *>
  54. *> \param[in] TRANS
  55. *> \verbatim
  56. *> TRANS is CHARACTER*1
  57. *> = 'N': apply H (No transpose)
  58. *> = 'T': apply H**T (Transpose)
  59. *> \endverbatim
  60. *>
  61. *> \param[in] DIRECT
  62. *> \verbatim
  63. *> DIRECT is CHARACTER*1
  64. *> Indicates how H is formed from a product of elementary
  65. *> reflectors
  66. *> = 'F': H = H(1) H(2) . . . H(k) (Forward)
  67. *> = 'B': H = H(k) . . . H(2) H(1) (Backward)
  68. *> \endverbatim
  69. *>
  70. *> \param[in] STOREV
  71. *> \verbatim
  72. *> STOREV is CHARACTER*1
  73. *> Indicates how the vectors which define the elementary
  74. *> reflectors are stored:
  75. *> = 'C': Columnwise
  76. *> = 'R': Rowwise
  77. *> \endverbatim
  78. *>
  79. *> \param[in] M
  80. *> \verbatim
  81. *> M is INTEGER
  82. *> The number of rows of the matrix C.
  83. *> \endverbatim
  84. *>
  85. *> \param[in] N
  86. *> \verbatim
  87. *> N is INTEGER
  88. *> The number of columns of the matrix C.
  89. *> \endverbatim
  90. *>
  91. *> \param[in] K
  92. *> \verbatim
  93. *> K is INTEGER
  94. *> The order of the matrix T (= the number of elementary
  95. *> reflectors whose product defines the block reflector).
  96. *> \endverbatim
  97. *>
  98. *> \param[in] V
  99. *> \verbatim
  100. *> V is REAL*8 array, dimension
  101. *> (LDV,K) if STOREV = 'C'
  102. *> (LDV,M) if STOREV = 'R' and SIDE = 'L'
  103. *> (LDV,N) if STOREV = 'R' and SIDE = 'R'
  104. *> The matrix V. See Further Details.
  105. *> \endverbatim
  106. *>
  107. *> \param[in] LDV
  108. *> \verbatim
  109. *> LDV is INTEGER
  110. *> The leading dimension of the array V.
  111. *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
  112. *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
  113. *> if STOREV = 'R', LDV >= K.
  114. *> \endverbatim
  115. *>
  116. *> \param[in] T
  117. *> \verbatim
  118. *> T is REAL*8 array, dimension (LDT,K)
  119. *> The triangular k by k matrix T in the representation of the
  120. *> block reflector.
  121. *> \endverbatim
  122. *>
  123. *> \param[in] LDT
  124. *> \verbatim
  125. *> LDT is INTEGER
  126. *> The leading dimension of the array T. LDT >= K.
  127. *> \endverbatim
  128. *>
  129. *> \param[in,out] C
  130. *> \verbatim
  131. *> C is REAL*8 array, dimension (LDC,N)
  132. *> On entry, the m by n matrix C.
  133. *> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T.
  134. *> \endverbatim
  135. *>
  136. *> \param[in] LDC
  137. *> \verbatim
  138. *> LDC is INTEGER
  139. *> The leading dimension of the array C. LDC >= max(1,M).
  140. *> \endverbatim
  141. *>
  142. *> \param[out] WORK
  143. *> \verbatim
  144. *> WORK is REAL*8 array, dimension (LDWORK,K)
  145. *> \endverbatim
  146. *>
  147. *> \param[in] LDWORK
  148. *> \verbatim
  149. *> LDWORK is INTEGER
  150. *> The leading dimension of the array WORK.
  151. *> If SIDE = 'L', LDWORK >= max(1,N);
  152. *> if SIDE = 'R', LDWORK >= max(1,M).
  153. *> \endverbatim
  154. *
  155. * Authors:
  156. * ========
  157. *
  158. *> \author Univ. of Tennessee
  159. *> \author Univ. of California Berkeley
  160. *> \author Univ. of Colorado Denver
  161. *> \author NAG Ltd.
  162. *
  163. *> \date June 2013
  164. *
  165. *> \ingroup doubleOTHERauxiliary
  166. *
  167. *> \par Further Details:
  168. * =====================
  169. *>
  170. *> \verbatim
  171. *>
  172. *> The shape of the matrix V and the storage of the vectors which define
  173. *> the H(i) is best illustrated by the following example with n = 5 and
  174. *> k = 3. The elements equal to 1 are not stored; the corresponding
  175. *> array elements are modified but restored on exit. The rest of the
  176. *> array is not used.
  177. *>
  178. *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
  179. *>
  180. *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
  181. *> ( v1 1 ) ( 1 v2 v2 v2 )
  182. *> ( v1 v2 1 ) ( 1 v3 v3 )
  183. *> ( v1 v2 v3 )
  184. *> ( v1 v2 v3 )
  185. *>
  186. *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
  187. *>
  188. *> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
  189. *> ( v1 v2 v3 ) ( v2 v2 v2 1 )
  190. *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
  191. *> ( 1 v3 )
  192. *> ( 1 )
  193. *> \endverbatim
  194. *>
  195. * =====================================================================
  196. SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
  197. $ T, LDT, C, LDC, WORK, LDWORK )
  198. *
  199. * -- LAPACK auxdtiliary routine (version 3.7.0) --
  200. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  201. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  202. * June 2013
  203.  
  204. IMPLICIT INTEGER(I-N)
  205. IMPLICIT REAL*8(A-H,O-Z)
  206. *
  207. * .. Scalar Arguments ..
  208. CHARACTER DIRECT, SIDE, STOREV, TRANS
  209. INTEGER K, LDC, LDT, LDV, LDWORK, M, N
  210. * ..
  211. * .. Array Arguments ..
  212. REAL*8 C( LDC, * ), T( LDT, * ), V( LDV, * ),
  213. $ WORK( LDWORK, * )
  214. * ..
  215. *
  216. * =====================================================================
  217. *
  218. * .. Parameters ..
  219. REAL*8 ONE
  220. PARAMETER ( ONE = 1.0D+0 )
  221. * ..
  222. * .. Local Scalars ..
  223. CHARACTER TRANST
  224. INTEGER I, J
  225. * ..
  226. * .. External Functions ..
  227. LOGICAL LSAME
  228. * EXTERNAL LSAME
  229. * ..
  230. * .. External Subroutines ..
  231. * EXTERNAL DCOPY, DGEMM, DTRMM
  232. * ..
  233. * .. Executable Statements ..
  234. *
  235. * Quick return if possible
  236. *
  237. IF( M.LE.0 .OR. N.LE.0 )
  238. $ RETURN
  239. *
  240. IF( LSAME( TRANS, 'N' ) ) THEN
  241. TRANST = 'T'
  242. ELSE
  243. TRANST = 'N'
  244. END IF
  245. *
  246. IF( LSAME( STOREV, 'C' ) ) THEN
  247. *
  248. IF( LSAME( DIRECT, 'F' ) ) THEN
  249. *
  250. * Let V = ( V1 ) (first K rows)
  251. * ( V2 )
  252. * where V1 is unit lower triangular.
  253. *
  254. IF( LSAME( SIDE, 'L' ) ) THEN
  255. *
  256. * Form H * C or H**T * C where C = ( C1 )
  257. * ( C2 )
  258. *
  259. * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
  260. *
  261. * W := C1**T
  262. *
  263. DO 10 J = 1, K
  264. CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
  265. 10 CONTINUE
  266. *
  267. * W := W * V1
  268. *
  269. CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
  270. $ K, ONE, V, LDV, WORK, LDWORK )
  271. IF( M.GT.K ) THEN
  272. *
  273. * W := W + C2**T * V2
  274. *
  275. CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
  276. $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
  277. $ ONE, WORK, LDWORK )
  278. END IF
  279. *
  280. * W := W * T**T or W * T
  281. *
  282. CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
  283. $ ONE, T, LDT, WORK, LDWORK )
  284. *
  285. * C := C - V * W**T
  286. *
  287. IF( M.GT.K ) THEN
  288. *
  289. * C2 := C2 - V2 * W**T
  290. *
  291. CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
  292. $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
  293. $ C( K+1, 1 ), LDC )
  294. END IF
  295. *
  296. * W := W * V1**T
  297. *
  298. CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
  299. $ ONE, V, LDV, WORK, LDWORK )
  300. *
  301. * C1 := C1 - W**T
  302. *
  303. DO 30 J = 1, K
  304. DO 20 I = 1, N
  305. C( J, I ) = C( J, I ) - WORK( I, J )
  306. 20 CONTINUE
  307. 30 CONTINUE
  308. *
  309. ELSE IF( LSAME( SIDE, 'R' ) ) THEN
  310. *
  311. * Form C * H or C * H**T where C = ( C1 C2 )
  312. *
  313. * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
  314. *
  315. * W := C1
  316. *
  317. DO 40 J = 1, K
  318. CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
  319. 40 CONTINUE
  320. *
  321. * W := W * V1
  322. *
  323. CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
  324. $ K, ONE, V, LDV, WORK, LDWORK )
  325. IF( N.GT.K ) THEN
  326. *
  327. * W := W + C2 * V2
  328. *
  329. CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
  330. $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
  331. $ ONE, WORK, LDWORK )
  332. END IF
  333. *
  334. * W := W * T or W * T**T
  335. *
  336. CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
  337. $ ONE, T, LDT, WORK, LDWORK )
  338. *
  339. * C := C - W * V**T
  340. *
  341. IF( N.GT.K ) THEN
  342. *
  343. * C2 := C2 - W * V2**T
  344. *
  345. CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
  346. $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
  347. $ C( 1, K+1 ), LDC )
  348. END IF
  349. *
  350. * W := W * V1**T
  351. *
  352. CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
  353. $ ONE, V, LDV, WORK, LDWORK )
  354. *
  355. * C1 := C1 - W
  356. *
  357. DO 60 J = 1, K
  358. DO 50 I = 1, M
  359. C( I, J ) = C( I, J ) - WORK( I, J )
  360. 50 CONTINUE
  361. 60 CONTINUE
  362. END IF
  363. *
  364. ELSE
  365. *
  366. * Let V = ( V1 )
  367. * ( V2 ) (last K rows)
  368. * where V2 is unit upper triangular.
  369. *
  370. IF( LSAME( SIDE, 'L' ) ) THEN
  371. *
  372. * Form H * C or H**T * C where C = ( C1 )
  373. * ( C2 )
  374. *
  375. * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
  376. *
  377. * W := C2**T
  378. *
  379. DO 70 J = 1, K
  380. CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
  381. 70 CONTINUE
  382. *
  383. * W := W * V2
  384. *
  385. CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
  386. $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
  387. IF( M.GT.K ) THEN
  388. *
  389. * W := W + C1**T * V1
  390. *
  391. CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
  392. $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
  393. END IF
  394. *
  395. * W := W * T**T or W * T
  396. *
  397. CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
  398. $ ONE, T, LDT, WORK, LDWORK )
  399. *
  400. * C := C - V * W**T
  401. *
  402. IF( M.GT.K ) THEN
  403. *
  404. * C1 := C1 - V1 * W**T
  405. *
  406. CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
  407. $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
  408. END IF
  409. *
  410. * W := W * V2**T
  411. *
  412. CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
  413. $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
  414. *
  415. * C2 := C2 - W**T
  416. *
  417. DO 90 J = 1, K
  418. DO 80 I = 1, N
  419. C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
  420. 80 CONTINUE
  421. 90 CONTINUE
  422. *
  423. ELSE IF( LSAME( SIDE, 'R' ) ) THEN
  424. *
  425. * Form C * H or C * H**T where C = ( C1 C2 )
  426. *
  427. * W := C * V = (C1*V1 + C2*V2) (stored in WORK)
  428. *
  429. * W := C2
  430. *
  431. DO 100 J = 1, K
  432. CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
  433. 100 CONTINUE
  434. *
  435. * W := W * V2
  436. *
  437. CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
  438. $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
  439. IF( N.GT.K ) THEN
  440. *
  441. * W := W + C1 * V1
  442. *
  443. CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
  444. $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
  445. END IF
  446. *
  447. * W := W * T or W * T**T
  448. *
  449. CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
  450. $ ONE, T, LDT, WORK, LDWORK )
  451. *
  452. * C := C - W * V**T
  453. *
  454. IF( N.GT.K ) THEN
  455. *
  456. * C1 := C1 - W * V1**T
  457. *
  458. CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
  459. $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
  460. END IF
  461. *
  462. * W := W * V2**T
  463. *
  464. CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
  465. $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
  466. *
  467. * C2 := C2 - W
  468. *
  469. DO 120 J = 1, K
  470. DO 110 I = 1, M
  471. C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
  472. 110 CONTINUE
  473. 120 CONTINUE
  474. END IF
  475. END IF
  476. *
  477. ELSE IF( LSAME( STOREV, 'R' ) ) THEN
  478. *
  479. IF( LSAME( DIRECT, 'F' ) ) THEN
  480. *
  481. * Let V = ( V1 V2 ) (V1: first K columns)
  482. * where V1 is unit upper triangular.
  483. *
  484. IF( LSAME( SIDE, 'L' ) ) THEN
  485. *
  486. * Form H * C or H**T * C where C = ( C1 )
  487. * ( C2 )
  488. *
  489. * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
  490. *
  491. * W := C1**T
  492. *
  493. DO 130 J = 1, K
  494. CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
  495. 130 CONTINUE
  496. *
  497. * W := W * V1**T
  498. *
  499. CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
  500. $ ONE, V, LDV, WORK, LDWORK )
  501. IF( M.GT.K ) THEN
  502. *
  503. * W := W + C2**T * V2**T
  504. *
  505. CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
  506. $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
  507. $ WORK, LDWORK )
  508. END IF
  509. *
  510. * W := W * T**T or W * T
  511. *
  512. CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
  513. $ ONE, T, LDT, WORK, LDWORK )
  514. *
  515. * C := C - V**T * W**T
  516. *
  517. IF( M.GT.K ) THEN
  518. *
  519. * C2 := C2 - V2**T * W**T
  520. *
  521. CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
  522. $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
  523. $ C( K+1, 1 ), LDC )
  524. END IF
  525. *
  526. * W := W * V1
  527. *
  528. CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
  529. $ K, ONE, V, LDV, WORK, LDWORK )
  530. *
  531. * C1 := C1 - W**T
  532. *
  533. DO 150 J = 1, K
  534. DO 140 I = 1, N
  535. C( J, I ) = C( J, I ) - WORK( I, J )
  536. 140 CONTINUE
  537. 150 CONTINUE
  538. *
  539. ELSE IF( LSAME( SIDE, 'R' ) ) THEN
  540. *
  541. * Form C * H or C * H**T where C = ( C1 C2 )
  542. *
  543. * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
  544. *
  545. * W := C1
  546. *
  547. DO 160 J = 1, K
  548. CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
  549. 160 CONTINUE
  550. *
  551. * W := W * V1**T
  552. *
  553. CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
  554. $ ONE, V, LDV, WORK, LDWORK )
  555. IF( N.GT.K ) THEN
  556. *
  557. * W := W + C2 * V2**T
  558. *
  559. CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
  560. $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
  561. $ ONE, WORK, LDWORK )
  562. END IF
  563. *
  564. * W := W * T or W * T**T
  565. *
  566. CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
  567. $ ONE, T, LDT, WORK, LDWORK )
  568. *
  569. * C := C - W * V
  570. *
  571. IF( N.GT.K ) THEN
  572. *
  573. * C2 := C2 - W * V2
  574. *
  575. CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
  576. $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
  577. $ C( 1, K+1 ), LDC )
  578. END IF
  579. *
  580. * W := W * V1
  581. *
  582. CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
  583. $ K, ONE, V, LDV, WORK, LDWORK )
  584. *
  585. * C1 := C1 - W
  586. *
  587. DO 180 J = 1, K
  588. DO 170 I = 1, M
  589. C( I, J ) = C( I, J ) - WORK( I, J )
  590. 170 CONTINUE
  591. 180 CONTINUE
  592. *
  593. END IF
  594. *
  595. ELSE
  596. *
  597. * Let V = ( V1 V2 ) (V2: last K columns)
  598. * where V2 is unit lower triangular.
  599. *
  600. IF( LSAME( SIDE, 'L' ) ) THEN
  601. *
  602. * Form H * C or H**T * C where C = ( C1 )
  603. * ( C2 )
  604. *
  605. * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
  606. *
  607. * W := C2**T
  608. *
  609. DO 190 J = 1, K
  610. CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
  611. 190 CONTINUE
  612. *
  613. * W := W * V2**T
  614. *
  615. CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
  616. $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
  617. IF( M.GT.K ) THEN
  618. *
  619. * W := W + C1**T * V1**T
  620. *
  621. CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
  622. $ C, LDC, V, LDV, ONE, WORK, LDWORK )
  623. END IF
  624. *
  625. * W := W * T**T or W * T
  626. *
  627. CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
  628. $ ONE, T, LDT, WORK, LDWORK )
  629. *
  630. * C := C - V**T * W**T
  631. *
  632. IF( M.GT.K ) THEN
  633. *
  634. * C1 := C1 - V1**T * W**T
  635. *
  636. CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
  637. $ V, LDV, WORK, LDWORK, ONE, C, LDC )
  638. END IF
  639. *
  640. * W := W * V2
  641. *
  642. CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
  643. $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
  644. *
  645. * C2 := C2 - W**T
  646. *
  647. DO 210 J = 1, K
  648. DO 200 I = 1, N
  649. C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
  650. 200 CONTINUE
  651. 210 CONTINUE
  652. *
  653. ELSE IF( LSAME( SIDE, 'R' ) ) THEN
  654. *
  655. * Form C * H or C * H' where C = ( C1 C2 )
  656. *
  657. * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
  658. *
  659. * W := C2
  660. *
  661. DO 220 J = 1, K
  662. CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
  663. 220 CONTINUE
  664. *
  665. * W := W * V2**T
  666. *
  667. CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
  668. $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
  669. IF( N.GT.K ) THEN
  670. *
  671. * W := W + C1 * V1**T
  672. *
  673. CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
  674. $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
  675. END IF
  676. *
  677. * W := W * T or W * T**T
  678. *
  679. CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
  680. $ ONE, T, LDT, WORK, LDWORK )
  681. *
  682. * C := C - W * V
  683. *
  684. IF( N.GT.K ) THEN
  685. *
  686. * C1 := C1 - W * V1
  687. *
  688. CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
  689. $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
  690. END IF
  691. *
  692. * W := W * V2
  693. *
  694. CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
  695. $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
  696. *
  697. * C1 := C1 - W
  698. *
  699. DO 240 J = 1, K
  700. DO 230 I = 1, M
  701. C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
  702. 230 CONTINUE
  703. 240 CONTINUE
  704. *
  705. END IF
  706. *
  707. END IF
  708. END IF
  709. *
  710. RETURN
  711. *
  712. * End of DLARFB
  713. *
  714. END
  715.  
  716.  
  717.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales