dlarfb.c 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775
  1. /* dlarfb.f -- translated by f2c (version 20061008).
  2. You must link the resulting object file with libf2c:
  3. on Microsoft Windows system, link with libf2c.lib;
  4. on Linux or Unix systems, link with .../path/to/libf2c.a -lm
  5. or, if you install libf2c.a in a standard place, with -lf2c -lm
  6. -- in that order, at the end of the command line, as in
  7. cc *.o -lf2c -lm
  8. Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
  9. http://www.netlib.org/f2c/libf2c.zip
  10. */
  11. #include "f2c.h"
  12. #include "blaswrap.h"
  13. /* Table of constant values */
  14. static integer c__1 = 1;
  15. static doublereal c_b14 = 1.;
  16. static doublereal c_b25 = -1.;
  17. /* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char *
  18. storev, integer *m, integer *n, integer *k, doublereal *v, integer *
  19. ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc,
  20. doublereal *work, integer *ldwork)
  21. {
  22. /* System generated locals */
  23. integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
  24. work_offset, i__1, i__2;
  25. /* Local variables */
  26. integer i__, j;
  27. extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
  28. integer *, doublereal *, doublereal *, integer *, doublereal *,
  29. integer *, doublereal *, doublereal *, integer *);
  30. extern logical lsame_(char *, char *);
  31. integer lastc;
  32. extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
  33. doublereal *, integer *), dtrmm_(char *, char *, char *, char *,
  34. integer *, integer *, doublereal *, doublereal *, integer *,
  35. doublereal *, integer *);
  36. integer lastv;
  37. extern integer iladlc_(integer *, integer *, doublereal *, integer *),
  38. iladlr_(integer *, integer *, doublereal *, integer *);
  39. char transt[1];
  40. /* -- LAPACK auxiliary routine (version 3.2) -- */
  41. /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
  42. /* November 2006 */
  43. /* .. Scalar Arguments .. */
  44. /* .. */
  45. /* .. Array Arguments .. */
  46. /* .. */
  47. /* Purpose */
  48. /* ======= */
  49. /* DLARFB applies a real block reflector H or its transpose H' to a */
  50. /* real m by n matrix C, from either the left or the right. */
  51. /* Arguments */
  52. /* ========= */
  53. /* SIDE (input) CHARACTER*1 */
  54. /* = 'L': apply H or H' from the Left */
  55. /* = 'R': apply H or H' from the Right */
  56. /* TRANS (input) CHARACTER*1 */
  57. /* = 'N': apply H (No transpose) */
  58. /* = 'T': apply H' (Transpose) */
  59. /* DIRECT (input) CHARACTER*1 */
  60. /* Indicates how H is formed from a product of elementary */
  61. /* reflectors */
  62. /* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
  63. /* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
  64. /* STOREV (input) CHARACTER*1 */
  65. /* Indicates how the vectors which define the elementary */
  66. /* reflectors are stored: */
  67. /* = 'C': Columnwise */
  68. /* = 'R': Rowwise */
  69. /* M (input) INTEGER */
  70. /* The number of rows of the matrix C. */
  71. /* N (input) INTEGER */
  72. /* The number of columns of the matrix C. */
  73. /* K (input) INTEGER */
  74. /* The order of the matrix T (= the number of elementary */
  75. /* reflectors whose product defines the block reflector). */
  76. /* V (input) DOUBLE PRECISION array, dimension */
  77. /* (LDV,K) if STOREV = 'C' */
  78. /* (LDV,M) if STOREV = 'R' and SIDE = 'L' */
  79. /* (LDV,N) if STOREV = 'R' and SIDE = 'R' */
  80. /* The matrix V. See further details. */
  81. /* LDV (input) INTEGER */
  82. /* The leading dimension of the array V. */
  83. /* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */
  84. /* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */
  85. /* if STOREV = 'R', LDV >= K. */
  86. /* T (input) DOUBLE PRECISION array, dimension (LDT,K) */
  87. /* The triangular k by k matrix T in the representation of the */
  88. /* block reflector. */
  89. /* LDT (input) INTEGER */
  90. /* The leading dimension of the array T. LDT >= K. */
  91. /* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
  92. /* On entry, the m by n matrix C. */
  93. /* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
  94. /* LDC (input) INTEGER */
  95. /* The leading dimension of the array C. LDA >= max(1,M). */
  96. /* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) */
  97. /* LDWORK (input) INTEGER */
  98. /* The leading dimension of the array WORK. */
  99. /* If SIDE = 'L', LDWORK >= max(1,N); */
  100. /* if SIDE = 'R', LDWORK >= max(1,M). */
  101. /* ===================================================================== */
  102. /* .. Parameters .. */
  103. /* .. */
  104. /* .. Local Scalars .. */
  105. /* .. */
  106. /* .. External Functions .. */
  107. /* .. */
  108. /* .. External Subroutines .. */
  109. /* .. */
  110. /* .. Executable Statements .. */
  111. /* Quick return if possible */
  112. /* Parameter adjustments */
  113. v_dim1 = *ldv;
  114. v_offset = 1 + v_dim1;
  115. v -= v_offset;
  116. t_dim1 = *ldt;
  117. t_offset = 1 + t_dim1;
  118. t -= t_offset;
  119. c_dim1 = *ldc;
  120. c_offset = 1 + c_dim1;
  121. c__ -= c_offset;
  122. work_dim1 = *ldwork;
  123. work_offset = 1 + work_dim1;
  124. work -= work_offset;
  125. /* Function Body */
  126. if (*m <= 0 || *n <= 0) {
  127. return 0;
  128. }
  129. if (lsame_(trans, "N")) {
  130. *(unsigned char *)transt = 'T';
  131. } else {
  132. *(unsigned char *)transt = 'N';
  133. }
  134. if (lsame_(storev, "C")) {
  135. if (lsame_(direct, "F")) {
  136. /* Let V = ( V1 ) (first K rows) */
  137. /* ( V2 ) */
  138. /* where V1 is unit lower triangular. */
  139. if (lsame_(side, "L")) {
  140. /* Form H * C or H' * C where C = ( C1 ) */
  141. /* ( C2 ) */
  142. /* Computing MAX */
  143. i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv);
  144. lastv = max(i__1,i__2);
  145. lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
  146. /* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
  147. /* W := C1' */
  148. i__1 = *k;
  149. for (j = 1; j <= i__1; ++j) {
  150. dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
  151. + 1], &c__1);
  152. /* L10: */
  153. }
  154. /* W := W * V1 */
  155. dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
  156. c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
  157. if (lastv > *k) {
  158. /* W := W + C2'*V2 */
  159. i__1 = lastv - *k;
  160. dgemm_("Transpose", "No transpose", &lastc, k, &i__1, &
  161. c_b14, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 +
  162. v_dim1], ldv, &c_b14, &work[work_offset], ldwork);
  163. }
  164. /* W := W * T' or W * T */
  165. dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &
  166. c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
  167. /* C := C - V * W' */
  168. if (lastv > *k) {
  169. /* C2 := C2 - V2 * W' */
  170. i__1 = lastv - *k;
  171. dgemm_("No transpose", "Transpose", &i__1, &lastc, k, &
  172. c_b25, &v[*k + 1 + v_dim1], ldv, &work[
  173. work_offset], ldwork, &c_b14, &c__[*k + 1 +
  174. c_dim1], ldc);
  175. }
  176. /* W := W * V1' */
  177. dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
  178. c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
  179. /* C1 := C1 - W' */
  180. i__1 = *k;
  181. for (j = 1; j <= i__1; ++j) {
  182. i__2 = lastc;
  183. for (i__ = 1; i__ <= i__2; ++i__) {
  184. c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
  185. /* L20: */
  186. }
  187. /* L30: */
  188. }
  189. } else if (lsame_(side, "R")) {
  190. /* Form C * H or C * H' where C = ( C1 C2 ) */
  191. /* Computing MAX */
  192. i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv);
  193. lastv = max(i__1,i__2);
  194. lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
  195. /* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
  196. /* W := C1 */
  197. i__1 = *k;
  198. for (j = 1; j <= i__1; ++j) {
  199. dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
  200. work_dim1 + 1], &c__1);
  201. /* L40: */
  202. }
  203. /* W := W * V1 */
  204. dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
  205. c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
  206. if (lastv > *k) {
  207. /* W := W + C2 * V2 */
  208. i__1 = lastv - *k;
  209. dgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
  210. c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k +
  211. 1 + v_dim1], ldv, &c_b14, &work[work_offset],
  212. ldwork);
  213. }
  214. /* W := W * T or W * T' */
  215. dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14,
  216. &t[t_offset], ldt, &work[work_offset], ldwork);
  217. /* C := C - W * V' */
  218. if (lastv > *k) {
  219. /* C2 := C2 - W * V2' */
  220. i__1 = lastv - *k;
  221. dgemm_("No transpose", "Transpose", &lastc, &i__1, k, &
  222. c_b25, &work[work_offset], ldwork, &v[*k + 1 +
  223. v_dim1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1],
  224. ldc);
  225. }
  226. /* W := W * V1' */
  227. dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
  228. c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
  229. /* C1 := C1 - W */
  230. i__1 = *k;
  231. for (j = 1; j <= i__1; ++j) {
  232. i__2 = lastc;
  233. for (i__ = 1; i__ <= i__2; ++i__) {
  234. c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
  235. /* L50: */
  236. }
  237. /* L60: */
  238. }
  239. }
  240. } else {
  241. /* Let V = ( V1 ) */
  242. /* ( V2 ) (last K rows) */
  243. /* where V2 is unit upper triangular. */
  244. if (lsame_(side, "L")) {
  245. /* Form H * C or H' * C where C = ( C1 ) */
  246. /* ( C2 ) */
  247. /* Computing MAX */
  248. i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv);
  249. lastv = max(i__1,i__2);
  250. lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
  251. /* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
  252. /* W := C2' */
  253. i__1 = *k;
  254. for (j = 1; j <= i__1; ++j) {
  255. dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
  256. j * work_dim1 + 1], &c__1);
  257. /* L70: */
  258. }
  259. /* W := W * V2 */
  260. dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
  261. c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
  262. work_offset], ldwork);
  263. if (lastv > *k) {
  264. /* W := W + C1'*V1 */
  265. i__1 = lastv - *k;
  266. dgemm_("Transpose", "No transpose", &lastc, k, &i__1, &
  267. c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
  268. c_b14, &work[work_offset], ldwork);
  269. }
  270. /* W := W * T' or W * T */
  271. dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &
  272. c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
  273. /* C := C - V * W' */
  274. if (lastv > *k) {
  275. /* C1 := C1 - V1 * W' */
  276. i__1 = lastv - *k;
  277. dgemm_("No transpose", "Transpose", &i__1, &lastc, k, &
  278. c_b25, &v[v_offset], ldv, &work[work_offset],
  279. ldwork, &c_b14, &c__[c_offset], ldc);
  280. }
  281. /* W := W * V2' */
  282. dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
  283. c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
  284. work_offset], ldwork);
  285. /* C2 := C2 - W' */
  286. i__1 = *k;
  287. for (j = 1; j <= i__1; ++j) {
  288. i__2 = lastc;
  289. for (i__ = 1; i__ <= i__2; ++i__) {
  290. c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j *
  291. work_dim1];
  292. /* L80: */
  293. }
  294. /* L90: */
  295. }
  296. } else if (lsame_(side, "R")) {
  297. /* Form C * H or C * H' where C = ( C1 C2 ) */
  298. /* Computing MAX */
  299. i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv);
  300. lastv = max(i__1,i__2);
  301. lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
  302. /* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
  303. /* W := C2 */
  304. i__1 = *k;
  305. for (j = 1; j <= i__1; ++j) {
  306. dcopy_(&lastc, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &
  307. work[j * work_dim1 + 1], &c__1);
  308. /* L100: */
  309. }
  310. /* W := W * V2 */
  311. dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
  312. c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
  313. work_offset], ldwork);
  314. if (lastv > *k) {
  315. /* W := W + C1 * V1 */
  316. i__1 = lastv - *k;
  317. dgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
  318. c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
  319. c_b14, &work[work_offset], ldwork);
  320. }
  321. /* W := W * T or W * T' */
  322. dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14,
  323. &t[t_offset], ldt, &work[work_offset], ldwork);
  324. /* C := C - W * V' */
  325. if (lastv > *k) {
  326. /* C1 := C1 - W * V1' */
  327. i__1 = lastv - *k;
  328. dgemm_("No transpose", "Transpose", &lastc, &i__1, k, &
  329. c_b25, &work[work_offset], ldwork, &v[v_offset],
  330. ldv, &c_b14, &c__[c_offset], ldc);
  331. }
  332. /* W := W * V2' */
  333. dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
  334. c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
  335. work_offset], ldwork);
  336. /* C2 := C2 - W */
  337. i__1 = *k;
  338. for (j = 1; j <= i__1; ++j) {
  339. i__2 = lastc;
  340. for (i__ = 1; i__ <= i__2; ++i__) {
  341. c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j *
  342. work_dim1];
  343. /* L110: */
  344. }
  345. /* L120: */
  346. }
  347. }
  348. }
  349. } else if (lsame_(storev, "R")) {
  350. if (lsame_(direct, "F")) {
  351. /* Let V = ( V1 V2 ) (V1: first K columns) */
  352. /* where V1 is unit upper triangular. */
  353. if (lsame_(side, "L")) {
  354. /* Form H * C or H' * C where C = ( C1 ) */
  355. /* ( C2 ) */
  356. /* Computing MAX */
  357. i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv);
  358. lastv = max(i__1,i__2);
  359. lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
  360. /* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
  361. /* W := C1' */
  362. i__1 = *k;
  363. for (j = 1; j <= i__1; ++j) {
  364. dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
  365. + 1], &c__1);
  366. /* L130: */
  367. }
  368. /* W := W * V1' */
  369. dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
  370. c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
  371. if (lastv > *k) {
  372. /* W := W + C2'*V2' */
  373. i__1 = lastv - *k;
  374. dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14,
  375. &c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1
  376. + 1], ldv, &c_b14, &work[work_offset], ldwork);
  377. }
  378. /* W := W * T' or W * T */
  379. dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &
  380. c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
  381. /* C := C - V' * W' */
  382. if (lastv > *k) {
  383. /* C2 := C2 - V2' * W' */
  384. i__1 = lastv - *k;
  385. dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25,
  386. &v[(*k + 1) * v_dim1 + 1], ldv, &work[
  387. work_offset], ldwork, &c_b14, &c__[*k + 1 +
  388. c_dim1], ldc);
  389. }
  390. /* W := W * V1 */
  391. dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
  392. c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
  393. /* C1 := C1 - W' */
  394. i__1 = *k;
  395. for (j = 1; j <= i__1; ++j) {
  396. i__2 = lastc;
  397. for (i__ = 1; i__ <= i__2; ++i__) {
  398. c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
  399. /* L140: */
  400. }
  401. /* L150: */
  402. }
  403. } else if (lsame_(side, "R")) {
  404. /* Form C * H or C * H' where C = ( C1 C2 ) */
  405. /* Computing MAX */
  406. i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv);
  407. lastv = max(i__1,i__2);
  408. lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
  409. /* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
  410. /* W := C1 */
  411. i__1 = *k;
  412. for (j = 1; j <= i__1; ++j) {
  413. dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
  414. work_dim1 + 1], &c__1);
  415. /* L160: */
  416. }
  417. /* W := W * V1' */
  418. dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
  419. c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
  420. if (lastv > *k) {
  421. /* W := W + C2 * V2' */
  422. i__1 = lastv - *k;
  423. dgemm_("No transpose", "Transpose", &lastc, k, &i__1, &
  424. c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k +
  425. 1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset],
  426. ldwork);
  427. }
  428. /* W := W * T or W * T' */
  429. dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14,
  430. &t[t_offset], ldt, &work[work_offset], ldwork);
  431. /* C := C - W * V */
  432. if (lastv > *k) {
  433. /* C2 := C2 - W * V2 */
  434. i__1 = lastv - *k;
  435. dgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
  436. c_b25, &work[work_offset], ldwork, &v[(*k + 1) *
  437. v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1
  438. + 1], ldc);
  439. }
  440. /* W := W * V1 */
  441. dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
  442. c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
  443. /* C1 := C1 - W */
  444. i__1 = *k;
  445. for (j = 1; j <= i__1; ++j) {
  446. i__2 = lastc;
  447. for (i__ = 1; i__ <= i__2; ++i__) {
  448. c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
  449. /* L170: */
  450. }
  451. /* L180: */
  452. }
  453. }
  454. } else {
  455. /* Let V = ( V1 V2 ) (V2: last K columns) */
  456. /* where V2 is unit lower triangular. */
  457. if (lsame_(side, "L")) {
  458. /* Form H * C or H' * C where C = ( C1 ) */
  459. /* ( C2 ) */
  460. /* Computing MAX */
  461. i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv);
  462. lastv = max(i__1,i__2);
  463. lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
  464. /* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
  465. /* W := C2' */
  466. i__1 = *k;
  467. for (j = 1; j <= i__1; ++j) {
  468. dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
  469. j * work_dim1 + 1], &c__1);
  470. /* L190: */
  471. }
  472. /* W := W * V2' */
  473. dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
  474. c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
  475. work_offset], ldwork);
  476. if (lastv > *k) {
  477. /* W := W + C1'*V1' */
  478. i__1 = lastv - *k;
  479. dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14,
  480. &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
  481. work[work_offset], ldwork);
  482. }
  483. /* W := W * T' or W * T */
  484. dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &
  485. c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
  486. /* C := C - V' * W' */
  487. if (lastv > *k) {
  488. /* C1 := C1 - V1' * W' */
  489. i__1 = lastv - *k;
  490. dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25,
  491. &v[v_offset], ldv, &work[work_offset], ldwork, &
  492. c_b14, &c__[c_offset], ldc);
  493. }
  494. /* W := W * V2 */
  495. dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
  496. c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
  497. work_offset], ldwork);
  498. /* C2 := C2 - W' */
  499. i__1 = *k;
  500. for (j = 1; j <= i__1; ++j) {
  501. i__2 = lastc;
  502. for (i__ = 1; i__ <= i__2; ++i__) {
  503. c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j *
  504. work_dim1];
  505. /* L200: */
  506. }
  507. /* L210: */
  508. }
  509. } else if (lsame_(side, "R")) {
  510. /* Form C * H or C * H' where C = ( C1 C2 ) */
  511. /* Computing MAX */
  512. i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv);
  513. lastv = max(i__1,i__2);
  514. lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
  515. /* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
  516. /* W := C2 */
  517. i__1 = *k;
  518. for (j = 1; j <= i__1; ++j) {
  519. dcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
  520. &work[j * work_dim1 + 1], &c__1);
  521. /* L220: */
  522. }
  523. /* W := W * V2' */
  524. dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
  525. c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
  526. work_offset], ldwork);
  527. if (lastv > *k) {
  528. /* W := W + C1 * V1' */
  529. i__1 = lastv - *k;
  530. dgemm_("No transpose", "Transpose", &lastc, k, &i__1, &
  531. c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
  532. c_b14, &work[work_offset], ldwork);
  533. }
  534. /* W := W * T or W * T' */
  535. dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14,
  536. &t[t_offset], ldt, &work[work_offset], ldwork);
  537. /* C := C - W * V */
  538. if (lastv > *k) {
  539. /* C1 := C1 - W * V1 */
  540. i__1 = lastv - *k;
  541. dgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
  542. c_b25, &work[work_offset], ldwork, &v[v_offset],
  543. ldv, &c_b14, &c__[c_offset], ldc);
  544. }
  545. /* W := W * V2 */
  546. dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
  547. c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
  548. work_offset], ldwork);
  549. /* C1 := C1 - W */
  550. i__1 = *k;
  551. for (j = 1; j <= i__1; ++j) {
  552. i__2 = lastc;
  553. for (i__ = 1; i__ <= i__2; ++i__) {
  554. c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j *
  555. work_dim1];
  556. /* L230: */
  557. }
  558. /* L240: */
  559. }
  560. }
  561. }
  562. }
  563. return 0;
  564. /* End of DLARFB */
  565. } /* dlarfb_ */