diff --git a/lapack-netlib/SRC/clarft.c b/lapack-netlib/SRC/clarft.c index be36bcec8a..b392e9155b 100644 --- a/lapack-netlib/SRC/clarft.c +++ b/lapack-netlib/SRC/clarft.c @@ -254,11 +254,10 @@ typedef struct Namelist Namelist; -lf2c -lm (in that order) */ - /* Table of constant values */ static complex c_b1 = {1.f,0.f}; -static complex c_b3 = {-1.f,0.f}; +static complex c_b2 = {-1.f,0.f}; static integer c__3 = 3; static integer c_n1 = -1; static integer c__2 = 2; @@ -312,6 +311,9 @@ f"> */ /* > H(i) is stored in the i-th row of the array V, and */ /* > */ /* > H = I - V**H * T * V */ +/* > */ +/* > If DIRECT or STOREV = 'T', see Further Details for the shape of T */ +/* > */ /* > \endverbatim */ /* Arguments: */ @@ -324,6 +326,8 @@ f"> */ /* > multiplied to form the block reflector: */ /* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ /* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) */ +/* > but we return the T matrix that is already (conjugate) transposed */ /* > \endverbatim */ /* > */ /* > \param[in] STOREV */ @@ -331,8 +335,10 @@ f"> */ /* > STOREV is CHARACTER*1 */ /* > Specifies how the vectors which define the elementary */ /* > reflectors are stored (see also Further Details): */ -/* > = 'C': columnwise */ -/* > = 'R': rowwise */ +/* > = 'C': column-wise */ +/* > = 'R': row-wise */ +/* > = 'T': (With DIRECT='F') Row-wise, but we return the T */ +/* > matrix that is already (conjugate) transposed. */ /* > \endverbatim */ /* > */ /* > \param[in] N */ @@ -403,7 +409,7 @@ f"> */ /* > the H(i) is best illustrated by the following example with n = 5 and */ /* > k = 3. The elements equal to 1 are not stored. */ /* > */ -/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ +/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and (STOREV = 'R' or STOREV = 'T'): */ /* > */ /* > V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ /* > ( v1 1 ) ( 1 v2 v2 v2 ) */ @@ -411,13 +417,36 @@ f"> */ /* > ( v1 v2 v3 ) */ /* > ( v1 v2 v3 ) */ /* > */ -/* > DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ +/* > DIRECT = 'B' and STOREV = 'C': (DIRECT = 'B' or DIRECT = 'T') and STOREV = 'R': */ /* > */ /* > V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ /* > ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ /* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ /* > ( 1 v3 ) */ /* > ( 1 ) */ +/* > */ +/* > In addition, the shape of T is determined by these same flags as */ +/* > in the below table. */ +/* > 'U' denotes upper triangular */ +/* > 'L' denotes lower triangular */ +/* > 'X' denotes no current implementation */ +/* > We also provide the logical variable that represents the case */ +/* > in the code if it is implemented */ +/* > */ +/* > |-----------------------------------------------------------| */ +/* > | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | */ +/* > |--------------+--------------+--------------+--------------| */ +/* > | STOREV = 'C' | U (QR) | L (QL) | X | */ +/* > | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | */ +/* > | STOREV = 'T' | L (LQT) | X | X | */ +/* > |-----------------------------------------------------------| */ +/* > */ +/* > Finally, the relationship between the (conjugate) transposed T matrices */ +/* > are as follows: (Note that T_{FC} denotes the T associated with calling */ +/* > this routine with DIRECT = 'F' and STOREV = 'C') */ +/* > */ +/* > T_{TR} = (T_{BR})**H */ +/* > T_{FT} = (T_{FR})**H */ /* > \endverbatim */ /* > */ /* ===================================================================== */ @@ -432,11 +461,13 @@ f"> */ /* Local variables */ integer i__, j, l; - logical lq, ql, qr; + logical lq, ql, qr, rq; integer nx; extern /* Subroutine */ void clarft_lvl2__(char *, char *, integer *, integer *, complex *, integer *, complex *, complex *, integer *); - logical dirf, colv; + logical lqt, rqt, dirb, dirf; + integer info; + logical dirt; extern /* Subroutine */ void cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); @@ -444,9 +475,11 @@ f"> */ extern /* Subroutine */ void ctrmm_(char *, char *, char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *), clacpy_(char *, - integer *, integer *, complex *, integer *, complex *, integer *); + integer *, integer *, complex *, integer *, complex *, integer *), + xerbla_(char *, integer *, ftnlen); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); + logical storec, storer, storet; /* -- LAPACK auxiliary routine -- */ @@ -471,7 +504,7 @@ f"> */ /* Based on the algorithm of Elmroth and Gustavson, */ /* IBM J. Res. Develop. Vol 44 No. 4 July 2000. */ -/* Quick return if possible */ +/* Convert our character flags to logical flags for later */ /* Parameter adjustments */ v_dim1 = *ldv; @@ -483,19 +516,102 @@ f"> */ t -= t_offset; /* Function Body */ + dirf = lsame_(direct, "F"); + dirb = lsame_(direct, "B"); + dirt = lsame_(direct, "T"); + storec = lsame_(storev, "C"); + storer = lsame_(storev, "R"); + storet = lsame_(storev, "T"); + +/* Error handling for our character flags */ + + info = 0; + if (! (dirf || dirb || dirt)) { + +/* DIRECT holds an illegal value */ + + info = 1; + } else if (! (storec || storer || storet)) { + +/* STOREV holds an illegal value */ + + info = 2; + } else if (dirb && storet) { + +/* This case is purposefully not implemented, but any other value for */ +/* STOREV is valid, so we report STOREV as the invalid input */ + + info = 2; + } else if (dirt && storec) { + +/* This case is purposefully not implemented, but any other value for */ +/* DIRECT is valid, so we report DIRECT as the invalid input */ + + info = 1; + } else if (dirt && storet) { + +/* This case is purposefully not implemented, and is ambiguous what */ +/* the user wants to do, so we arbitrarily say DIRECT is the incorrect */ +/* character flag. */ + + info = 1; + } + if (info != 0) { + xerbla_("CLARFT", &info,(ftnlen)6); + return; + } + +/* Quick return if possible */ + if (*n == 0 || *k == 0) { return; } +/* Now we determine what factorization our flags are associated with */ + +/* QR happens when we have forward direction in column storage */ + + qr = dirf && storec; + +/* LQT happens when we have forward direction in row storage and want to compute the transpose of */ +/* the T we would normally compute */ + + lqt = dirf && storet; + +/* LQ happens when we have forward direction in row storage and want to compute the T we would */ +/* normally compute */ + + lq = dirf && storer; + +/* QL happens when we have backward direction in column storage */ + + ql = dirb && storec; + +/* RQT happens when we have backward direction in row storage and want to compute the transpose */ +/* of the T we would normally compute */ + + rqt = dirt && storer; + +/* RQ happens when we have backward direction in row storage and want to compute the T that we */ +/* would normally compute */ + + rq = dirb && storer; + /* Base case */ if (*n == 1 || *k == 1) { - i__1 = t_dim1 + 1; - t[i__1].r = tau[1].r, t[i__1].i = tau[1].i; + if (lqt || rqt) { + i__1 = t_dim1 + 1; + r_cnjg(&q__1, &tau[1]); + t[i__1].r = q__1.r, t[i__1].i = q__1.i; + } else { + i__1 = t_dim1 + 1; + t[i__1].r = tau[1].r, t[i__1].i = tau[1].i; + } return; } -/* Determine when to cross over into the level 2 based implementation */ +/* Determine crossover point from level 2 to level 3 BLAS implementation */ /* Writing concatenation */ i__2[0] = 1, a__1[0] = direct; @@ -504,41 +620,17 @@ f"> */ nx = ilaenv_(&c__3, "CLARFT", ch__1, n, k, &c_n1, &c_n1, (ftnlen)6, ( ftnlen)2); if (*k < nx) { + +/* Finish this component with a level 2 BLAS implementation */ + clarft_lvl2__(direct, storev, n, k, &v[v_offset], ldv, &tau[1], &t[ t_offset], ldt); return; } -/* Beginning of executable statements */ +/* Beginning of executable statements for the recursive case */ l = *k / 2; - -/* Determine what kind of Q we need to compute */ -/* We assume that if the user doesn't provide 'F' for DIRECT, */ -/* then they meant to provide 'B' and if they don't provide */ -/* 'C' for STOREV, then they meant to provide 'R' */ - - dirf = lsame_(direct, "F"); - colv = lsame_(storev, "C"); - -/* QR happens when we have forward direction in column storage */ - - qr = dirf && colv; - -/* LQ happens when we have forward direction in row storage */ - - lq = dirf && ! colv; - -/* QL happens when we have backward direction in column storage */ - - ql = ! dirf && colv; - -/* The last case is RQ. Due to how we structured this, if the */ -/* above 3 are false, then RQ must be true, so we never store */ -/* this */ -/* RQ happens when we have backward direction in row storage */ -/* RQ = (.NOT.DIRF).AND.(.NOT.COLV) */ - if (qr) { /* Break V apart into 6 components */ @@ -577,7 +669,7 @@ f"> */ /* (I - V_1*T_{1,1}*V_1')*(I - V_2*T_{2,2}*V_2') */ /* = I - V_1*T_{1,1}*V_1' - V_2*T_{2,2}*V_2' + V_1*T_{1,1}*V_1'*V_2*T_{2,2}*V_2' */ -/* Define T{1,2} = -T_{1,1}*V_1'*V_2*T_{2,2} */ +/* Define T_{1,2} = -T_{1,1}*V_1'*V_2*T_{2,2} */ /* Then, we can define the matrix V as */ /* V = |-------| */ @@ -636,7 +728,7 @@ f"> */ /* T_{1,2} = -T_{1,1}*T_{1,2} */ i__1 = *k - l; - ctrmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__1, &c_b3, + ctrmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__1, &c_b2, &t[t_offset], ldt, &t[(l + 1) * t_dim1 + 1], ldt); /* T_{1,2} = T_{1,2}*T_{2,2} */ @@ -679,8 +771,8 @@ f"> */ /* Then, consider the product: */ -/* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) */ -/* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 */ +/* (I - V_1'*T_{1,1}'*V_1)*(I - V_2'*T_{2,2}'*V_2) */ +/* = I - V_1'*T_{1,1}'*V_1 - V_2'*T_{2,2}'*V_2 + V_1'*T_{1,1}'*V_1*V_2'*T_{2,2}'*V_2 */ /* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} */ @@ -691,7 +783,7 @@ f"> */ /* |---| */ /* So, our product is equivalent to the matrix product */ -/* I - V'*T*V */ +/* I - V'*T'*V */ /* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ /* to compute T_{1,2} */ @@ -736,7 +828,7 @@ f"> */ /* T_{1,2} = -T_{1,1}*T_{1,2} */ i__1 = *k - l; - ctrmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__1, &c_b3, + ctrmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__1, &c_b2, &t[t_offset], ldt, &t[(l + 1) * t_dim1 + 1], ldt); /* T_{1,2} = T_{1,2}*T_{2,2} */ @@ -745,6 +837,111 @@ f"> */ ctrmm_("Right", "Upper", "No transpose", "Non-unit", &l, &i__1, &c_b1, &t[l + 1 + (l + 1) * t_dim1], ldt, &t[(l + 1) * t_dim1 + 1], ldt); + } else if (lqt) { + +/* Break V apart into 6 components */ + +/* V = |----------------------| */ +/* |V_{1,1} V_{1,2} V{1,3}| */ +/* |0 V_{2,2} V{2,3}| */ +/* |----------------------| */ + +/* V_{1,1}\in\C^{l,l} unit upper triangular */ +/* V_{1,2}\in\C^{l,k-l} rectangular */ +/* V_{1,3}\in\C^{l,n-k} rectangular */ + +/* V_{2,2}\in\C^{k-l,k-l} unit upper triangular */ +/* V_{2,3}\in\C^{k-l,n-k} rectangular */ + +/* Where l = floor(k/2) */ + +/* We will construct the T matrix */ +/* T = |---------------| */ +/* |T_{1,1} 0 | */ +/* |T_{2,1} T_{2,2}| */ +/* |---------------| */ + +/* T is the triangular factor obtained from block reflectors. */ +/* To motivate the structure, assume we have already computed T_{1,1} */ +/* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 */ + +/* T_{1,1}\in\C^{l, l} lower triangular */ +/* T_{2,2}\in\C^{k-l, k-l} lower triangular */ +/* T_{2,1}\in\C^{k-l, l} rectangular */ + +/* Then, consider the product: */ + +/* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) */ +/* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 */ + +/* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} */ + +/* Then, we can define the matrix V as */ +/* V = |---| */ +/* |V_1| */ +/* |V_2| */ +/* |---| */ + +/* So, our product is equivalent to the matrix product */ +/* I - V'*T*V */ +/* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ +/* to compute T_{2,1} */ + +/* Compute T_{1,1} recursively */ + + clarft_(direct, storev, n, &l, &v[v_offset], ldv, &tau[1], &t[ + t_offset], ldt); + +/* Compute T_{2,2} recursively */ + + i__1 = *n - l; + i__3 = *k - l; + clarft_(direct, storev, &i__1, &i__3, &v[l + 1 + (l + 1) * v_dim1], + ldv, &tau[l + 1], &t[l + 1 + (l + 1) * t_dim1], ldt); + +/* Compute T_{2,1} */ +/* T_{2,1} = V_{1,2}' */ + + i__1 = *k - l; + for (i__ = 1; i__ <= i__1; ++i__) { + i__3 = l; + for (j = 1; j <= i__3; ++j) { + i__4 = l + i__ + j * t_dim1; + r_cnjg(&q__1, &v[j + (l + i__) * v_dim1]); + t[i__4].r = q__1.r, t[i__4].i = q__1.i; + } + } + +/* T_{2,1} = V_{2,2}*T_{2,1} */ + + i__1 = *k - l; + ctrmm_("Left", "Upper", "No Transpose", "Unit", &i__1, &l, &c_b1, &v[ + l + 1 + (l + 1) * v_dim1], ldv, &t[l + 1 + t_dim1], ldt); + +/* T_{2,1} = V_{2,3}*V_{1,3}' + T_{2,1} */ +/* Note: We assume K <= N, and GEMM will do nothing if N=K */ + + i__1 = *k - l; + i__3 = *n - *k; + cgemm_("No Transpose", "Conjugate", &i__1, &l, &i__3, &c_b1, &v[l + 1 + + (*k + 1) * v_dim1], ldv, &v[(*k + 1) * v_dim1 + 1], ldv, & + c_b1, &t[l + 1 + t_dim1], ldt); + +/* At this point, we have that T_{2,1} = V_2*V_1' */ +/* All that is left is to pre and post multiply by -T_{2,2} and T_{1,1} */ +/* respectively. */ + +/* T_{2,1} = -T_{2,2}*T_{2,1} */ + + i__1 = *k - l; + ctrmm_("Left", "Lower", "No Transpose", "Non-unit", &i__1, &l, &c_b2, + &t[l + 1 + (l + 1) * t_dim1], ldt, &t[l + 1 + t_dim1], ldt); + +/* T_{2,1} = T_{2,1}*T_{1,1} */ + + i__1 = *k - l; + ctrmm_("Right", "Lower", "No Transpose", "Non-unit", &i__1, &l, &c_b1, + &t[t_offset], ldt, &t[l + 1 + t_dim1], ldt); } else if (ql) { /* Break V apart into 6 components */ @@ -842,7 +1039,7 @@ f"> */ /* T_{2,1} = -T_{2,2}*T_{2,1} */ i__1 = *k - l; - ctrmm_("Left", "Lower", "No transpose", "Non-unit", &l, &i__1, &c_b3, + ctrmm_("Left", "Lower", "No transpose", "Non-unit", &l, &i__1, &c_b2, &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[*k - l + 1 + t_dim1], ldt); @@ -851,10 +1048,7 @@ f"> */ i__1 = *k - l; ctrmm_("Right", "Lower", "No transpose", "Non-unit", &l, &i__1, &c_b1, &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); - } else { - -/* Else means RQ case */ - + } else if (rq) { /* Break V apart into 6 components */ /* V = |-----------------------| */ @@ -887,8 +1081,8 @@ f"> */ /* Then, consider the product: */ -/* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) */ -/* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 */ +/* (I - V_2'*T_{2,2}'*V_2)*(I - V_1'*T_{1,1}'*V_1) */ +/* = I - V_2'*T_{2,2}'*V_2 - V_1'*T_{1,1}'*V_1 + V_2'*T_{2,2}'*V_2*V_1'*T_{1,1}'*V_1 */ /* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} */ @@ -899,7 +1093,7 @@ f"> */ /* |---| */ /* So, our product is equivalent to the matrix product */ -/* I - V'*T*V */ +/* I - V'*T'*V */ /* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ /* to compute T_{2,1} */ @@ -944,15 +1138,120 @@ f"> */ /* T_{2,1} = -T_{2,2}*T_{2,1} */ i__1 = *k - l; - ctrmm_("Left", "Lower", "No tranpose", "Non-unit", &l, &i__1, &c_b3, & - t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[*k - l + 1 + + ctrmm_("Left", "Lower", "No transpose", "Non-unit", &l, &i__1, &c_b2, + &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[*k - l + 1 + t_dim1], ldt); /* T_{2,1} = T_{2,1}*T_{1,1} */ i__1 = *k - l; - ctrmm_("Right", "Lower", "No tranpose", "Non-unit", &l, &i__1, &c_b1, - &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); + ctrmm_("Right", "Lower", "No transpose", "Non-unit", &l, &i__1, &c_b1, + &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); + } else if (rqt) { +/* Break V apart into 6 components */ + +/* V = |-----------------------| */ +/* |V_{1,1} V_{1,2} 0 | */ +/* |V_{2,1} V_{2,2} V_{2,3}| */ +/* |-----------------------| */ + +/* V_{1,1}\in\C^{k-l,n-k} rectangular */ +/* V_{1,2}\in\C^{k-l,k-l} unit lower triangular */ + +/* V_{2,1}\in\C^{l,n-k} rectangular */ +/* V_{2,2}\in\C^{l,k-l} rectangular */ +/* V_{2,3}\in\C^{l,l} unit lower triangular */ + +/* We will construct the T matrix */ +/* T = |---------------| */ +/* |T_{1,1} T_{1,2}| */ +/* | 0 T_{2,2}| */ +/* |---------------| */ + +/* T is the triangular factor obtained from block reflectors. */ +/* To motivate the structure, assume we have already computed T_{1,1} */ +/* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 */ + +/* T_{1,1}\in\C^{k-l, k-l} non-unit upper triangular */ +/* T_{2,2}\in\C^{l, l} non-unit upper triangular */ +/* T_{1,2}\in\C^{k-l, l} rectangular */ + +/* Where l = floor(k/2) */ + +/* Then, consider the product: */ + +/* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) */ +/* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 */ + +/* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} */ + +/* Then, we can define the matrix V as */ +/* V = |---| */ +/* |V_1| */ +/* |V_2| */ +/* |---| */ + +/* So, our product is equivalent to the matrix product */ +/* I - V'*T*V */ +/* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ +/* to compute T_{1,2} */ + +/* Compute T_{1,1} recursively */ + + i__1 = *n - l; + i__3 = *k - l; + clarft_(direct, storev, &i__1, &i__3, &v[v_offset], ldv, &tau[1], &t[ + t_offset], ldt); + +/* Compute T_{2,2} recursively */ + + clarft_(direct, storev, n, &l, &v[*k - l + 1 + v_dim1], ldv, &tau[*k + - l + 1], &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt); + +/* Compute T_{1,2} */ +/* T_{1,2} = V_{2,2}' */ + + i__1 = *k - l; + for (i__ = 1; i__ <= i__1; ++i__) { + i__3 = l; + for (j = 1; j <= i__3; ++j) { + i__4 = i__ + (*k - l + j) * t_dim1; + r_cnjg(&q__1, &v[*k - l + j + (*n - *k + i__) * v_dim1]); + t[i__4].r = q__1.r, t[i__4].i = q__1.i; + } + } + +/* T_{1,2} = V_{1,2}T_{1,2} */ + + i__1 = *k - l; + ctrmm_("Left", "Lower", "No Transpose", "Unit", &i__1, &l, &c_b1, &v[( + *n - *k + 1) * v_dim1 + 1], ldv, &t[(*k - l + 1) * t_dim1 + 1] + , ldt); + +/* T_{1,2} = V_{1,1}V_{2,1}' + T_{1,2} */ + + i__1 = *k - l; + i__3 = *n - *k; + cgemm_("No Transpose", "Conjugate", &i__1, &l, &i__3, &c_b1, &v[ + v_offset], ldv, &v[*k - l + 1 + v_dim1], ldv, &c_b1, &t[(*k - + l + 1) * t_dim1 + 1], ldt); + +/* At this point, we have that T_{1,2} = V_1*V_2' */ +/* All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} */ +/* respectively. */ + +/* T_{1,2} = -T_{1,1}*T_{1,2} */ + + i__1 = *k - l; + ctrmm_("Left", "Upper", "No Transpose", "Non-Unit", &i__1, &l, &c_b2, + &t[t_offset], ldt, &t[(*k - l + 1) * t_dim1 + 1], ldt); + +/* T_{1,2} = T_{1,2}*T_{2,2} */ + + i__1 = *k - l; + ctrmm_("Right", "Upper", "No Transpose", "Non-Unit", &i__1, &l, &c_b1, + &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[(*k - l + 1) + * t_dim1 + 1], ldt); } return; } /* clarft_ */ diff --git a/lapack-netlib/SRC/clarft.f b/lapack-netlib/SRC/clarft.f index 3bf2448ba8..78c754db85 100644 --- a/lapack-netlib/SRC/clarft.f +++ b/lapack-netlib/SRC/clarft.f @@ -48,6 +48,9 @@ *> H(i) is stored in the i-th row of the array V, and *> *> H = I - V**H * T * V +*> +*> If DIRECT or STOREV = 'T', see Further Details for the shape of T +*> *> \endverbatim * * Arguments: @@ -60,6 +63,8 @@ *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) +*> = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) +*> but we return the T matrix that is already (conjugate) transposed *> \endverbatim *> *> \param[in] STOREV @@ -67,8 +72,10 @@ *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise +*> = 'C': column-wise +*> = 'R': row-wise +*> = 'T': (With DIRECT='F') Row-wise, but we return the T +*> matrix that is already (conjugate) transposed. *> \endverbatim *> *> \param[in] N @@ -139,7 +146,7 @@ *> the H(i) is best illustrated by the following example with n = 5 and *> k = 3. The elements equal to 1 are not stored. *> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and (STOREV = 'R' or STOREV = 'T'): *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) @@ -147,13 +154,36 @@ *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +*> DIRECT = 'B' and STOREV = 'C': (DIRECT = 'B' or DIRECT = 'T') and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) +*> +*> In addition, the shape of T is determined by these same flags as +*> in the below table. +*> 'U' denotes upper triangular +*> 'L' denotes lower triangular +*> 'X' denotes no current implementation +*> We also provide the logical variable that represents the case +*> in the code if it is implemented +*> +*> |-----------------------------------------------------------| +*> | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | +*> |--------------+--------------+--------------+--------------| +*> | STOREV = 'C' | U (QR) | L (QL) | X | +*> | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | +*> | STOREV = 'T' | L (LQT) | X | X | +*> |-----------------------------------------------------------| +*> +*> Finally, the relationship between the (conjugate) transposed T matrices +*> are as follows: (Note that T_{FC} denotes the T associated with calling +*> this routine with DIRECT = 'F' and STOREV = 'C') +*> +*> T_{TR} = (T_{BR})**H +*> T_{FT} = (T_{FR})**H *> \endverbatim *> * ===================================================================== @@ -167,28 +197,30 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * * .. Scalar Arguments * - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. * - COMPLEX T( LDT, * ), TAU( * ), V( LDV, * ) + COMPLEX T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * .. Parameters .. * - COMPLEX ONE, NEG_ONE, ZERO - PARAMETER(ONE=(1.0E+0,0.0E+0), ZERO = (0.0E+0,0.0E+0), - $ NEG_ONE=(-1.0E+0,0.0E+0)) + COMPLEX ONE, NEG_ONE + PARAMETER(ONE=(1.0E+0,0.0E+0), + $ NEG_ONE=(-1.0E+0,0.0E+0)) * * .. Local Scalars .. * - INTEGER I,J,L,NX - LOGICAL QR,LQ,QL,DIRF,COLV + INTEGER I,J,L,NX,INFO + LOGICAL QR, LQ, QL, RQ, LQT, RQT, + $ DIRF, DIRB, DIRT, + $ STOREC, STORER, STORET * * .. External Subroutines .. * - EXTERNAL CTRMM,CGEMM,CLACPY + EXTERNAL CLARFT_LVL2, CTRMM, CGEMM, CLACPY, XERBLA * * .. External Functions.. * @@ -199,7 +231,7 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * .. Intrinsic Functions.. * INTRINSIC CONJG -* +* * The general scheme used is inspired by the approach inside DGEQRT3 * which was (at the time of writing this code): * Based on the algorithm of Elmroth and Gustavson, @@ -207,57 +239,115 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * .. * .. Executable Statements .. * -* Quick return if possible +* Convert our character flags to logical flags for later * - IF(N.EQ.0.OR.K.EQ.0) THEN - RETURN - END IF + DIRF = LSAME(DIRECT,'F') + DIRB = LSAME(DIRECT,'B') + DIRT = LSAME(DIRECT,'T') + STOREC = LSAME(STOREV,'C') + STORER = LSAME(STOREV,'R') + STORET = LSAME(STOREV,'T') * -* Base case +* Error handling for our character flags * - IF(N.EQ.1.OR.K.EQ.1) THEN - T(1,1) = TAU(1) + INFO = 0 + IF( .NOT.(DIRF.OR.DIRB.OR.DIRT) ) THEN +* +* DIRECT holds an illegal value +* + INFO = 1 + ELSE IF( .NOT.(STOREC.OR.STORER.OR.STORET) ) THEN +* +* STOREV holds an illegal value +* + INFO = 2 + ELSE IF( DIRB.AND.STORET ) THEN +* +* This case is purposefully not implemented, but any other value for +* STOREV is valid, so we report STOREV as the invalid input +* + INFO = 2 + ELSE IF( DIRT.AND.STOREC ) THEN +* +* This case is purposefully not implemented, but any other value for +* DIRECT is valid, so we report DIRECT as the invalid input +* + INFO = 1 + ELSE IF( DIRT.AND.STORET ) THEN +* +* This case is purposefully not implemented, and is ambiguous what +* the user wants to do, so we arbitrarily say DIRECT is the incorrect +* character flag. +* + INFO = 1 + END IF + + IF( INFO.NE.0 ) THEN + CALL XERBLA('CLARFT', INFO) RETURN END IF * -* Determine when to cross over into the level 2 based implementation +* Quick return if possible * - NX = ILAENV(3, "CLARFT", DIRECT // STOREV, N, K, -1, -1) - IF(K.LT.NX) THEN - CALL CLARFT_LVL2(DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT) + IF(N.EQ.0.OR.K.EQ.0) THEN RETURN END IF * -* Beginning of executable statements -* - L = K / 2 +* Now we determine what factorization our flags are associated with * -* Determine what kind of Q we need to compute -* We assume that if the user doesn't provide 'F' for DIRECT, -* then they meant to provide 'B' and if they don't provide -* 'C' for STOREV, then they meant to provide 'R' +* QR happens when we have forward direction in column storage * - DIRF = LSAME(DIRECT,'F') - COLV = LSAME(STOREV,'C') + QR = DIRF.AND.STOREC * -* QR happens when we have forward direction in column storage +* LQT happens when we have forward direction in row storage and want to compute the transpose of +* the T we would normally compute * - QR = DIRF.AND.COLV + LQT = DIRF.AND.STORET * -* LQ happens when we have forward direction in row storage +* LQ happens when we have forward direction in row storage and want to compute the T we would +* normally compute * - LQ = DIRF.AND.(.NOT.COLV) + LQ = DIRF.AND.STORER * * QL happens when we have backward direction in column storage * - QL = (.NOT.DIRF).AND.COLV + QL = DIRB.AND.STOREC +* +* RQT happens when we have backward direction in row storage and want to compute the transpose +* of the T we would normally compute * -* The last case is RQ. Due to how we structured this, if the -* above 3 are false, then RQ must be true, so we never store -* this -* RQ happens when we have backward direction in row storage -* RQ = (.NOT.DIRF).AND.(.NOT.COLV) + RQT = DIRT.AND.STORER * +* RQ happens when we have backward direction in row storage and want to compute the T that we +* would normally compute +* + RQ = DIRB.AND.STORER +* +* Base case +* + IF(N.EQ.1.OR.K.EQ.1) THEN + IF( LQT.OR.RQT ) THEN + T(1,1) = CONJG(TAU(1)) + ELSE + T(1,1) = TAU(1) + END IF + RETURN + END IF +* +* Determine crossover point from level 2 to level 3 BLAS implementation +* + NX = ILAENV(3, "CLARFT", DIRECT // STOREV, N, K, -1, -1) + IF(K.LT.NX) THEN +* +* Finish this component with a level 2 BLAS implementation +* + CALL CLARFT_LVL2(DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT) + RETURN + END IF +* +* Beginning of executable statements for the recursive case +* + L = K / 2 IF(QR) THEN * * Break V apart into 6 components @@ -271,17 +361,17 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * V_{1,1}\in\C^{l,l} unit lower triangular * V_{2,1}\in\C^{k-l,l} rectangular * V_{3,1}\in\C^{n-k,l} rectangular -* +* * V_{2,2}\in\C^{k-l,k-l} unit lower triangular * V_{3,2}\in\C^{n-k,k-l} rectangular * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} T_{1,2}| * |0 T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -292,17 +382,17 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * Where l = floor(k/2) * * Then, consider the product: -* +* * (I - V_1*T_{1,1}*V_1')*(I - V_2*T_{2,2}*V_2') * = I - V_1*T_{1,1}*V_1' - V_2*T_{2,2}*V_2' + V_1*T_{1,1}*V_1'*V_2*T_{2,2}*V_2' -* -* Define T{1,2} = -T_{1,1}*V_1'*V_2*T_{2,2} -* -* Then, we can define the matrix V as +* +* Define T_{1,2} = -T_{1,1}*V_1'*V_2*T_{2,2} +* +* Then, we can define the matrix V as * V = |-------| * |V_1 V_2| * |-------| -* +* * So, our product is equivalent to the matrix product * I - V*T*V' * This means, we can compute T_{1,1} and T_{2,2}, then use this information @@ -314,15 +404,15 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * * Compute T_{2,2} recursively * - CALL CLARFT(DIRECT, STOREV, N-L, K-L, V(L+1, L+1), LDV, - $ TAU(L+1), T(L+1, L+1), LDT) + CALL CLARFT(DIRECT, STOREV, N-L, K-L, V(L+1,L+1), LDV, + $ TAU(L+1), T(L+1,L+1), LDT) * -* Compute T_{1,2} +* Compute T_{1,2} * T_{1,2} = V_{2,1}' * DO J = 1, L DO I = 1, K-L - T(J, L+I) = CONJG(V(L+I, J)) + T(J,L+I) = CONJG(V(L+I,J)) END DO END DO * @@ -335,9 +425,8 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{1,2} = V_{3,1}'*V_{3,2} + T_{1,2} * Note: We assume K <= N, and GEMM will do nothing if N=K * - CALL CGEMM('Conjugate', 'No transpose', L, K-L, N-K, ONE, - $ V(K+1, 1), LDV, V(K+1, L+1), LDV, ONE, T(1, L+1), - $ LDT) + CALL CGEMM('Conjugate', 'No transpose', L, K-L, N-K, ONE, + $ V(K+1, 1), LDV, V(K+1,L+1), LDV, ONE, T(1, L+1), LDT) * * At this point, we have that T_{1,2} = V_1'*V_2 * All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} @@ -350,8 +439,8 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * * T_{1,2} = T_{1,2}*T_{2,2} * - CALL CTRMM('Right', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, ONE, T(L+1, L+1), LDT, T(1, L+1), LDT) + CALL CTRMM('Right', 'Upper', 'No transpose', 'Non-unit', L, + $ K-L, ONE, T(L+1,L+1), LDT, T(1, L+1), LDT) ELSE IF(LQ) THEN * @@ -365,19 +454,19 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * V_{1,1}\in\C^{l,l} unit upper triangular * V_{1,2}\in\C^{l,k-l} rectangular * V_{1,3}\in\C^{l,n-k} rectangular -* +* * V_{2,2}\in\C^{k-l,k-l} unit upper triangular * V_{2,3}\in\C^{k-l,n-k} rectangular * * Where l = floor(k/2) * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} T_{1,2}| * |0 T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -386,20 +475,20 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{1,2}\in\C^{l, k-l} rectangular * * Then, consider the product: -* -* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) -* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 -* +* +* (I - V_1'*T_{1,1}'*V_1)*(I - V_2'*T_{2,2}'*V_2) +* = I - V_1'*T_{1,1}'*V_1 - V_2'*T_{2,2}'*V_2 + V_1'*T_{1,1}'*V_1*V_2'*T_{2,2}'*V_2 +* * Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |---| * |V_1| * |V_2| * |---| -* +* * So, our product is equivalent to the matrix product -* I - V'*T*V +* I - V'*T'*V * This means, we can compute T_{1,1} and T_{2,2}, then use this information * to compute T_{1,2} * @@ -409,14 +498,14 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * * Compute T_{2,2} recursively * - CALL CLARFT(DIRECT, STOREV, N-L, K-L, V(L+1, L+1), LDV, - $ TAU(L+1), T(L+1, L+1), LDT) + CALL CLARFT(DIRECT, STOREV, N-L, K-L, V(L+1,L+1), LDV, + $ TAU(L+1), T(L+1,L+1), LDT) * * Compute T_{1,2} * T_{1,2} = V_{1,2} * - CALL CLACPY('All', L, K-L, V(1, L+1), LDV, T(1, L+1), LDT) + CALL CLACPY('All', L, K - L, V(1,L+1), LDV, T(1, L+1), LDT) * * T_{1,2} = T_{1,2}*V_{2,2}' * @@ -444,6 +533,99 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * CALL CTRMM('Right', 'Upper', 'No transpose', 'Non-unit', L, $ K-L, ONE, T(L+1,L+1), LDT, T(1, L+1), LDT) + ELSE IF(LQT) THEN +* +* Break V apart into 6 components +* +* V = |----------------------| +* |V_{1,1} V_{1,2} V{1,3}| +* |0 V_{2,2} V{2,3}| +* |----------------------| +* +* V_{1,1}\in\C^{l,l} unit upper triangular +* V_{1,2}\in\C^{l,k-l} rectangular +* V_{1,3}\in\C^{l,n-k} rectangular +* +* V_{2,2}\in\C^{k-l,k-l} unit upper triangular +* V_{2,3}\in\C^{k-l,n-k} rectangular +* +* Where l = floor(k/2) +* +* We will construct the T matrix +* T = |---------------| +* |T_{1,1} 0 | +* |T_{2,1} T_{2,2}| +* |---------------| +* +* T is the triangular factor obtained from block reflectors. +* To motivate the structure, assume we have already computed T_{1,1} +* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 +* +* T_{1,1}\in\C^{l, l} lower triangular +* T_{2,2}\in\C^{k-l, k-l} lower triangular +* T_{2,1}\in\C^{k-l, l} rectangular +* +* Then, consider the product: +* +* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) +* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 +* +* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} +* +* Then, we can define the matrix V as +* V = |---| +* |V_1| +* |V_2| +* |---| +* +* So, our product is equivalent to the matrix product +* I - V'*T*V +* This means, we can compute T_{1,1} and T_{2,2}, then use this information +* to compute T_{2,1} +* +* Compute T_{1,1} recursively +* + CALL CLARFT(DIRECT, STOREV, N, L, V, LDV, TAU, T, LDT) +* +* Compute T_{2,2} recursively +* + CALL CLARFT(DIRECT, STOREV, N-L, K-L, V(L+1,L+1), LDV, + $ TAU(L+1), T(L+1,L+1), LDT) + +* +* Compute T_{2,1} +* T_{2,1} = V_{1,2}' +* + DO I = 1, K-L + DO J = 1, L + T(L+I,J) = CONJG(V(J,L+I)) + END DO + END DO +* +* T_{2,1} = V_{2,2}*T_{2,1} +* + CALL CTRMM('Left', 'Upper', 'No Transpose', 'Unit', K-L, L, + $ ONE, V(L+1,L+1), LDV, T(L+1,1), LDT) +* +* T_{2,1} = V_{2,3}*V_{1,3}' + T_{2,1} +* Note: We assume K <= N, and GEMM will do nothing if N=K +* + CALL CGEMM('No Transpose', 'Conjugate', K-L, L, N-K, ONE, + $ V(L+1,K+1), LDV, V(1, K+1), LDV, ONE, T(L+1,1), LDT) +* +* At this point, we have that T_{2,1} = V_2*V_1' +* All that is left is to pre and post multiply by -T_{2,2} and T_{1,1} +* respectively. +* +* T_{2,1} = -T_{2,2}*T_{2,1} +* + CALL CTRMM('Left', 'Lower', 'No Transpose', 'Non-unit', + $ K-L, L, NEG_ONE, T(L+1,L+1), LDT, T(L+1,1), LDT) +* +* T_{2,1} = T_{2,1}*T_{1,1} +* + CALL CTRMM('Right', 'Lower', 'No Transpose', 'Non-unit', + $ K-L, L, ONE, T, LDT, T(L+1,1), LDT) ELSE IF(QL) THEN * * Break V apart into 6 components @@ -456,18 +638,18 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * * V_{1,1}\in\C^{n-k,k-l} rectangular * V_{2,1}\in\C^{k-l,k-l} unit upper triangular -* +* * V_{1,2}\in\C^{n-k,l} rectangular * V_{2,2}\in\C^{k-l,l} rectangular * V_{3,2}\in\C^{l,l} unit upper triangular * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} 0 | * |T_{2,1} T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -478,17 +660,17 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * Where l = floor(k/2) * * Then, consider the product: -* +* * (I - V_2*T_{2,2}*V_2')*(I - V_1*T_{1,1}*V_1') * = I - V_2*T_{2,2}*V_2' - V_1*T_{1,1}*V_1' + V_2*T_{2,2}*V_2'*V_1*T_{1,1}*V_1' -* +* * Define T_{2,1} = -T_{2,2}*V_2'*V_1*T_{1,1} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |-------| * |V_1 V_2| * |-------| -* +* * So, our product is equivalent to the matrix product * I - V*T*V' * This means, we can compute T_{1,1} and T_{2,2}, then use this information @@ -496,34 +678,34 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * * Compute T_{1,1} recursively * - CALL CLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, LDT) + CALL CLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, + $ LDT) * * Compute T_{2,2} recursively * CALL CLARFT(DIRECT, STOREV, N, L, V(1, K-L+1), LDV, - $ TAU(K-L+1), T(K-L+1, K-L+1), LDT) + $ TAU(K-L+1), T(K-L+1,K-L+1), LDT) * * Compute T_{2,1} * T_{2,1} = V_{2,2}' * DO J = 1, K-L DO I = 1, L - T(K-L+I, J) = CONJG(V(N-K+J, K-L+I)) + T(K-L+I,J) = CONJG(V(N-K+J, K-L+I)) END DO END DO * * T_{2,1} = T_{2,1}*V_{2,1} * CALL CTRMM('Right', 'Upper', 'No transpose', 'Unit', L, - $ K-L, ONE, V(N-K+1, 1), LDV, T(K-L+1, 1), LDT) + $ K-L, ONE, V(N-K+1,1), LDV, T(K-L+1,1), LDT) * * T_{2,1} = V_{2,2}'*V_{2,1} + T_{2,1} * Note: We assume K <= N, and GEMM will do nothing if N=K * CALL CGEMM('Conjugate', 'No transpose', L, K-L, N-K, ONE, - $ V(1, K-L+1), LDV, V, LDV, ONE, T(K-L+1, 1), - $ LDT) + $ V(1,K-L+1), LDV, V, LDV, ONE, T(K-L+1,1), LDT) * * At this point, we have that T_{2,1} = V_2'*V_1 * All that is left is to pre and post multiply by -T_{2,2} and T_{1,1} @@ -532,17 +714,13 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{2,1} = -T_{2,2}*T_{2,1} * CALL CTRMM('Left', 'Lower', 'No transpose', 'Non-unit', L, - $ K-L, NEG_ONE, T(K-L+1, K-L+1), LDT, - $ T(K-L+1, 1), LDT) + $ K-L, NEG_ONE, T(K-L+1,K-L+1), LDT, T(K-L+1,1), LDT) * * T_{2,1} = T_{2,1}*T_{1,1} * CALL CTRMM('Right', 'Lower', 'No transpose', 'Non-unit', L, - $ K-L, ONE, T, LDT, T(K-L+1, 1), LDT) - ELSE -* -* Else means RQ case -* + $ K-L, ONE, T, LDT, T(K-L+1,1), LDT) + ELSE IF(RQ) THEN * Break V apart into 6 components * * V = |-----------------------| @@ -557,13 +735,13 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * V_{2,2}\in\C^{l,k-l} rectangular * V_{2,3}\in\C^{l,l} unit lower triangular * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} 0 | * |T_{2,1} T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -574,51 +752,51 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * Where l = floor(k/2) * * Then, consider the product: -* -* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) -* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 -* +* +* (I - V_2'*T_{2,2}'*V_2)*(I - V_1'*T_{1,1}'*V_1) +* = I - V_2'*T_{2,2}'*V_2 - V_1'*T_{1,1}'*V_1 + V_2'*T_{2,2}'*V_2*V_1'*T_{1,1}'*V_1 +* * Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |---| * |V_1| * |V_2| * |---| -* +* * So, our product is equivalent to the matrix product -* I - V'*T*V +* I - V'*T'*V * This means, we can compute T_{1,1} and T_{2,2}, then use this information * to compute T_{2,1} * * Compute T_{1,1} recursively * - CALL CLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, LDT) + CALL CLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, + $ LDT) * * Compute T_{2,2} recursively * CALL CLARFT(DIRECT, STOREV, N, L, V(K-L+1,1), LDV, - $ TAU(K-L+1), T(K-L+1, K-L+1), LDT) + $ TAU(K-L+1), T(K-L+1,K-L+1), LDT) * * Compute T_{2,1} * T_{2,1} = V_{2,2} * - CALL CLACPY('All', L, K-L, V(K-L+1, N-K+1), LDV, - $ T(K-L+1, 1), LDT) + CALL CLACPY('All', L, K-L, V(K-L+1,N-K+1), LDV, T(K-L+1,1), + $ LDT) * * T_{2,1} = T_{2,1}*V_{1,2}' * CALL CTRMM('Right', 'Lower', 'Conjugate', 'Unit', L, K-L, - $ ONE, V(1, N-K+1), LDV, T(K-L+1,1), LDT) + $ ONE, V(1, N-K+1), LDV, T(K-L+1,1), LDT) * * T_{2,1} = V_{2,1}*V_{1,1}' + T_{2,1} * Note: We assume K <= N, and GEMM will do nothing if N=K * - CALL CGEMM('No transpose', 'Conjugate', L, K-L, N-K, ONE, - $ V(K-L+1, 1), LDV, V, LDV, ONE, T(K-L+1, 1), - $ LDT) + CALL CGEMM('No transpose', 'Conjugate', L, K-L, N-K, ONE, + $ V(K-L+1,1), LDV, V, LDV, ONE, T(K-L+1,1), LDT) * * At this point, we have that T_{2,1} = V_2*V_1' @@ -627,14 +805,104 @@ RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, * * T_{2,1} = -T_{2,2}*T_{2,1} * - CALL CTRMM('Left', 'Lower', 'No tranpose', 'Non-unit', L, - $ K-L, NEG_ONE, T(K-L+1, K-L+1), LDT, - $ T(K-L+1, 1), LDT) + CALL CTRMM('Left', 'Lower', 'No transpose', 'Non-unit', L, + $ K-L, NEG_ONE, T(K-L+1,K-L+1), LDT, T(K-L+1,1), LDT) * * T_{2,1} = T_{2,1}*T_{1,1} * - CALL CTRMM('Right', 'Lower', 'No tranpose', 'Non-unit', L, - $ K-L, ONE, T, LDT, T(K-L+1, 1), LDT) + CALL CTRMM('Right', 'Lower', 'No transpose', 'Non-unit', L, + $ K-L, ONE, T, LDT, T(K-L+1,1), LDT) + ELSE IF(RQT) THEN +* Break V apart into 6 components +* +* V = |-----------------------| +* |V_{1,1} V_{1,2} 0 | +* |V_{2,1} V_{2,2} V_{2,3}| +* |-----------------------| +* +* V_{1,1}\in\C^{k-l,n-k} rectangular +* V_{1,2}\in\C^{k-l,k-l} unit lower triangular +* +* V_{2,1}\in\C^{l,n-k} rectangular +* V_{2,2}\in\C^{l,k-l} rectangular +* V_{2,3}\in\C^{l,l} unit lower triangular +* +* We will construct the T matrix +* T = |---------------| +* |T_{1,1} T_{1,2}| +* | 0 T_{2,2}| +* |---------------| +* +* T is the triangular factor obtained from block reflectors. +* To motivate the structure, assume we have already computed T_{1,1} +* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 +* +* T_{1,1}\in\C^{k-l, k-l} non-unit upper triangular +* T_{2,2}\in\C^{l, l} non-unit upper triangular +* T_{1,2}\in\C^{k-l, l} rectangular +* +* Where l = floor(k/2) +* +* Then, consider the product: +* +* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) +* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 +* +* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} +* +* Then, we can define the matrix V as +* V = |---| +* |V_1| +* |V_2| +* |---| +* +* So, our product is equivalent to the matrix product +* I - V'*T*V +* This means, we can compute T_{1,1} and T_{2,2}, then use this information +* to compute T_{1,2} +* +* Compute T_{1,1} recursively +* + CALL CLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, + $ LDT) +* +* Compute T_{2,2} recursively +* + CALL CLARFT(DIRECT, STOREV, N, L, V(K-L+1,1), LDV, + $ TAU(K-L+1), T(K-L+1,K-L+1), LDT) +* +* Compute T_{1,2} +* T_{1,2} = V_{2,2}' +* + DO I = 1, K-L + DO J = 1, L + T(I,K-L+J) = CONJG(V(K-L+J, N-K+I)) + END DO + END DO +* +* T_{1,2} = V_{1,2}T_{1,2} +* + CALL CTRMM('Left', 'Lower', 'No Transpose', 'Unit', K-L, L, + $ ONE, V(1,N-K+1), LDV, T(1,K-L+1), LDT) +* +* T_{1,2} = V_{1,1}V_{2,1}' + T_{1,2} +* + CALL CGEMM('No Transpose', 'Conjugate', K-L, L, N-K, ONE, V, + $ LDV, V(K-L+1,1), LDV, ONE, T(1, K-L+1), LDT) +* +* At this point, we have that T_{1,2} = V_1*V_2' +* All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} +* respectively. +* +* T_{1,2} = -T_{1,1}*T_{1,2} +* + CALL CTRMM('Left', 'Upper', 'No Transpose', 'Non-Unit', + $ K-L, L, NEG_ONE, T, LDT, T(1, K-L+1), LDT) +* +* T_{1,2} = T_{1,2}*T_{2,2} +* + CALL CTRMM('Right', 'Upper', 'No Transpose', 'Non-Unit', + $ K-L, L, ONE, T(K-L+1,K-L+1), LDT, T(1, K-L+1), LDT) END IF END SUBROUTINE diff --git a/lapack-netlib/SRC/clarft_lvl2.c b/lapack-netlib/SRC/clarft_lvl2.c index 90ee71fdbb..7ec4875028 100644 --- a/lapack-netlib/SRC/clarft_lvl2.c +++ b/lapack-netlib/SRC/clarft_lvl2.c @@ -254,29 +254,17 @@ typedef struct Namelist Namelist; static complex c_b1 = {1.f,0.f}; static integer c__1 = 1; -/* > \brief \b CLARFT_LVL2: Level 2 BLAS version for terminating case of CLARFT */ +/* > \brief \b CLARFT_LVL2 forms the triangular factor T of a block reflector H = I - vtvH */ /* =========== DOCUMENTATION =========== */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > Download CLARFT_LVL2 + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ - /* Definition: */ /* =========== */ -/* SUBROUTINE CLARFT_LVL2( DIRECT, STOREV, N, K, V, LDV, TAU, */ -/* T, LDT ) */ +/* SUBROUTINE CLARFT_LVL2( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) */ /* CHARACTER DIRECT, STOREV */ /* INTEGER K, LDT, LDV, N */ @@ -304,6 +292,9 @@ f"> */ /* > H(i) is stored in the i-th row of the array V, and */ /* > */ /* > H = I - V**H * T * V */ +/* > */ +/* > If DIRECT or STOREV = 'T', see Further Details for the shape of T */ +/* > */ /* > \endverbatim */ /* Arguments: */ @@ -316,6 +307,8 @@ f"> */ /* > multiplied to form the block reflector: */ /* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ /* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) */ +/* > but we return the T matrix that is already (conjugate) transposed */ /* > \endverbatim */ /* > */ /* > \param[in] STOREV */ @@ -323,8 +316,10 @@ f"> */ /* > STOREV is CHARACTER*1 */ /* > Specifies how the vectors which define the elementary */ /* > reflectors are stored (see also Further Details): */ -/* > = 'C': columnwise */ -/* > = 'R': rowwise */ +/* > = 'C': column-wise */ +/* > = 'R': row-wise */ +/* > = 'T': (With DIRECT='F') Row-wise, but we return the T */ +/* > matrix that is already (conjugate) transposed. */ /* > \endverbatim */ /* > */ /* > \param[in] N */ @@ -410,6 +405,29 @@ f"> */ /* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ /* > ( 1 v3 ) */ /* > ( 1 ) */ +/* > */ +/* > In addition, the shape of T is determined by these same flags as */ +/* > in the below table. */ +/* > 'U' denotes upper triangular */ +/* > 'L' denotes lower triangular */ +/* > 'X' denotes no current implementation */ +/* > We also provide the logical variable that represents the case */ +/* > in the code if it is implemented */ +/* > */ +/* > |-----------------------------------------------------------| */ +/* > | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | */ +/* > |--------------+--------------+--------------+--------------| */ +/* > | STOREV = 'C' | U (QR) | L (QL) | X | */ +/* > | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | */ +/* > | STOREV = 'T' | L (LQT) | X | X | */ +/* > |-----------------------------------------------------------| */ +/* > */ +/* > Finally, the relationship between the (conjugate) transposed T matrices */ +/* > are as follows: (Note that T_{FC} denotes the T associated with calling */ +/* > this routine with DIRECT = 'F' and STOREV = 'C') */ +/* > */ +/* > T_{TR} = (T_{BR})**H */ +/* > T_{FT} = (T_{FR})**H */ /* > \endverbatim */ /* > */ /* ===================================================================== */ @@ -422,16 +440,21 @@ f"> */ complex q__1, q__2, q__3; /* Local variables */ - integer i__, j, prevlastv; + integer i__, j; + logical lq, ql, qr, rq; + integer kmi, nmi; + logical lqt, rqt, dirb, dirf; + integer info; + logical dirt; extern /* Subroutine */ void cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), cgemv_(char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); extern logical lsame_(char *, char *); - integer lastv; extern /* Subroutine */ void ctrmv_(char *, char *, char *, integer *, - complex *, integer *, complex *, integer *), mecago_(); + complex *, integer *, complex *, integer *), xerbla_(char *, integer *, ftnlen); + logical storec, storer, storet; /* -- LAPACK auxiliary routine -- */ @@ -439,10 +462,18 @@ f"> */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* ===================================================================== */ -/* Quick return if possible */ + + + + + + + + + +/* Convert our character flags to logical flags for later */ /* Parameter adjustments */ v_dim1 = *ldv; @@ -454,212 +485,635 @@ f"> */ t -= t_offset; /* Function Body */ - if (*n == 0) { + dirf = lsame_(direct, "F"); + dirb = lsame_(direct, "B"); + dirt = lsame_(direct, "T"); + storec = lsame_(storev, "C"); + storer = lsame_(storev, "R"); + storet = lsame_(storev, "T"); + +/* Error handling for our character flags */ + + info = 0; + if (! (dirf || dirb || dirt)) { + +/* DIRECT holds an illegal value */ + + info = 1; + } else if (! (storec || storer || storet)) { + +/* STOREV holds an illegal value */ + + info = 2; + } else if (dirb && storet) { + +/* This case is purposefully not implemented, but any other value for */ +/* STOREV is valid, so we report STOREV as the invalid input */ + + info = 2; + } else if (dirt && storec) { + +/* This case is purposefully not implemented, but any other value for */ +/* DIRECT is valid, so we report DIRECT as the invalid input */ + + info = 1; + } else if (dirt && storet) { + +/* This case is purposefully not implemented, and is ambiguous what */ +/* the user wants to do, so we arbitrarily say DIRECT is the incorrect */ +/* character flag. */ + + info = 1; + } + if (info != 0) { + xerbla_("CLARFT_LVL2", &info, (ftnlen)11); + return; + } + +/* Quick return if possible */ + + if (*n == 0 || *k == 0) { + return; + } + +/* Now we determine what factorization our flags are associated with */ + +/* QR happens when we have forward direction in column storage */ + + qr = dirf && storec; + +/* LQT happens when we have forward direction in row storage and want to compute the transpose of */ +/* the T we would normally compute */ + + lqt = dirf && storet; + +/* LQ happens when we have forward direction in row storage and want to compute the T we would */ +/* normally compute */ + + lq = dirf && storer; + +/* QL happens when we have backward direction in column storage */ + + ql = dirb && storec; + +/* RQT happens when we have backward direction in row storage and want to compute the transpose */ +/* of the T we would normally compute */ + + rqt = dirt && storer; + +/* RQ happens when we have backward direction in row storage and want to compute the T that we */ +/* would normally compute */ + + rq = dirb && storer; + if (*n == 1 || *k == 1) { + if (lqt || rqt) { + i__1 = t_dim1 + 1; + r_cnjg(&q__1, &tau[1]); + t[i__1].r = q__1.r, t[i__1].i = q__1.i; + } else { + i__1 = t_dim1 + 1; + t[i__1].r = tau[1].r, t[i__1].i = tau[1].i; + } return; } + if (qr) { + +/* Break V into 9 components */ + +/* V = |-----------------------| */ +/* |V_{1,1} 0 0 | i-1 */ +/* |V_{2,1} V_{2,2} 0 | 1 */ +/* |V_{3,1} V_{3,2} V_{3,3}| n-i */ +/* |-----------------------| */ +/* i-1 1 k-i */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{3,3} and repeat until we */ +/* reach the end. On each iteration V_{3,3} is not referenced */ + +/* We will construct T one column at a time from left to right */ +/* after initializing T(1,1) = TAU(1) */ + +/* T = |-------------------------| */ +/* | T_{1,1} T_{1,2} T_{1,3} | i-1 */ +/* | 0 T_{2,2} T_{2,3} | 1 */ +/* | 0 0 T_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 k-i */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{1,2} and T_{2,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On */ +/* each iteration, T_{1:3,3} are not referenced. See clarft.f */ +/* for details on how these formulae were constructed. */ + +/* We now get */ + +/* T_{1,2} = -T_{1,1}[V_{1,1}\\V_{2,1}\\V_{3,1}]' */ +/* [0\\V_{2,2}\\V_{3,2}]T_{2,2} */ + +/* T_{1,2} = -T_{1,1}(V_{2,1}' + V_{3,1}'V_{3,2})T_{2,2} */ + +/* This means we will do the following */ + +/* T_{1,2} = -V_{2,1}'T_{2,2} = -\tau_{i}V_{2,1}' */ +/* T_{1,2} = -\tau_{i}V_{3,2}' V_{3,1} + T_{1,2} */ +/* T_{1,2} = T_{1,1}T_{1,2} */ +/* T_{2,2} = \tau{i} */ + + i__1 = t_dim1 + 1; + t[i__1].r = tau[1].r, t[i__1].i = tau[1].i; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T_{1,2} = -V_{2,1}'V_{2,2}T_{2,2} = -\tau_i V_{2,1}' */ +/* We must do this at copy time as otherwise gemv will do nothing */ +/* on the last column when n=k, but we neet to make sure we are */ +/* scaled by this value */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + i__4 = i__; + q__2.r = -tau[i__4].r, q__2.i = -tau[i__4].i; + r_cnjg(&q__3, &v[i__ + j * v_dim1]); + q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * + q__3.i + q__2.i * q__3.r; + t[i__3].r = q__1.r, t[i__3].i = q__1.i; + } + +/* T_{1,2} = -V_{3,1}'V_{3,2}T_{2,2} + T_{1,2} */ +/* = -\tau{i} V_{3,2}'V_{3,1} + T_{1,2} */ + + i__2 = *n - i__; + i__3 = i__ - 1; + i__4 = i__; + q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i; + cgemv_("Conjugate Transpose", &i__2, &i__3, &q__1, &v[i__ + 1 + + v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, &c_b1, & + t[i__ * t_dim1 + 1], &c__1); + +/* T_{1,2} = T_{1,1}T_{1,2} */ + + i__2 = i__ - 1; + ctrmv_("Upper", "No Transpose", "Non-unit", &i__2, &t[t_offset], + ldt, &t[i__ * t_dim1 + 1], &c__1); + +/* T_{2,2} = \tau{i} */ + + i__2 = i__ + i__ * t_dim1; + i__3 = i__; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + } + } else if (lq) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} V_{1,2} V_{1,3} | i-1 */ +/* | 0 V_{2,2} V_{2,3} | 1 */ +/* | 0 0 V_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 n-i */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{3,3} and repeat until we */ +/* reach the end. On each iteration V_{3,3} is not referenced */ + +/* We will construct T one column at a time from left to right */ +/* after initializing T(1,1) = TAU(1) */ + +/* T = |-------------------------| */ +/* | T_{1,1} T_{1,2} T_{1,3} | i-1 */ +/* | 0 T_{2,2} T_{2,3} | 1 */ +/* | 0 0 T_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 k-i */ + +/* Similarly as above, we will construct T_{1,2} and T_{2,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On */ +/* each iteration, T_{1:3,3} are not referenced. See clarft.f */ +/* for details on how these formulae were constructed. */ + +/* We now get */ + +/* T_{1,2} = -T_{1,1}[V_{1,1} V_{1,2} V_{1,3}][ 0 V_{2,2} V_{2,3} ]'T_{2,2} */ + +/* T_{1,2} = -T_{1,1}(V_{1,2} + V_{1,3}V_{2,3}')T_{2,2} */ + +/* This means we will do the following */ + +/* T_{1,2} = -V_{1,2}T_{2,2} = -\tau_{i}V_{1,2} */ +/* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} */ +/* T_{1,2} = T_{1,1}T_{1,2} */ +/* T_{2,2} = \tau{i} */ + + i__1 = t_dim1 + 1; + t[i__1].r = tau[1].r, t[i__1].i = tau[1].i; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T_{1,2} = -\tau_{i}V_{1,2} */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + i__4 = i__; + q__2.r = -tau[i__4].r, q__2.i = -tau[i__4].i; + i__5 = j + i__ * v_dim1; + q__1.r = q__2.r * v[i__5].r - q__2.i * v[i__5].i, q__1.i = + q__2.r * v[i__5].i + q__2.i * v[i__5].r; + t[i__3].r = q__1.r, t[i__3].i = q__1.i; + } + +/* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + i__4 = i__; + q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i; + cgemm_("No Transpose", "Conjugate Transpose", &i__2, &c__1, &i__3, + &q__1, &v[(i__ + 1) * v_dim1 + 1], ldv, &v[i__ + (i__ + + 1) * v_dim1], ldv, &c_b1, &t[i__ * t_dim1 + 1], ldt); + +/* T_{1,2} = T_{1,1}T_{1,2} */ + + i__2 = i__ - 1; + ctrmv_("Upper", "No Transpose", "Non-unit", &i__2, &t[t_offset], + ldt, &t[i__ * t_dim1 + 1], &c__1); + +/* T_{2,2} = \tau{i} */ + + i__2 = i__ + i__ * t_dim1; + i__3 = i__; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + } + } else if (lqt) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} V_{1,2} V_{1,3} | i-1 */ +/* | 0 V_{2,2} V_{2,3} | 1 */ +/* | 0 0 V_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 n-i */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{3,3} and repeat until we */ +/* reach the end. On each iteration V_{3,3} is not referenced */ + +/* We will construct T one column at a time from left to right */ +/* after initializing T(1,1) = TAU(1) */ + +/* T = |-------------------------| */ +/* | T_{1,1} 0 0 | i-1 */ +/* | T_{2,1} T_{2,2} 0 | 1 */ +/* | T_{3,1} T_{3,2} T_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 k-i */ + +/* Similarly as above, we will construct T_{2,1} and T_{2,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{3,1:3}. On */ +/* each iteration, T_{3,1:3} are not referenced. See clarft.f */ +/* for details on how these formulae were constructed. */ + +/* We now get */ + +/* T_{2,1} = -T_{2,2}[0 V_{2,2} V_{2,3}][V_{1,1} V_{1,2} V_{1,3}]'T_{1,1} */ + +/* T_{2,1} = -T_{2,2}(V_{1,2}' + V_{2,3}V_{1,3}')T_{1,1} */ + +/* This means we will do the following */ + +/* T_{2,1} = -T_{2,2}V_{1,2}' = -\tau_{i}V_{1,2}' */ +/* T_{2,1} = -\tau_{i}V_{1,3}V_{2,3}' + T_{2,1} */ +/* T_{2,1} = T_{1,1}'T_{2,1} */ +/* T_{2,2} = \tau{i} */ + + i__1 = t_dim1 + 1; + r_cnjg(&q__1, &tau[1]); + t[i__1].r = q__1.r, t[i__1].i = q__1.i; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T_{2,1} = -\tau_{i}V_{1,2}' */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * t_dim1; + i__4 = i__; + i__5 = j + i__ * v_dim1; + q__3.r = tau[i__4].r * v[i__5].r - tau[i__4].i * v[i__5].i, + q__3.i = tau[i__4].r * v[i__5].i + tau[i__4].i * v[ + i__5].r; + r_cnjg(&q__2, &q__3); + q__1.r = -q__2.r, q__1.i = -q__2.i; + t[i__3].r = q__1.r, t[i__3].i = q__1.i; + } + +/* T_{2,1} = -\tau_{i}V_{2,3}V_{1,3}' + T_{2,1} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + r_cnjg(&q__2, &tau[i__]); + q__1.r = -q__2.r, q__1.i = -q__2.i; + cgemm_("No Transpose", "Conjugate Transpose", &c__1, &i__2, &i__3, + &q__1, &v[i__ + (i__ + 1) * v_dim1], ldv, &v[(i__ + 1) * + v_dim1 + 1], ldv, &c_b1, &t[i__ + t_dim1], ldt); + +/* T_{2,1} = T_{1,1}'T_{2,1} */ + + i__2 = i__ - 1; + ctrmv_("Lower", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt, + &t[i__ + t_dim1], ldt); + i__2 = i__ + i__ * t_dim1; + r_cnjg(&q__1, &tau[i__]); + t[i__2].r = q__1.r, t[i__2].i = q__1.i; + } + } else if (ql) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} V_{1,2} V_{1,3} | n-i */ +/* | 0 V_{2,2} V_{2,3} | 1 */ +/* | 0 0 V_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{1,1} and repeat until we */ +/* reach the end. On each iteration V_{1,1} is not referenced */ + +/* We will construct T one column at a time from right to left */ +/* after initializing T(K,K) = TAU(K) */ + +/* T = |-------------------------| */ +/* | T_{1,1} 0 0 | k-i */ +/* | T_{2,1} T_{2,2} 0 | 1 */ +/* | T_{3,1} T_{3,2} T_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{2,2} and T_{3,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On */ +/* each iteration, T_{1:3,1} are not referenced. See clarft.f */ +/* for details on how these formulae were constructed. */ + +/* We get that */ + +/* T_{3,2} = -T_{3,3}[V_{1,3}\\V_{2,3}\\V_{3,3}]' */ +/* [V_{1,2}\\V_{2,2}\\0]T_{2,2} */ + +/* T_{3,2} = -T_{3,3}(V_{1,3}'V_{1,2} + V_{2,3}')T_{2,2} */ + +/* Thus, we will compute */ + +/* T_{2,2} = \tau_{k-i+1} */ +/* T_{3,2} = -T_{3,3}V_{3,2}' = -\tau_{k-i+1}V_{3,2}' */ +/* T_{3,2} = -\tau_{k-i+1}V_{1,3}'V_{1,2} + T_{3,2} */ +/* T_{3,2} = T_{3,3}T_{3,2} */ + + i__1 = *k + *k * t_dim1; + i__2 = *k; + t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + kmi = *k - i__ + 1; + nmi = *n - i__ + 1; + +/* T_{2,2} = \tau(k-i+1) */ + + i__2 = kmi + kmi * t_dim1; + i__3 = kmi; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + +/* T_{3,2} = -\tau(k-i+1)V_{2,3}' */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = kmi + j + kmi * t_dim1; + i__4 = kmi; + q__2.r = -tau[i__4].r, q__2.i = -tau[i__4].i; + r_cnjg(&q__3, &v[nmi + (kmi + j) * v_dim1]); + q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * + q__3.i + q__2.i * q__3.r; + t[i__3].r = q__1.r, t[i__3].i = q__1.i; + } + +/* T_{3,2} = -\tau(k-i+1)V_{1,3}'V_{1,2} + T_{3,2} */ + + i__2 = *n - i__; + i__3 = i__ - 1; + i__4 = kmi; + q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i; + cgemv_("Conjugate Transpose", &i__2, &i__3, &q__1, &v[(kmi + 1) * + v_dim1 + 1], ldv, &v[kmi * v_dim1 + 1], &c__1, &c_b1, &t[ + kmi + 1 + kmi * t_dim1], &c__1); + +/* T_{3,2} = T_{3,3}T_{3,2} */ + + i__2 = i__ - 1; + ctrmv_("Lower", "No Transpose", "Non-unit", &i__2, &t[kmi + 1 + ( + kmi + 1) * t_dim1], ldt, &t[kmi + 1 + kmi * t_dim1], & + c__1); + } + } else if (rq) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} 0 0 | k-i */ +/* | V_{2,1} V_{2,2} 0 | 1 */ +/* | V_{3,1} V_{3,2} V_{3,3} | i-1 */ +/* |-------------------------| */ +/* n-i 1 i-1 */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{1,1} and repeat until we */ +/* reach the end. On each iteration V_{1,1} is not referenced */ + +/* We will construct T one column at a time from right to left */ +/* after initializing T(K,K) = TAU(K) */ - if (lsame_(direct, "F")) { - prevlastv = *n; +/* T = |-------------------------| */ +/* | T_{1,1} 0 0 | k-i */ +/* | T_{2,1} T_{2,2} 0 | 1 */ +/* | T_{3,1} T_{3,2} T_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{2,2} and T_{3,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On */ +/* each iteration, T_{1:3,1} are not referenced. See clarft.f */ +/* for details on how these formulae were constructed. */ + +/* We get that */ + +/* T_{3,2} = -T_{3,3}[V_{3,1} V_{3,2} V_{3,3}][V_{2,1} V_{2,2} 0]'T_{2,2} */ + +/* T_{3,2} = -T_{3,3}(V_{3,1}V_{2,1}' + V_{3,2})T_{2,2} */ + +/* Thus, we will compute */ + +/* T_{2,2} = \tau_{k-i+1} */ +/* T_{3,2} = -\tau_{k-i+1}V_{3,2} */ +/* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} */ +/* T_{3,2} = T_{3,3}T_{3,2} */ + + i__1 = *k + *k * t_dim1; + i__2 = *k; + t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - prevlastv = f2cmax(prevlastv,i__); - i__2 = i__; - if (tau[i__2].r == 0.f && tau[i__2].i == 0.f) { - -/* H(i) = I */ - - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - i__3 = j + i__ * t_dim1; - t[i__3].r = 0.f, t[i__3].i = 0.f; - } - } else { - -/* general case */ - - if (lsame_(storev, "C")) { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - i__3 = lastv + i__ * v_dim1; - if (v[i__3].r != 0.f || v[i__3].i != 0.f) { - myexit_(); - } - } - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - i__3 = j + i__ * t_dim1; - i__4 = i__; - q__2.r = -tau[i__4].r, q__2.i = -tau[i__4].i; - r_cnjg(&q__3, &v[i__ + j * v_dim1]); - q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = - q__2.r * q__3.i + q__2.i * q__3.r; - t[i__3].r = q__1.r, t[i__3].i = q__1.i; - } - j = f2cmin(lastv,prevlastv); - -/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) */ - - i__2 = j - i__; - i__3 = i__ - 1; - i__4 = i__; - q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i; - cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &v[i__ - + 1 + v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], & - c__1, &c_b1, &t[i__ * t_dim1 + 1], &c__1); - } else { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - i__3 = i__ + lastv * v_dim1; - if (v[i__3].r != 0.f || v[i__3].i != 0.f) { - myexit_(); - } - } - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - i__3 = j + i__ * t_dim1; - i__4 = i__; - q__2.r = -tau[i__4].r, q__2.i = -tau[i__4].i; - i__5 = j + i__ * v_dim1; - q__1.r = q__2.r * v[i__5].r - q__2.i * v[i__5].i, - q__1.i = q__2.r * v[i__5].i + q__2.i * v[i__5] - .r; - t[i__3].r = q__1.r, t[i__3].i = q__1.i; - } - j = f2cmin(lastv,prevlastv); - -/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H */ - - i__2 = i__ - 1; - i__3 = j - i__; - i__4 = i__; - q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i; - cgemm_("N", "C", &i__2, &c__1, &i__3, &q__1, &v[(i__ + 1) - * v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], - ldv, &c_b1, &t[i__ * t_dim1 + 1], ldt); - } - -/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ - - i__2 = i__ - 1; - ctrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ - t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); - i__2 = i__ + i__ * t_dim1; - i__3 = i__; - t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; - if (i__ > 1) { - prevlastv = f2cmax(prevlastv,lastv); - } else { - prevlastv = lastv; - } + for (i__ = 2; i__ <= i__1; ++i__) { + kmi = *k - i__ + 1; + nmi = *n - i__ + 1; + +/* T_{2,2} = \tau_{k-i+1} */ + + i__2 = kmi + kmi * t_dim1; + i__3 = kmi; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + +/* T_{3,2} = -\tau_{k-i+1}V_{3,2} */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = kmi + j + kmi * t_dim1; + i__4 = kmi; + q__2.r = -tau[i__4].r, q__2.i = -tau[i__4].i; + i__5 = kmi + j + nmi * v_dim1; + q__1.r = q__2.r * v[i__5].r - q__2.i * v[i__5].i, q__1.i = + q__2.r * v[i__5].i + q__2.i * v[i__5].r; + t[i__3].r = q__1.r, t[i__3].i = q__1.i; } + +/* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + i__4 = kmi; + q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i; + cgemm_("No Transpose", "Conjugate Transpose", &i__2, &c__1, &i__3, + &q__1, &v[kmi + 1 + v_dim1], ldv, &v[kmi + v_dim1], ldv, + &c_b1, &t[kmi + 1 + kmi * t_dim1], ldt); + +/* T_{3,2} = T_{3,3}T_{3,2} */ + + i__2 = i__ - 1; + ctrmv_("Lower", "No Transpose", "Non-unit", &i__2, &t[kmi + 1 + ( + kmi + 1) * t_dim1], ldt, &t[kmi + 1 + kmi * t_dim1], & + c__1); } - } else { - prevlastv = 1; - for (i__ = *k; i__ >= 1; --i__) { - i__1 = i__; - if (tau[i__1].r == 0.f && tau[i__1].i == 0.f) { - -/* H(i) = I */ - - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - i__2 = j + i__ * t_dim1; - t[i__2].r = 0.f, t[i__2].i = 0.f; - } - } else { - -/* general case */ - - if (i__ < *k) { - if (lsame_(storev, "C")) { -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - i__2 = lastv + i__ * v_dim1; - if (v[i__2].r != 0.f || v[i__2].i != 0.f) { - myexit_(); - } - } - i__1 = *k; - for (j = i__ + 1; j <= i__1; ++j) { - i__2 = j + i__ * t_dim1; - i__3 = i__; - q__2.r = -tau[i__3].r, q__2.i = -tau[i__3].i; - r_cnjg(&q__3, &v[*n - *k + i__ + j * v_dim1]); - q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, - q__1.i = q__2.r * q__3.i + q__2.i * - q__3.r; - t[i__2].r = q__1.r, t[i__2].i = q__1.i; - } - j = f2cmax(lastv,prevlastv); - -/* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) */ - - i__1 = *n - *k + i__ - j; - i__2 = *k - i__; - i__3 = i__; - q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i; - cgemv_("Conjugate transpose", &i__1, &i__2, &q__1, &v[ - j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * - v_dim1], &c__1, &c_b1, &t[i__ + 1 + i__ * - t_dim1], &c__1); - } else { -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - i__2 = i__ + lastv * v_dim1; - if (v[i__2].r != 0.f || v[i__2].i != 0.f) { - myexit_(); - } - } - i__1 = *k; - for (j = i__ + 1; j <= i__1; ++j) { - i__2 = j + i__ * t_dim1; - i__3 = i__; - q__2.r = -tau[i__3].r, q__2.i = -tau[i__3].i; - i__4 = j + (*n - *k + i__) * v_dim1; - q__1.r = q__2.r * v[i__4].r - q__2.i * v[i__4].i, - q__1.i = q__2.r * v[i__4].i + q__2.i * v[ - i__4].r; - t[i__2].r = q__1.r, t[i__2].i = q__1.i; - } - j = f2cmax(lastv,prevlastv); - -/* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H */ - - i__1 = *k - i__; - i__2 = *n - *k + i__ - j; - i__3 = i__; - q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i; - cgemm_("N", "C", &i__1, &c__1, &i__2, &q__1, &v[i__ + - 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], - ldv, &c_b1, &t[i__ + 1 + i__ * t_dim1], ldt); - } - -/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ - - i__1 = *k - i__; - ctrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ - + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * - t_dim1], &c__1) - ; - if (i__ > 1) { - prevlastv = f2cmin(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - i__1 = i__ + i__ * t_dim1; - i__2 = i__; - t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; + } else if (rqt) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} 0 0 | k-i */ +/* | V_{2,1} V_{2,2} 0 | 1 */ +/* | V_{3,1} V_{3,2} V_{3,3} | i-1 */ +/* |-------------------------| */ +/* n-i 1 i-1 */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{1,1} and repeat until we */ +/* reach the end. On each iteration V_{1,1} is not referenced */ + +/* We will construct T one column at a time from right to left */ +/* after initializing T(K,K) = TAU(K) */ + +/* T = |-------------------------| */ +/* | T_{1,1} T_{1,2} T_{1,3} | k-i */ +/* | 0 T_{2,2} T_{2,3} | 1 */ +/* | 0 0 T_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{2,2} and T_{2,3} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1,1:3}. On */ +/* each iteration, T_{1,1:3} are not referenced. See clarft.f */ +/* for details on how these formulae were constructed. */ + +/* We get that */ + +/* T_{2,3} = -T_{2,2}[V_{2,1} V_{2,2} 0][V_{3,1} V_{3,2} V_{3,3}]'T_{3,3} */ + +/* T_{3,2} = -T_{2,2}(V_{2,1}V_{3,1}' + V_{3,2}')T_{3,3} */ + +/* Thus, we will compute */ + +/* T_{2,2} = \tau_{k-i+1} */ +/* T_{2,3} = -\tau_{k-i+1}V_{3,2}' */ +/* T_{2,3} = -\tau_{k-i+1}V_{2,1}V_{3,1}' + T_{2,3} */ +/* T_{2,3} = T_{3,3}'T_{2,3} */ + + i__1 = *k + *k * t_dim1; + r_cnjg(&q__1, &tau[*k]); + t[i__1].r = q__1.r, t[i__1].i = q__1.i; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + kmi = *k - i__ + 1; + nmi = *n - i__ + 1; + +/* T_{2,2} = \tau_{k-i+1} */ + + i__2 = kmi + kmi * t_dim1; + r_cnjg(&q__1, &tau[kmi]); + t[i__2].r = q__1.r, t[i__2].i = q__1.i; + +/* T_{2,3} = -\tau_{k-i+1}V_{3,2}' */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = kmi + (kmi + j) * t_dim1; + i__4 = kmi; + i__5 = kmi + j + nmi * v_dim1; + q__3.r = tau[i__4].r * v[i__5].r - tau[i__4].i * v[i__5].i, + q__3.i = tau[i__4].r * v[i__5].i + tau[i__4].i * v[ + i__5].r; + r_cnjg(&q__2, &q__3); + q__1.r = -q__2.r, q__1.i = -q__2.i; + t[i__3].r = q__1.r, t[i__3].i = q__1.i; } + +/* T_{2,3} = -\tau_{k-i+1}V_{2,1}V_{3,1}' + T_{2,3} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + r_cnjg(&q__2, &tau[kmi]); + q__1.r = -q__2.r, q__1.i = -q__2.i; + cgemm_("No Transpose", "Conjugate Transpose", &c__1, &i__2, &i__3, + &q__1, &v[kmi + v_dim1], ldv, &v[kmi + 1 + v_dim1], ldv, + &c_b1, &t[kmi + (kmi + 1) * t_dim1], ldt); + +/* T_{2,3} = T_{3,3}'T_{2,3} */ + + i__2 = i__ - 1; + ctrmv_("Upper", "Transpose", "Non-unit", &i__2, &t[kmi + 1 + (kmi + + 1) * t_dim1], ldt, &t[kmi + (kmi + 1) * t_dim1], ldt); } } return; - -/* End of CLARFT_LVL2 */ - } /* clarft_lvl2__ */ diff --git a/lapack-netlib/SRC/clarft_lvl2.f b/lapack-netlib/SRC/clarft_lvl2.f index 3b0aea1132..0dca6c0dc5 100644 --- a/lapack-netlib/SRC/clarft_lvl2.f +++ b/lapack-netlib/SRC/clarft_lvl2.f @@ -1,23 +1,14 @@ -*> \brief \b CLARFT_LVL2: Level 2 BLAS version for terminating case of CLARFT +*> \brief \b CLARFT_LVL2 forms the triangular factor T of a block reflector H = I - vtvH * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> Download CLARFT_LVL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -* * Definition: * =========== * -* SUBROUTINE CLARFT_LVL2( DIRECT, STOREV, N, K, V, LDV, TAU, -* T, LDT ) +* SUBROUTINE CLARFT_LVL2( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV @@ -49,6 +40,9 @@ *> H(i) is stored in the i-th row of the array V, and *> *> H = I - V**H * T * V +*> +*> If DIRECT or STOREV = 'T', see Further Details for the shape of T +*> *> \endverbatim * * Arguments: @@ -61,6 +55,8 @@ *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) +*> = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) +*> but we return the T matrix that is already (conjugate) transposed *> \endverbatim *> *> \param[in] STOREV @@ -68,8 +64,10 @@ *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise +*> = 'C': column-wise +*> = 'R': row-wise +*> = 'T': (With DIRECT='F') Row-wise, but we return the T +*> matrix that is already (conjugate) transposed. *> \endverbatim *> *> \param[in] N @@ -155,6 +153,29 @@ *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) +*> +*> In addition, the shape of T is determined by these same flags as +*> in the below table. +*> 'U' denotes upper triangular +*> 'L' denotes lower triangular +*> 'X' denotes no current implementation +*> We also provide the logical variable that represents the case +*> in the code if it is implemented +*> +*> |-----------------------------------------------------------| +*> | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | +*> |--------------+--------------+--------------+--------------| +*> | STOREV = 'C' | U (QR) | L (QL) | X | +*> | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | +*> | STOREV = 'T' | L (LQT) | X | X | +*> |-----------------------------------------------------------| +*> +*> Finally, the relationship between the (conjugate) transposed T matrices +*> are as follows: (Note that T_{FC} denotes the T associated with calling +*> this routine with DIRECT = 'F' and STOREV = 'C') +*> +*> T_{TR} = (T_{BR})**H +*> T_{FT} = (T_{FR})**H *> \endverbatim *> * ===================================================================== @@ -170,159 +191,568 @@ SUBROUTINE CLARFT_LVL2( DIRECT, STOREV, N, K, V, LDV, TAU, INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. +* COMPLEX T( LDT, * ), TAU( * ), V( LDV, * ) * .. * -* ===================================================================== -* * .. Parameters .. - COMPLEX ONE, ZERO - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), - $ ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. +* + COMPLEX ONE + PARAMETER(ONE=(1.0E+0,0.0E+0)) +* * .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV -* .. +* + INTEGER I,J,KMI,NMI,INFO + LOGICAL QR, LQ, QL, RQ, LQT, RQT, + $ DIRF, DIRB, DIRT, + $ STOREC, STORER, STORET +* * .. External Subroutines .. - EXTERNAL CGEMM, CGEMV, CTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME +* + EXTERNAL CTRMV,CGEMV,CGEMM,XERBLA +* +* .. External Functions.. +* + LOGICAL LSAME + EXTERNAL LSAME +* +* .. Intrinsic Functions.. +* + INTRINSIC CONJG * .. * .. Executable Statements .. * +* Convert our character flags to logical flags for later +* + DIRF = LSAME(DIRECT,'F') + DIRB = LSAME(DIRECT,'B') + DIRT = LSAME(DIRECT,'T') + STOREC = LSAME(STOREV,'C') + STORER = LSAME(STOREV,'R') + STORET = LSAME(STOREV,'T') +* +* Error handling for our character flags +* + INFO = 0 + IF( .NOT.(DIRF.OR.DIRB.OR.DIRT) ) THEN +* +* DIRECT holds an illegal value +* + INFO = 1 + ELSE IF( .NOT.(STOREC.OR.STORER.OR.STORET) ) THEN +* +* STOREV holds an illegal value +* + INFO = 2 + ELSE IF( DIRB.AND.STORET ) THEN +* +* This case is purposefully not implemented, but any other value for +* STOREV is valid, so we report STOREV as the invalid input +* + INFO = 2 + ELSE IF( DIRT.AND.STOREC ) THEN +* +* This case is purposefully not implemented, but any other value for +* DIRECT is valid, so we report DIRECT as the invalid input +* + INFO = 1 + ELSE IF( DIRT.AND.STORET ) THEN +* +* This case is purposefully not implemented, and is ambiguous what +* the user wants to do, so we arbitrarily say DIRECT is the incorrect +* character flag. +* + INFO = 1 + END IF + + IF( INFO.NE.0 ) THEN + CALL XERBLA('CLARFT_LVL2', INFO) + RETURN + END IF +* * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO I = 1, K - PREVLASTV = MAX( PREVLASTV, I ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = 1, I - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * CONJG( V( I , J ) ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) -* - CALL CGEMV( 'Conjugate transpose', J-I, I-1, - $ -TAU( I ), V( I+1, 1 ), LDV, - $ V( I+1, I ), 1, - $ ONE, T( 1, I ), 1 ) - ELSE -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( J , I ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H -* - CALL CGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, - $ ONE, T( 1, I ), LDT ) - END IF -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL CTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF + IF(N.EQ.0.OR.K.EQ.0) THEN + RETURN + END IF +* +* Now we determine what factorization our flags are associated with +* +* QR happens when we have forward direction in column storage +* + QR = DIRF.AND.STOREC +* +* LQT happens when we have forward direction in row storage and want to compute the transpose of +* the T we would normally compute +* + LQT = DIRF.AND.STORET +* +* LQ happens when we have forward direction in row storage and want to compute the T we would +* normally compute +* + LQ = DIRF.AND.STORER +* +* QL happens when we have backward direction in column storage +* + QL = DIRB.AND.STOREC +* +* RQT happens when we have backward direction in row storage and want to compute the transpose +* of the T we would normally compute +* + RQT = DIRT.AND.STORER +* +* RQ happens when we have backward direction in row storage and want to compute the T that we +* would normally compute +* + RQ = DIRB.AND.STORER + IF( N.EQ.1.OR.K.EQ.1) THEN + IF( LQT.OR.RQT ) THEN + T(1,1) = CONJG(TAU(1)) + ELSE + T(1,1) = TAU(1) + END IF + RETURN + END IF + IF (QR) THEN +* +* Break V into 9 components +* +* V = |-----------------------| +* |V_{1,1} 0 0 | i-1 +* |V_{2,1} V_{2,2} 0 | 1 +* |V_{3,1} V_{3,2} V_{3,3}| n-i +* |-----------------------| +* i-1 1 k-i +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{3,3} and repeat until we +* reach the end. On each iteration V_{3,3} is not referenced +* +* We will construct T one column at a time from left to right +* after initializing T(1,1) = TAU(1) +* +* T = |-------------------------| +* | T_{1,1} T_{1,2} T_{1,3} | i-1 +* | 0 T_{2,2} T_{2,3} | 1 +* | 0 0 T_{3,3} | k-i +* |-------------------------| +* i-1 1 k-i +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{1,2} and T_{2,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On +* each iteration, T_{1:3,3} are not referenced. See clarft.f +* for details on how these formulae were constructed. +* +* We now get +* +* T_{1,2} = -T_{1,1}[V_{1,1}\\V_{2,1}\\V_{3,1}]' +* [0\\V_{2,2}\\V_{3,2}]T_{2,2} +* +* T_{1,2} = -T_{1,1}(V_{2,1}' + V_{3,1}'V_{3,2})T_{2,2} +* +* This means we will do the following +* +* T_{1,2} = -V_{2,1}'T_{2,2} = -\tau_{i}V_{2,1}' +* T_{1,2} = -\tau_{i}V_{3,2}' V_{3,1} + T_{1,2} +* T_{1,2} = T_{1,1}T_{1,2} +* T_{2,2} = \tau{i} +* + T(1,1) = TAU(1) + + DO I = 2, K +* +* T_{1,2} = -V_{2,1}'V_{2,2}T_{2,2} = -\tau_i V_{2,1}' +* We must do this at copy time as otherwise gemv will do nothing +* on the last column when n=k, but we neet to make sure we are +* scaled by this value +* + DO J = 1, I-1 + T(J,I) = -TAU(I)*CONJG(V(I,J)) + END DO + +* +* T_{1,2} = -V_{3,1}'V_{3,2}T_{2,2} + T_{1,2} +* = -\tau{i} V_{3,2}'V_{3,1} + T_{1,2} +* + CALL CGEMV('Conjugate Transpose', N-I, I-1, -TAU(I), + $ V(I+1,1), LDV, V(I+1,I), 1, ONE, T(1, I), 1) + + +* +* T_{1,2} = T_{1,1}T_{1,2} +* + CALL CTRMV('Upper', 'No Transpose', 'Non-unit', I-1, + $ T, LDT, T(1,I), 1) + +* +* T_{2,2} = \tau{i} +* + T(I,I) = TAU(I) END DO - ELSE - PREVLASTV = 1 - DO I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = I, K - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) -* - CALL CGEMV( 'Conjugate transpose', N-K+I-J, K-I, - $ -TAU( I ), V( J, I+1 ), LDV, V( J, I ), - $ 1, ONE, T( I+1, I ), 1 ) - ELSE -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H -* - CALL CGEMM( 'N', 'C', K-I, 1, N-K+I-J, - $ -TAU( I ), - $ V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), LDT ) - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL CTRMV( 'Lower', 'No transpose', 'Non-unit', - $ K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF + ELSE IF (LQ) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} V_{1,2} V_{1,3} | i-1 +* | 0 V_{2,2} V_{2,3} | 1 +* | 0 0 V_{3,3} | k-i +* |-------------------------| +* i-1 1 n-i +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{3,3} and repeat until we +* reach the end. On each iteration V_{3,3} is not referenced +* +* We will construct T one column at a time from left to right +* after initializing T(1,1) = TAU(1) +* +* T = |-------------------------| +* | T_{1,1} T_{1,2} T_{1,3} | i-1 +* | 0 T_{2,2} T_{2,3} | 1 +* | 0 0 T_{3,3} | k-i +* |-------------------------| +* i-1 1 k-i +* +* Similarly as above, we will construct T_{1,2} and T_{2,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On +* each iteration, T_{1:3,3} are not referenced. See clarft.f +* for details on how these formulae were constructed. +* +* We now get +* +* T_{1,2} = -T_{1,1}[V_{1,1} V_{1,2} V_{1,3}][ 0 V_{2,2} V_{2,3} ]'T_{2,2} +* +* T_{1,2} = -T_{1,1}(V_{1,2} + V_{1,3}V_{2,3}')T_{2,2} +* +* This means we will do the following +* +* T_{1,2} = -V_{1,2}T_{2,2} = -\tau_{i}V_{1,2} +* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} +* T_{1,2} = T_{1,1}T_{1,2} +* T_{2,2} = \tau{i} +* + T(1,1) = TAU(1) + + DO I = 2, K +* +* T_{1,2} = -\tau_{i}V_{1,2} +* + DO J = 1, I-1 + T(J, I) = -TAU(I)*V(J, I) + END DO + +* +* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} +* + CALL CGEMM('No Transpose', 'Conjugate Transpose', I-1, + $ 1, N-I, -TAU(I), V(1,I+1), LDV, V(I, I+1), LDV, ONE, + $ T(1, I), LDT) +* +* T_{1,2} = T_{1,1}T_{1,2} +* + CALL CTRMV('Upper', 'No Transpose', 'Non-unit', I-1, + $ T, LDT, T(1,I), 1) + +* +* T_{2,2} = \tau{i} +* + T(I,I) = TAU(I) END DO - END IF - RETURN + ELSE IF (LQT) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} V_{1,2} V_{1,3} | i-1 +* | 0 V_{2,2} V_{2,3} | 1 +* | 0 0 V_{3,3} | k-i +* |-------------------------| +* i-1 1 n-i +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{3,3} and repeat until we +* reach the end. On each iteration V_{3,3} is not referenced +* +* We will construct T one column at a time from left to right +* after initializing T(1,1) = TAU(1) +* +* T = |-------------------------| +* | T_{1,1} 0 0 | i-1 +* | T_{2,1} T_{2,2} 0 | 1 +* | T_{3,1} T_{3,2} T_{3,3} | k-i +* |-------------------------| +* i-1 1 k-i +* +* Similarly as above, we will construct T_{2,1} and T_{2,2} at +* each iteration i = 2, \dots k, and then grow into T_{3,1:3}. On +* each iteration, T_{3,1:3} are not referenced. See clarft.f +* for details on how these formulae were constructed. +* +* We now get +* +* T_{2,1} = -T_{2,2}[0 V_{2,2} V_{2,3}][V_{1,1} V_{1,2} V_{1,3}]'T_{1,1} +* +* T_{2,1} = -T_{2,2}(V_{1,2}' + V_{2,3}V_{1,3}')T_{1,1} +* +* This means we will do the following +* +* T_{2,1} = -T_{2,2}V_{1,2}' = -\tau_{i}V_{1,2}' +* T_{2,1} = -\tau_{i}V_{1,3}V_{2,3}' + T_{2,1} +* T_{2,1} = T_{1,1}'T_{2,1} +* T_{2,2} = \tau{i} +* + T(1,1) = CONJG(TAU(1)) + + DO I = 2, K +* +* T_{2,1} = -\tau_{i}V_{1,2}' +* + DO J = 1, I-1 + T(I,J) = -CONJG(TAU(I)*V(J,I)) + END DO +* +* T_{2,1} = -\tau_{i}V_{2,3}V_{1,3}' + T_{2,1} +* + CALL CGEMM('No Transpose', 'Conjugate Transpose', 1, + $ I-1, N-I, -CONJG(TAU(I)), V(I,I+1), LDV, V(1, I+1), + $ LDV, ONE, T(I, 1), LDT) +* +* T_{2,1} = T_{1,1}'T_{2,1} +* + CALL CTRMV('Lower', 'Transpose', 'Non-unit', + $ I-1, T, LDT, T(I,1), LDT) + + T(I,I) = CONJG(TAU(I)) + END DO + ELSE IF (QL) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} V_{1,2} V_{1,3} | n-i +* | 0 V_{2,2} V_{2,3} | 1 +* | 0 0 V_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{1,1} and repeat until we +* reach the end. On each iteration V_{1,1} is not referenced +* +* We will construct T one column at a time from right to left +* after initializing T(K,K) = TAU(K) +* +* T = |-------------------------| +* | T_{1,1} 0 0 | k-i +* | T_{2,1} T_{2,2} 0 | 1 +* | T_{3,1} T_{3,2} T_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{2,2} and T_{3,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On +* each iteration, T_{1:3,1} are not referenced. See clarft.f +* for details on how these formulae were constructed. +* +* We get that +* +* T_{3,2} = -T_{3,3}[V_{1,3}\\V_{2,3}\\V_{3,3}]' +* [V_{1,2}\\V_{2,2}\\0]T_{2,2} +* +* T_{3,2} = -T_{3,3}(V_{1,3}'V_{1,2} + V_{2,3}')T_{2,2} +* +* Thus, we will compute +* +* T_{2,2} = \tau_{k-i+1} +* T_{3,2} = -T_{3,3}V_{3,2}' = -\tau_{k-i+1}V_{3,2}' +* T_{3,2} = -\tau_{k-i+1}V_{1,3}'V_{1,2} + T_{3,2} +* T_{3,2} = T_{3,3}T_{3,2} +* + T(K,K) = TAU(K) + DO I = 2, K + KMI = K-I+1 + NMI = N-I+1 +* +* T_{2,2} = \tau(k-i+1) +* + T(KMI,KMI) = TAU(KMI) +* +* T_{3,2} = -\tau(k-i+1)V_{2,3}' +* + DO J = 1, I-1 + T(KMI + J, KMI) = -TAU(KMI)*CONJG(V(NMI, KMI + J)) + END DO +* +* T_{3,2} = -\tau(k-i+1)V_{1,3}'V_{1,2} + T_{3,2} +* + CALL CGEMV('Conjugate Transpose', N-I, I-1, -TAU(KMI), + $ V(1, KMI + 1), LDV, V(1, KMI), 1, ONE, + $ T(KMI+1, KMI), 1) +* +* T_{3,2} = T_{3,3}T_{3,2} +* + CALL CTRMV('Lower', 'No Transpose', 'Non-unit', I-1, + $ T(KMI + 1, KMI + 1), LDT, T(KMI + 1, KMI), 1) + + END DO + ELSE IF (RQ) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} 0 0 | k-i +* | V_{2,1} V_{2,2} 0 | 1 +* | V_{3,1} V_{3,2} V_{3,3} | i-1 +* |-------------------------| +* n-i 1 i-1 +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{1,1} and repeat until we +* reach the end. On each iteration V_{1,1} is not referenced +* +* We will construct T one column at a time from right to left +* after initializing T(K,K) = TAU(K) +* +* T = |-------------------------| +* | T_{1,1} 0 0 | k-i +* | T_{2,1} T_{2,2} 0 | 1 +* | T_{3,1} T_{3,2} T_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{2,2} and T_{3,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On +* each iteration, T_{1:3,1} are not referenced. See clarft.f +* for details on how these formulae were constructed. +* +* We get that +* +* T_{3,2} = -T_{3,3}[V_{3,1} V_{3,2} V_{3,3}][V_{2,1} V_{2,2} 0]'T_{2,2} +* +* T_{3,2} = -T_{3,3}(V_{3,1}V_{2,1}' + V_{3,2})T_{2,2} +* +* Thus, we will compute +* +* T_{2,2} = \tau_{k-i+1} +* T_{3,2} = -\tau_{k-i+1}V_{3,2} +* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} +* T_{3,2} = T_{3,3}T_{3,2} +* + T(K,K) = TAU(K) + DO I = 2, K + KMI = K-I+1 + NMI = N-I+1 +* +* T_{2,2} = \tau_{k-i+1} +* + T(KMI,KMI) = TAU(KMI) +* +* T_{3,2} = -\tau_{k-i+1}V_{3,2} +* + DO J = 1, I-1 + T(KMI + J, KMI) = -TAU(KMI)*V(KMI + J, NMI) + END DO +* +* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} +* + CALL CGEMM('No Transpose', 'Conjugate Transpose', I-1, + $ 1, N-I, -TAU(KMI), V(KMI+1, 1), LDV, V(KMI, 1), LDV, + $ ONE, T(KMI+1, KMI), LDT) +* +* T_{3,2} = T_{3,3}T_{3,2} +* + CALL CTRMV('Lower', 'No Transpose', 'Non-unit', I-1, + $ T(KMI+1, KMI+1), LDT, T(KMI+1, KMI), 1) + END DO + ELSE IF (RQT) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} 0 0 | k-i +* | V_{2,1} V_{2,2} 0 | 1 +* | V_{3,1} V_{3,2} V_{3,3} | i-1 +* |-------------------------| +* n-i 1 i-1 +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{1,1} and repeat until we +* reach the end. On each iteration V_{1,1} is not referenced +* +* We will construct T one column at a time from right to left +* after initializing T(K,K) = TAU(K) +* +* T = |-------------------------| +* | T_{1,1} T_{1,2} T_{1,3} | k-i +* | 0 T_{2,2} T_{2,3} | 1 +* | 0 0 T_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{2,2} and T_{2,3} at +* each iteration i = 2, \dots k, and then grow into T_{1,1:3}. On +* each iteration, T_{1,1:3} are not referenced. See clarft.f +* for details on how these formulae were constructed. +* +* We get that +* +* T_{2,3} = -T_{2,2}[V_{2,1} V_{2,2} 0][V_{3,1} V_{3,2} V_{3,3}]'T_{3,3} +* +* T_{3,2} = -T_{2,2}(V_{2,1}V_{3,1}' + V_{3,2}')T_{3,3} * -* End of CLARFT_LVL2 +* Thus, we will compute * - END +* T_{2,2} = \tau_{k-i+1} +* T_{2,3} = -\tau_{k-i+1}V_{3,2}' +* T_{2,3} = -\tau_{k-i+1}V_{2,1}V_{3,1}' + T_{2,3} +* T_{2,3} = T_{3,3}'T_{2,3} +* + T(K,K) = CONJG(TAU(K)) + DO I = 2, K + KMI = K-I+1 + NMI = N-I+1 +* +* T_{2,2} = \tau_{k-i+1} +* + T(KMI,KMI) = CONJG(TAU(KMI)) +* +* T_{2,3} = -\tau_{k-i+1}V_{3,2}' +* + DO J = 1, I-1 + T(KMI, KMI + J) = -CONJG(TAU(KMI)*V(KMI + J, NMI)) + END DO +* +* T_{2,3} = -\tau_{k-i+1}V_{2,1}V_{3,1}' + T_{2,3} +* + CALL CGEMM('No Transpose', 'Conjugate Transpose', 1, + $ I-1, N-I, -CONJG(TAU(KMI)), V(KMI, 1), LDV, + $ V(KMI+1,1), LDV, ONE, T(KMI, KMI+1), LDT) +* +* T_{2,3} = T_{3,3}'T_{2,3} +* + CALL CTRMV('Upper', 'Transpose', 'Non-unit', I-1, + $ T(KMI+1, KMI+1), LDT, T(KMI, KMI+1), LDT) + END DO + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/dlarft.c b/lapack-netlib/SRC/dlarft.c index d478b38ece..bab6cd283a 100644 --- a/lapack-netlib/SRC/dlarft.c +++ b/lapack-netlib/SRC/dlarft.c @@ -231,8 +231,8 @@ typedef struct Namelist Namelist; static integer c__3 = 3; static integer c_n1 = -1; static integer c__2 = 2; -static doublereal c_b13 = 1.; -static doublereal c_b22 = -1.; +static doublereal c_b18 = 1.; +static doublereal c_b27 = -1.; /* > \brief \b DLARFT forms the triangular factor T of a block reflector H = I - vtvH */ @@ -283,6 +283,9 @@ f"> */ /* > H(i) is stored in the i-th row of the array V, and */ /* > */ /* > H = I - V**T * T * V */ +/* > */ +/* > If DIRECT or STOREV = 'T', see Further Details for the shape of T */ +/* > */ /* > \endverbatim */ /* Arguments: */ @@ -295,6 +298,8 @@ f"> */ /* > multiplied to form the block reflector: */ /* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ /* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) */ +/* > but we return the T matrix that is already (conjugate) transposed */ /* > \endverbatim */ /* > */ /* > \param[in] STOREV */ @@ -302,8 +307,10 @@ f"> */ /* > STOREV is CHARACTER*1 */ /* > Specifies how the vectors which define the elementary */ /* > reflectors are stored (see also Further Details): */ -/* > = 'C': columnwise */ -/* > = 'R': rowwise */ +/* > = 'C': column-wise */ +/* > = 'R': row-wise */ +/* > = 'T': (With DIRECT='F') Row-wise, but we return the T */ +/* > matrix that is already (conjugate) transposed. */ /* > \endverbatim */ /* > */ /* > \param[in] N */ @@ -374,7 +381,7 @@ f"> */ /* > the H(i) is best illustrated by the following example with n = 5 and */ /* > k = 3. The elements equal to 1 are not stored. */ /* > */ -/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ +/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and (STOREV = 'R' or STOREV = 'T'): */ /* > */ /* > V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ /* > ( v1 1 ) ( 1 v2 v2 v2 ) */ @@ -382,13 +389,36 @@ f"> */ /* > ( v1 v2 v3 ) */ /* > ( v1 v2 v3 ) */ /* > */ -/* > DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ +/* > DIRECT = 'B' and STOREV = 'C': (DIRECT = 'B' or DIRECT = 'T') and STOREV = 'R': */ /* > */ /* > V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ /* > ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ /* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ /* > ( 1 v3 ) */ /* > ( 1 ) */ +/* > */ +/* > In addition, the shape of T is determined by these same flags as */ +/* > in the below table. */ +/* > 'U' denotes upper triangular */ +/* > 'L' denotes lower triangular */ +/* > 'X' denotes no current implementation */ +/* > We also provide the logical variable that represents the case */ +/* > in the code if it is implemented */ +/* > */ +/* > |-----------------------------------------------------------| */ +/* > | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | */ +/* > |--------------+--------------+--------------+--------------| */ +/* > | STOREV = 'C' | U (QR) | L (QL) | X | */ +/* > | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | */ +/* > | STOREV = 'T' | L (LQT) | X | X | */ +/* > |-----------------------------------------------------------| */ +/* > */ +/* > Finally, the relationship between the (conjugate) transposed T matrices */ +/* > are as follows: (Note that T_{FC} denotes the T associated with calling */ +/* > this routine with DIRECT = 'F' and STOREV = 'C') */ +/* > */ +/* > T_{TR} = (T_{BR})**H */ +/* > T_{FT} = (T_{FR})**H */ /* > \endverbatim */ /* > */ /* ===================================================================== */ @@ -403,12 +433,14 @@ f"> */ /* Local variables */ integer i__, j, l; - logical lq, ql, qr; + logical lq, ql, qr, rq; integer nx; extern /* Subroutine */ void dlarft_lvl2__(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); - logical dirf, colv; + logical lqt, rqt, dirb, dirf; + integer info; + logical dirt; extern /* Subroutine */ void dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); @@ -417,9 +449,10 @@ f"> */ integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), dlacpy_( char *, integer *, integer *, doublereal *, integer *, doublereal - *, integer *); + *, integer *), xerbla_(char *, integer *, ftnlen); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); + logical storec, storer, storet; /* -- LAPACK auxiliary routine -- */ @@ -442,7 +475,7 @@ f"> */ /* Based on the algorithm of Elmroth and Gustavson, */ /* IBM J. Res. Develop. Vol 44 No. 4 July 2000. */ -/* Quick return if possible */ +/* Convert our character flags to logical flags for later */ /* Parameter adjustments */ v_dim1 = *ldv; @@ -454,10 +487,87 @@ f"> */ t -= t_offset; /* Function Body */ + dirf = lsame_(direct, "F"); + dirb = lsame_(direct, "B"); + dirt = lsame_(direct, "T"); + storec = lsame_(storev, "C"); + storer = lsame_(storev, "R"); + storet = lsame_(storev, "T"); + +/* Error handling for our character flags */ + + info = 0; + if (! (dirf || dirb || dirt)) { + +/* DIRECT holds an illegal value */ + + info = 1; + } else if (! (storec || storer || storet)) { + +/* STOREV holds an illegal value */ + + info = 2; + } else if (dirb && storet) { + +/* This case is purposefully not implemented, but any other value for */ +/* STOREV is valid, so we report STOREV as the invalid input */ + + info = 2; + } else if (dirt && storec) { + +/* This case is purposefully not implemented, but any other value for */ +/* DIRECT is valid, so we report DIRECT as the invalid input */ + + info = 1; + } else if (dirt && storet) { + +/* This case is purposefully not implemented, and is ambiguous what */ +/* the user wants to do, so we arbitrarily say DIRECT is the incorrect */ +/* character flag. */ + + info = 1; + } + if (info != 0) { + xerbla_("DLARFT", &info, (ftnlen)6); + return; + } + +/* Quick return if possible */ + if (*n == 0 || *k == 0) { return; } +/* Now we determine what factorization our flags are associated with */ + +/* QR happens when we have forward direction in column storage */ + + qr = dirf && storec; + +/* LQT happens when we have forward direction in row storage and want to compute the transpose of */ +/* the T we would normally compute */ + + lqt = dirf && storet; + +/* LQ happens when we have forward direction in row storage and want to compute the T we would */ +/* normally compute */ + + lq = dirf && storer; + +/* QL happens when we have backward direction in column storage */ + + ql = dirb && storec; + +/* RQT happens when we have backward direction in row storage and want to compute the transpose */ +/* of the T we would normally compute */ + + rqt = dirt && storer; + +/* RQ happens when we have backward direction in row storage and want to compute the T that we */ +/* would normally compute */ + + rq = dirb && storer; + /* Base case */ if (*n == 1 || *k == 1) { @@ -465,7 +575,7 @@ f"> */ return; } -/* Determine when to cross over into the level 2 based implementation */ +/* Determine crossover point from level 2 to level 3 BLAS implementation */ /* Writing concatenation */ i__1[0] = 1, a__1[0] = direct; @@ -474,41 +584,17 @@ f"> */ nx = ilaenv_(&c__3, "DLARFT", ch__1, n, k, &c_n1, &c_n1, (ftnlen)6, ( ftnlen)2); if (*k < nx) { + +/* Finish this component with a level 2 BLAS implementation */ + dlarft_lvl2__(direct, storev, n, k, &v[v_offset], ldv, &tau[1], &t[ t_offset], ldt); return; } -/* Beginning of executable statements */ +/* Beginning of executable statements for the recursive case */ l = *k / 2; - -/* Determine what kind of Q we need to compute */ -/* We assume that if the user doesn't provide 'F' for DIRECT, */ -/* then they meant to provide 'B' and if they don't provide */ -/* 'C' for STOREV, then they meant to provide 'R' */ - - dirf = lsame_(direct, "F"); - colv = lsame_(storev, "C"); - -/* QR happens when we have forward direction in column storage */ - - qr = dirf && colv; - -/* LQ happens when we have forward direction in row storage */ - - lq = dirf && ! colv; - -/* QL happens when we have backward direction in column storage */ - - ql = ! dirf && colv; - -/* The last case is RQ. Due to how we structured this, if the */ -/* above 3 are false, then RQ must be true, so we never store */ -/* this */ -/* RQ happens when we have backward direction in row storage */ -/* RQ = (.NOT.DIRF).AND.(.NOT.COLV) */ - if (qr) { /* Break V apart into 6 components */ @@ -585,7 +671,7 @@ f"> */ /* T_{1,2} = T_{1,2}*V_{2,2} */ i__2 = *k - l; - dtrmm_("Right", "Lower", "No transpose", "Unit", &l, &i__2, &c_b13, & + dtrmm_("Right", "Lower", "No transpose", "Unit", &l, &i__2, &c_b18, & v[l + 1 + (l + 1) * v_dim1], ldv, &t[(l + 1) * t_dim1 + 1], ldt); @@ -594,8 +680,8 @@ f"> */ i__2 = *k - l; i__3 = *n - *k; - dgemm_("Transpose", "No transpose", &l, &i__2, &i__3, &c_b13, &v[*k + - 1 + v_dim1], ldv, &v[*k + 1 + (l + 1) * v_dim1], ldv, &c_b13, + dgemm_("Transpose", "No transpose", &l, &i__2, &i__3, &c_b18, &v[*k + + 1 + v_dim1], ldv, &v[*k + 1 + (l + 1) * v_dim1], ldv, &c_b18, &t[(l + 1) * t_dim1 + 1], ldt); /* At this point, we have that T_{1,2} = V_1'*V_2 */ @@ -605,14 +691,14 @@ f"> */ /* T_{1,2} = -T_{1,1}*T_{1,2} */ i__2 = *k - l; - dtrmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__2, &c_b22, + dtrmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__2, &c_b27, &t[t_offset], ldt, &t[(l + 1) * t_dim1 + 1], ldt); /* T_{1,2} = T_{1,2}*T_{2,2} */ i__2 = *k - l; dtrmm_("Right", "Upper", "No transpose", "Non-unit", &l, &i__2, & - c_b13, &t[l + 1 + (l + 1) * t_dim1], ldt, &t[(l + 1) * t_dim1 + c_b18, &t[l + 1 + (l + 1) * t_dim1], ldt, &t[(l + 1) * t_dim1 + 1], ldt); } else if (lq) { @@ -648,8 +734,8 @@ f"> */ /* Then, consider the product: */ -/* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) */ -/* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 */ +/* (I - V_1'*T_{1,1}'*V_1)*(I - V_2'*T_{2,2}'*V_2) */ +/* = I - V_1'*T_{1,1}'*V_1 - V_2'*T_{2,2}'*V_2 + V_1'*T_{1,1}'*V_1*V_2'*T_{2,2}'*V_2 */ /* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} */ @@ -660,7 +746,7 @@ f"> */ /* |---| */ /* So, our product is equivalent to the matrix product */ -/* I - V'*T*V */ +/* I - V'*T'*V */ /* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ /* to compute T_{1,2} */ @@ -686,7 +772,7 @@ f"> */ /* T_{1,2} = T_{1,2}*V_{2,2}' */ i__2 = *k - l; - dtrmm_("Right", "Upper", "Transpose", "Unit", &l, &i__2, &c_b13, &v[l + dtrmm_("Right", "Upper", "Transpose", "Unit", &l, &i__2, &c_b18, &v[l + 1 + (l + 1) * v_dim1], ldv, &t[(l + 1) * t_dim1 + 1], ldt); /* T_{1,2} = V_{1,3}*V_{2,3}' + T_{1,2} */ @@ -694,9 +780,9 @@ f"> */ i__2 = *k - l; i__3 = *n - *k; - dgemm_("No transpose", "Transpose", &l, &i__2, &i__3, &c_b13, &v[(*k + dgemm_("No transpose", "Transpose", &l, &i__2, &i__3, &c_b18, &v[(*k + 1) * v_dim1 + 1], ldv, &v[l + 1 + (*k + 1) * v_dim1], ldv, & - c_b13, &t[(l + 1) * t_dim1 + 1], ldt); + c_b18, &t[(l + 1) * t_dim1 + 1], ldt); /* At this point, we have that T_{1,2} = V_1*V_2' */ /* All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} */ @@ -705,15 +791,118 @@ f"> */ /* T_{1,2} = -T_{1,1}*T_{1,2} */ i__2 = *k - l; - dtrmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__2, &c_b22, + dtrmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__2, &c_b27, &t[t_offset], ldt, &t[(l + 1) * t_dim1 + 1], ldt); /* T_{1,2} = T_{1,2}*T_{2,2} */ i__2 = *k - l; dtrmm_("Right", "Upper", "No transpose", "Non-unit", &l, &i__2, & - c_b13, &t[l + 1 + (l + 1) * t_dim1], ldt, &t[(l + 1) * t_dim1 + c_b18, &t[l + 1 + (l + 1) * t_dim1], ldt, &t[(l + 1) * t_dim1 + 1], ldt); + } else if (lqt) { + +/* Break V apart into 6 components */ + +/* V = |----------------------| */ +/* |V_{1,1} V_{1,2} V{1,3}| */ +/* |0 V_{2,2} V{2,3}| */ +/* |----------------------| */ + +/* V_{1,1}\in\R^{l,l} unit upper triangular */ +/* V_{1,2}\in\R^{l,k-l} rectangular */ +/* V_{1,3}\in\R^{l,n-k} rectangular */ + +/* V_{2,2}\in\R^{k-l,k-l} unit upper triangular */ +/* V_{2,3}\in\R^{k-l,n-k} rectangular */ + +/* Where l = floor(k/2) */ + +/* We will construct the T matrix */ +/* T = |---------------| */ +/* |T_{1,1} 0 | */ +/* |T_{2,1} T_{2,2}| */ +/* |---------------| */ + +/* T is the triangular factor obtained from block reflectors. */ +/* To motivate the structure, assume we have already computed T_{1,1} */ +/* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 */ + +/* T_{1,1}\in\R^{l, l} lower triangular */ +/* T_{2,2}\in\R^{k-l, k-l} lower triangular */ +/* T_{2,1}\in\R^{k-l, l} rectangular */ + +/* Then, consider the product: */ + +/* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) */ +/* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 */ + +/* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} */ + +/* Then, we can define the matrix V as */ +/* V = |---| */ +/* |V_1| */ +/* |V_2| */ +/* |---| */ + +/* So, our product is equivalent to the matrix product */ +/* I - V'*T*V */ +/* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ +/* to compute T_{2,1} */ + +/* Compute T_{1,1} recursively */ + + dlarft_(direct, storev, n, &l, &v[v_offset], ldv, &tau[1], &t[ + t_offset], ldt); + +/* Compute T_{2,2} recursively */ + + i__2 = *n - l; + i__3 = *k - l; + dlarft_(direct, storev, &i__2, &i__3, &v[l + 1 + (l + 1) * v_dim1], + ldv, &tau[l + 1], &t[l + 1 + (l + 1) * t_dim1], ldt); + +/* Compute T_{2,1} */ +/* T_{2,1} = V_{1,2}' */ + + i__2 = *k - l; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = l; + for (j = 1; j <= i__3; ++j) { + t[l + i__ + j * t_dim1] = v[j + (l + i__) * v_dim1]; + } + } + +/* T_{2,1} = V_{2,2}*T_{2,1} */ + + i__2 = *k - l; + dtrmm_("Left", "Upper", "No Transpose", "Unit", &i__2, &l, &c_b18, &v[ + l + 1 + (l + 1) * v_dim1], ldv, &t[l + 1 + t_dim1], ldt); + +/* T_{2,1} = V_{2,3}*V_{1,3}' + T_{2,1} */ +/* Note: We assume K <= N, and GEMM will do nothing if N=K */ + + i__2 = *k - l; + i__3 = *n - *k; + dgemm_("No Transpose", "Transpose", &i__2, &l, &i__3, &c_b18, &v[l + + 1 + (*k + 1) * v_dim1], ldv, &v[(*k + 1) * v_dim1 + 1], ldv, & + c_b18, &t[l + 1 + t_dim1], ldt); + +/* At this point, we have that T_{2,1} = V_2*V_1' */ +/* All that is left is to pre and post multiply by -T_{2,2} and T_{1,1} */ +/* respectively. */ + +/* T_{2,1} = -T_{2,2}*T_{2,1} */ + + i__2 = *k - l; + dtrmm_("Left", "Lower", "No Transpose", "Non-unit", &i__2, &l, &c_b27, + &t[l + 1 + (l + 1) * t_dim1], ldt, &t[l + 1 + t_dim1], ldt); + +/* T_{2,1} = T_{2,1}*T_{1,1} */ + + i__2 = *k - l; + dtrmm_("Right", "Lower", "No Transpose", "Non-unit", &i__2, &l, & + c_b18, &t[t_offset], ldt, &t[l + 1 + t_dim1], ldt); } else if (ql) { /* Break V apart into 6 components */ @@ -791,7 +980,7 @@ f"> */ /* T_{2,1} = T_{2,1}*V_{2,1} */ i__2 = *k - l; - dtrmm_("Right", "Upper", "No transpose", "Unit", &l, &i__2, &c_b13, & + dtrmm_("Right", "Upper", "No transpose", "Unit", &l, &i__2, &c_b18, & v[*n - *k + 1 + v_dim1], ldv, &t[*k - l + 1 + t_dim1], ldt); /* T_{2,1} = V_{2,2}'*V_{2,1} + T_{2,1} */ @@ -799,8 +988,8 @@ f"> */ i__2 = *k - l; i__3 = *n - *k; - dgemm_("Transpose", "No transpose", &l, &i__2, &i__3, &c_b13, &v[(*k - - l + 1) * v_dim1 + 1], ldv, &v[v_offset], ldv, &c_b13, &t[*k + dgemm_("Transpose", "No transpose", &l, &i__2, &i__3, &c_b18, &v[(*k + - l + 1) * v_dim1 + 1], ldv, &v[v_offset], ldv, &c_b18, &t[*k - l + 1 + t_dim1], ldt); /* At this point, we have that T_{2,1} = V_2'*V_1 */ @@ -810,7 +999,7 @@ f"> */ /* T_{2,1} = -T_{2,2}*T_{2,1} */ i__2 = *k - l; - dtrmm_("Left", "Lower", "No transpose", "Non-unit", &l, &i__2, &c_b22, + dtrmm_("Left", "Lower", "No transpose", "Non-unit", &l, &i__2, &c_b27, &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[*k - l + 1 + t_dim1], ldt); @@ -818,11 +1007,8 @@ f"> */ i__2 = *k - l; dtrmm_("Right", "Lower", "No transpose", "Non-unit", &l, &i__2, & - c_b13, &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); - } else { - -/* Else means RQ case */ - + c_b18, &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); + } else if (rq) { /* Break V apart into 6 components */ /* V = |-----------------------| */ @@ -855,8 +1041,8 @@ f"> */ /* Then, consider the product: */ -/* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) */ -/* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 */ +/* (I - V_2'*T_{2,2}'*V_2)*(I - V_1'*T_{1,1}'*V_1) */ +/* = I - V_2'*T_{2,2}'*V_2 - V_1'*T_{1,1}'*V_1 + V_2'*T_{2,2}'*V_2*V_1'*T_{1,1}'*V_1 */ /* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} */ @@ -867,7 +1053,7 @@ f"> */ /* |---| */ /* So, our product is equivalent to the matrix product */ -/* I - V'*T*V */ +/* I - V'*T'*V */ /* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ /* to compute T_{2,1} */ @@ -893,7 +1079,7 @@ f"> */ /* T_{2,1} = T_{2,1}*V_{1,2}' */ i__2 = *k - l; - dtrmm_("Right", "Lower", "Transpose", "Unit", &l, &i__2, &c_b13, &v[(* + dtrmm_("Right", "Lower", "Transpose", "Unit", &l, &i__2, &c_b18, &v[(* n - *k + 1) * v_dim1 + 1], ldv, &t[*k - l + 1 + t_dim1], ldt); /* T_{2,1} = V_{2,1}*V_{1,1}' + T_{2,1} */ @@ -901,8 +1087,8 @@ f"> */ i__2 = *k - l; i__3 = *n - *k; - dgemm_("No transpose", "Transpose", &l, &i__2, &i__3, &c_b13, &v[*k - - l + 1 + v_dim1], ldv, &v[v_offset], ldv, &c_b13, &t[*k - l + + dgemm_("No transpose", "Transpose", &l, &i__2, &i__3, &c_b18, &v[*k - + l + 1 + v_dim1], ldv, &v[v_offset], ldv, &c_b18, &t[*k - l + 1 + t_dim1], ldt); /* At this point, we have that T_{2,1} = V_2*V_1' */ @@ -912,15 +1098,119 @@ f"> */ /* T_{2,1} = -T_{2,2}*T_{2,1} */ i__2 = *k - l; - dtrmm_("Left", "Lower", "No tranpose", "Non-unit", &l, &i__2, &c_b22, - &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[*k - l + 1 + + dtrmm_("Left", "Lower", "No transpose", "Non-unit", &l, &i__2, &c_b27, + &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[*k - l + 1 + t_dim1], ldt); /* T_{2,1} = T_{2,1}*T_{1,1} */ i__2 = *k - l; - dtrmm_("Right", "Lower", "No tranpose", "Non-unit", &l, &i__2, &c_b13, - &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); + dtrmm_("Right", "Lower", "No transpose", "Non-unit", &l, &i__2, & + c_b18, &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); + } else if (rqt) { +/* Break V apart into 6 components */ + +/* V = |-----------------------| */ +/* |V_{1,1} V_{1,2} 0 | */ +/* |V_{2,1} V_{2,2} V_{2,3}| */ +/* |-----------------------| */ + +/* V_{1,1}\in\R^{k-l,n-k} rectangular */ +/* V_{1,2}\in\R^{k-l,k-l} unit lower triangular */ + +/* V_{2,1}\in\R^{l,n-k} rectangular */ +/* V_{2,2}\in\R^{l,k-l} rectangular */ +/* V_{2,3}\in\R^{l,l} unit lower triangular */ + +/* We will construct the T matrix */ +/* T = |---------------| */ +/* |T_{1,1} T_{1,2}| */ +/* | 0 T_{2,2}| */ +/* |---------------| */ + +/* T is the triangular factor obtained from block reflectors. */ +/* To motivate the structure, assume we have already computed T_{1,1} */ +/* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 */ + +/* T_{1,1}\in\R^{k-l, k-l} non-unit upper triangular */ +/* T_{2,2}\in\R^{l, l} non-unit upper triangular */ +/* T_{1,2}\in\R^{k-l, l} rectangular */ + +/* Where l = floor(k/2) */ + +/* Then, consider the product: */ + +/* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) */ +/* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 */ + +/* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} */ + +/* Then, we can define the matrix V as */ +/* V = |---| */ +/* |V_1| */ +/* |V_2| */ +/* |---| */ + +/* So, our product is equivalent to the matrix product */ +/* I - V'*T*V */ +/* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ +/* to compute T_{1,2} */ + +/* Compute T_{1,1} recursively */ + + i__2 = *n - l; + i__3 = *k - l; + dlarft_(direct, storev, &i__2, &i__3, &v[v_offset], ldv, &tau[1], &t[ + t_offset], ldt); + +/* Compute T_{2,2} recursively */ + + dlarft_(direct, storev, n, &l, &v[*k - l + 1 + v_dim1], ldv, &tau[*k + - l + 1], &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt); + +/* Compute T_{1,2} */ +/* T_{1,2} = V_{2,2}' */ + + i__2 = *k - l; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = l; + for (j = 1; j <= i__3; ++j) { + t[i__ + (*k - l + j) * t_dim1] = v[*k - l + j + (*n - *k + + i__) * v_dim1]; + } + } + +/* T_{1,2} = V_{1,2}T_{1,2} */ + + i__2 = *k - l; + dtrmm_("Left", "Lower", "No Transpose", "Unit", &i__2, &l, &c_b18, &v[ + (*n - *k + 1) * v_dim1 + 1], ldv, &t[(*k - l + 1) * t_dim1 + + 1], ldt); + +/* T_{1,2} = V_{1,1}V_{2,1}' + T_{1,2} */ + + i__2 = *k - l; + i__3 = *n - *k; + dgemm_("No Transpose", "Transpose", &i__2, &l, &i__3, &c_b18, &v[ + v_offset], ldv, &v[*k - l + 1 + v_dim1], ldv, &c_b18, &t[(*k + - l + 1) * t_dim1 + 1], ldt); + +/* At this point, we have that T_{1,2} = V_1*V_2' */ +/* All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} */ +/* respectively. */ + +/* T_{1,2} = -T_{1,1}*T_{1,2} */ + + i__2 = *k - l; + dtrmm_("Left", "Upper", "No Transpose", "Non-Unit", &i__2, &l, &c_b27, + &t[t_offset], ldt, &t[(*k - l + 1) * t_dim1 + 1], ldt); + +/* T_{1,2} = T_{1,2}*T_{2,2} */ + + i__2 = *k - l; + dtrmm_("Right", "Upper", "No Transpose", "Non-Unit", &i__2, &l, & + c_b18, &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[(*k - + l + 1) * t_dim1 + 1], ldt); } return; } /* dlarft_ */ diff --git a/lapack-netlib/SRC/dlarft.f b/lapack-netlib/SRC/dlarft.f index fa2ea0d134..154f7226d8 100644 --- a/lapack-netlib/SRC/dlarft.f +++ b/lapack-netlib/SRC/dlarft.f @@ -48,6 +48,9 @@ *> H(i) is stored in the i-th row of the array V, and *> *> H = I - V**T * T * V +*> +*> If DIRECT or STOREV = 'T', see Further Details for the shape of T +*> *> \endverbatim * * Arguments: @@ -60,6 +63,8 @@ *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) +*> = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) +*> but we return the T matrix that is already (conjugate) transposed *> \endverbatim *> *> \param[in] STOREV @@ -67,8 +72,10 @@ *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise +*> = 'C': column-wise +*> = 'R': row-wise +*> = 'T': (With DIRECT='F') Row-wise, but we return the T +*> matrix that is already (conjugate) transposed. *> \endverbatim *> *> \param[in] N @@ -139,7 +146,7 @@ *> the H(i) is best illustrated by the following example with n = 5 and *> k = 3. The elements equal to 1 are not stored. *> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and (STOREV = 'R' or STOREV = 'T'): *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) @@ -147,13 +154,36 @@ *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +*> DIRECT = 'B' and STOREV = 'C': (DIRECT = 'B' or DIRECT = 'T') and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) +*> +*> In addition, the shape of T is determined by these same flags as +*> in the below table. +*> 'U' denotes upper triangular +*> 'L' denotes lower triangular +*> 'X' denotes no current implementation +*> We also provide the logical variable that represents the case +*> in the code if it is implemented +*> +*> |-----------------------------------------------------------| +*> | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | +*> |--------------+--------------+--------------+--------------| +*> | STOREV = 'C' | U (QR) | L (QL) | X | +*> | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | +*> | STOREV = 'T' | L (LQT) | X | X | +*> |-----------------------------------------------------------| +*> +*> Finally, the relationship between the (conjugate) transposed T matrices +*> are as follows: (Note that T_{FC} denotes the T associated with calling +*> this routine with DIRECT = 'F' and STOREV = 'C') +*> +*> T_{TR} = (T_{BR})**H +*> T_{FT} = (T_{FR})**H *> \endverbatim *> * ===================================================================== @@ -177,24 +207,26 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * * .. Parameters .. * - DOUBLE PRECISION ONE, NEG_ONE, ZERO - PARAMETER(ONE=1.0D+0, ZERO = 0.0D+0, NEG_ONE=-1.0D+0) + DOUBLE PRECISION ONE, NEG_ONE + PARAMETER(ONE=1.0D+0, NEG_ONE=-1.0D+0) * * .. Local Scalars .. * - INTEGER I,J,L,NX - LOGICAL QR,LQ,QL,DIRF,COLV + INTEGER I,J,L,NX,INFO + LOGICAL QR, LQ, QL, RQ, LQT, RQT, + $ DIRF, DIRB, DIRT, + $ STOREC, STORER, STORET * * .. External Subroutines .. * - EXTERNAL DTRMM,DGEMM,DLACPY + EXTERNAL DLARFT_LVL2, DTRMM, DGEMM, DLACPY, XERBLA * * .. External Functions.. * LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV -* +* * The general scheme used is inspired by the approach inside DGEQRT3 * which was (at the time of writing this code): * Based on the algorithm of Elmroth and Gustavson, @@ -202,12 +234,90 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * .. * .. Executable Statements .. * +* Convert our character flags to logical flags for later +* + DIRF = LSAME(DIRECT,'F') + DIRB = LSAME(DIRECT,'B') + DIRT = LSAME(DIRECT,'T') + STOREC = LSAME(STOREV,'C') + STORER = LSAME(STOREV,'R') + STORET = LSAME(STOREV,'T') +* +* Error handling for our character flags +* + INFO = 0 + IF( .NOT.(DIRF.OR.DIRB.OR.DIRT) ) THEN +* +* DIRECT holds an illegal value +* + INFO = 1 + ELSE IF( .NOT.(STOREC.OR.STORER.OR.STORET) ) THEN +* +* STOREV holds an illegal value +* + INFO = 2 + ELSE IF( DIRB.AND.STORET ) THEN +* +* This case is purposefully not implemented, but any other value for +* STOREV is valid, so we report STOREV as the invalid input +* + INFO = 2 + ELSE IF( DIRT.AND.STOREC ) THEN +* +* This case is purposefully not implemented, but any other value for +* DIRECT is valid, so we report DIRECT as the invalid input +* + INFO = 1 + ELSE IF( DIRT.AND.STORET ) THEN +* +* This case is purposefully not implemented, and is ambiguous what +* the user wants to do, so we arbitrarily say DIRECT is the incorrect +* character flag. +* + INFO = 1 + END IF + + IF( INFO.NE.0 ) THEN + CALL XERBLA('DLARFT', INFO) + RETURN + END IF +* * Quick return if possible * IF(N.EQ.0.OR.K.EQ.0) THEN RETURN END IF * +* Now we determine what factorization our flags are associated with +* +* QR happens when we have forward direction in column storage +* + QR = DIRF.AND.STOREC +* +* LQT happens when we have forward direction in row storage and want to compute the transpose of +* the T we would normally compute +* + LQT = DIRF.AND.STORET +* +* LQ happens when we have forward direction in row storage and want to compute the T we would +* normally compute +* + LQ = DIRF.AND.STORER +* +* QL happens when we have backward direction in column storage +* + QL = DIRB.AND.STOREC +* +* RQT happens when we have backward direction in row storage and want to compute the transpose +* of the T we would normally compute +* + RQT = DIRT.AND.STORER +* +* RQ happens when we have backward direction in row storage and want to compute the T that we +* would normally compute +* + RQ = DIRB.AND.STORER +* * Base case * IF(N.EQ.1.OR.K.EQ.1) THEN @@ -215,44 +325,20 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, RETURN END IF * -* Determine when to cross over into the level 2 based implementation +* Determine crossover point from level 2 to level 3 BLAS implementation * NX = ILAENV(3, "DLARFT", DIRECT // STOREV, N, K, -1, -1) IF(K.LT.NX) THEN +* +* Finish this component with a level 2 BLAS implementation +* CALL DLARFT_LVL2(DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT) RETURN END IF * -* Beginning of executable statements +* Beginning of executable statements for the recursive case * L = K / 2 -* -* Determine what kind of Q we need to compute -* We assume that if the user doesn't provide 'F' for DIRECT, -* then they meant to provide 'B' and if they don't provide -* 'C' for STOREV, then they meant to provide 'R' -* - DIRF = LSAME(DIRECT,'F') - COLV = LSAME(STOREV,'C') -* -* QR happens when we have forward direction in column storage -* - QR = DIRF.AND.COLV -* -* LQ happens when we have forward direction in row storage -* - LQ = DIRF.AND.(.NOT.COLV) -* -* QL happens when we have backward direction in column storage -* - QL = (.NOT.DIRF).AND.COLV -* -* The last case is RQ. Due to how we structured this, if the -* above 3 are false, then RQ must be true, so we never store -* this -* RQ happens when we have backward direction in row storage -* RQ = (.NOT.DIRF).AND.(.NOT.COLV) -* IF(QR) THEN * * Break V apart into 6 components @@ -266,17 +352,17 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * V_{1,1}\in\R^{l,l} unit lower triangular * V_{2,1}\in\R^{k-l,l} rectangular * V_{3,1}\in\R^{n-k,l} rectangular -* +* * V_{2,2}\in\R^{k-l,k-l} unit lower triangular * V_{3,2}\in\R^{n-k,k-l} rectangular * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} T_{1,2}| * |0 T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -287,17 +373,17 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * Where l = floor(k/2) * * Then, consider the product: -* +* * (I - V_1*T_{1,1}*V_1')*(I - V_2*T_{2,2}*V_2') * = I - V_1*T_{1,1}*V_1' - V_2*T_{2,2}*V_2' + V_1*T_{1,1}*V_1'*V_2*T_{2,2}*V_2' -* +* * Define T_{1,2} = -T_{1,1}*V_1'*V_2*T_{2,2} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |-------| * |V_1 V_2| * |-------| -* +* * So, our product is equivalent to the matrix product * I - V*T*V' * This means, we can compute T_{1,1} and T_{2,2}, then use this information @@ -309,30 +395,29 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * * Compute T_{2,2} recursively * - CALL DLARFT(DIRECT, STOREV, N-L, K-L, V(L+1, L+1), LDV, - $ TAU(L+1), T(L+1, L+1), LDT) + CALL DLARFT(DIRECT, STOREV, N-L, K-L, V(L+1,L+1), LDV, + $ TAU(L+1), T(L+1,L+1), LDT) * -* Compute T_{1,2} +* Compute T_{1,2} * T_{1,2} = V_{2,1}' * DO J = 1, L DO I = 1, K-L - T(J, L+I) = V(L+I, J) + T(J,L+I) = V(L+I,J) END DO END DO * * T_{1,2} = T_{1,2}*V_{2,2} * CALL DTRMM('Right', 'Lower', 'No transpose', 'Unit', L, - $ K-L, ONE, V(L+1, L+1), LDV, T(1, L+1), LDT) + $ K-L, ONE, V(L+1, L+1), LDV, T(1, L+1), LDT) * * T_{1,2} = V_{3,1}'*V_{3,2} + T_{1,2} * Note: We assume K <= N, and GEMM will do nothing if N=K * - CALL DGEMM('Transpose', 'No transpose', L, K-L, N-K, ONE, - $ V(K+1, 1), LDV, V(K+1, L+1), LDV, ONE, - $ T(1, L+1), LDT) + CALL DGEMM('Transpose', 'No transpose', L, K-L, N-K, ONE, + $ V(K+1, 1), LDV, V(K+1,L+1), LDV, ONE, T(1, L+1), LDT) * * At this point, we have that T_{1,2} = V_1'*V_2 * All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} @@ -341,12 +426,12 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{1,2} = -T_{1,1}*T_{1,2} * CALL DTRMM('Left', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT) + $ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT) * * T_{1,2} = T_{1,2}*T_{2,2} * - CALL DTRMM('Right', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, ONE, T(L+1, L+1), LDT, T(1, L+1), LDT) + CALL DTRMM('Right', 'Upper', 'No transpose', 'Non-unit', L, + $ K-L, ONE, T(L+1,L+1), LDT, T(1, L+1), LDT) ELSE IF(LQ) THEN * @@ -360,19 +445,19 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * V_{1,1}\in\R^{l,l} unit upper triangular * V_{1,2}\in\R^{l,k-l} rectangular * V_{1,3}\in\R^{l,n-k} rectangular -* +* * V_{2,2}\in\R^{k-l,k-l} unit upper triangular * V_{2,3}\in\R^{k-l,n-k} rectangular * * Where l = floor(k/2) * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} T_{1,2}| * |0 T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -381,20 +466,20 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{1,2}\in\R^{l, k-l} rectangular * * Then, consider the product: -* -* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) -* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 -* +* +* (I - V_1'*T_{1,1}'*V_1)*(I - V_2'*T_{2,2}'*V_2) +* = I - V_1'*T_{1,1}'*V_1 - V_2'*T_{2,2}'*V_2 + V_1'*T_{1,1}'*V_1*V_2'*T_{2,2}'*V_2 +* * Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |---| * |V_1| * |V_2| * |---| -* +* * So, our product is equivalent to the matrix product -* I - V'*T*V +* I - V'*T'*V * This means, we can compute T_{1,1} and T_{2,2}, then use this information * to compute T_{1,2} * @@ -404,27 +489,26 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * * Compute T_{2,2} recursively * - CALL DLARFT(DIRECT, STOREV, N-L, K-L, V(L+1, L+1), LDV, - $ TAU(L+1), T(L+1, L+1), LDT) + CALL DLARFT(DIRECT, STOREV, N-L, K-L, V(L+1,L+1), LDV, + $ TAU(L+1), T(L+1,L+1), LDT) * * Compute T_{1,2} * T_{1,2} = V_{1,2} * - CALL DLACPY('All', L, K-L, V(1, L+1), LDV, T(1, L+1), LDT) + CALL DLACPY('All', L, K - L, V(1,L+1), LDV, T(1, L+1), LDT) * * T_{1,2} = T_{1,2}*V_{2,2}' * CALL DTRMM('Right', 'Upper', 'Transpose', 'Unit', L, K-L, - $ ONE, V(L+1, L+1), LDV, T(1, L+1), LDT) + $ ONE, V(L+1, L+1), LDV, T(1, L+1), LDT) * * T_{1,2} = V_{1,3}*V_{2,3}' + T_{1,2} * Note: We assume K <= N, and GEMM will do nothing if N=K * CALL DGEMM('No transpose', 'Transpose', L, K-L, N-K, ONE, - $ V(1, K+1), LDV, V(L+1, K+1), LDV, ONE, - $ T(1, L+1), LDT) + $ V(1, K+1), LDV, V(L+1, K+1), LDV, ONE, T(1, L+1), LDT) * * At this point, we have that T_{1,2} = V_1*V_2' * All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} @@ -433,13 +517,106 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{1,2} = -T_{1,1}*T_{1,2} * CALL DTRMM('Left', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT) + $ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT) * * T_{1,2} = T_{1,2}*T_{2,2} * CALL DTRMM('Right', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, ONE, T(L+1, L+1), LDT, T(1, L+1), LDT) + $ K-L, ONE, T(L+1,L+1), LDT, T(1, L+1), LDT) + ELSE IF(LQT) THEN +* +* Break V apart into 6 components +* +* V = |----------------------| +* |V_{1,1} V_{1,2} V{1,3}| +* |0 V_{2,2} V{2,3}| +* |----------------------| +* +* V_{1,1}\in\R^{l,l} unit upper triangular +* V_{1,2}\in\R^{l,k-l} rectangular +* V_{1,3}\in\R^{l,n-k} rectangular +* +* V_{2,2}\in\R^{k-l,k-l} unit upper triangular +* V_{2,3}\in\R^{k-l,n-k} rectangular +* +* Where l = floor(k/2) +* +* We will construct the T matrix +* T = |---------------| +* |T_{1,1} 0 | +* |T_{2,1} T_{2,2}| +* |---------------| +* +* T is the triangular factor obtained from block reflectors. +* To motivate the structure, assume we have already computed T_{1,1} +* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 +* +* T_{1,1}\in\R^{l, l} lower triangular +* T_{2,2}\in\R^{k-l, k-l} lower triangular +* T_{2,1}\in\R^{k-l, l} rectangular +* +* Then, consider the product: +* +* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) +* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 +* +* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} +* +* Then, we can define the matrix V as +* V = |---| +* |V_1| +* |V_2| +* |---| +* +* So, our product is equivalent to the matrix product +* I - V'*T*V +* This means, we can compute T_{1,1} and T_{2,2}, then use this information +* to compute T_{2,1} +* +* Compute T_{1,1} recursively +* + CALL DLARFT(DIRECT, STOREV, N, L, V, LDV, TAU, T, LDT) +* +* Compute T_{2,2} recursively +* + CALL DLARFT(DIRECT, STOREV, N-L, K-L, V(L+1,L+1), LDV, + $ TAU(L+1), T(L+1,L+1), LDT) + +* +* Compute T_{2,1} +* T_{2,1} = V_{1,2}' +* + DO I = 1, K-L + DO J = 1, L + T(L+I,J) = V(J,L+I) + END DO + END DO +* +* T_{2,1} = V_{2,2}*T_{2,1} +* + CALL DTRMM('Left', 'Upper', 'No Transpose', 'Unit', K-L, L, + $ ONE, V(L+1,L+1), LDV, T(L+1,1), LDT) +* +* T_{2,1} = V_{2,3}*V_{1,3}' + T_{2,1} +* Note: We assume K <= N, and GEMM will do nothing if N=K +* + CALL DGEMM('No Transpose', 'Transpose', K-L, L, N-K, ONE, + $ V(L+1,K+1), LDV, V(1, K+1), LDV, ONE, T(L+1,1), LDT) +* +* At this point, we have that T_{2,1} = V_2*V_1' +* All that is left is to pre and post multiply by -T_{2,2} and T_{1,1} +* respectively. +* +* T_{2,1} = -T_{2,2}*T_{2,1} +* + CALL DTRMM('Left', 'Lower', 'No Transpose', 'Non-unit', + $ K-L, L, NEG_ONE, T(L+1,L+1), LDT, T(L+1,1), LDT) +* +* T_{2,1} = T_{2,1}*T_{1,1} +* + CALL DTRMM('Right', 'Lower', 'No Transpose', 'Non-unit', + $ K-L, L, ONE, T, LDT, T(L+1,1), LDT) ELSE IF(QL) THEN * * Break V apart into 6 components @@ -452,18 +629,18 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * * V_{1,1}\in\R^{n-k,k-l} rectangular * V_{2,1}\in\R^{k-l,k-l} unit upper triangular -* +* * V_{1,2}\in\R^{n-k,l} rectangular * V_{2,2}\in\R^{k-l,l} rectangular * V_{3,2}\in\R^{l,l} unit upper triangular * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} 0 | * |T_{2,1} T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -474,17 +651,17 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * Where l = floor(k/2) * * Then, consider the product: -* +* * (I - V_2*T_{2,2}*V_2')*(I - V_1*T_{1,1}*V_1') * = I - V_2*T_{2,2}*V_2' - V_1*T_{1,1}*V_1' + V_2*T_{2,2}*V_2'*V_1*T_{1,1}*V_1' -* +* * Define T_{2,1} = -T_{2,2}*V_2'*V_1*T_{1,1} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |-------| * |V_1 V_2| * |-------| -* +* * So, our product is equivalent to the matrix product * I - V*T*V' * This means, we can compute T_{1,1} and T_{2,2}, then use this information @@ -492,34 +669,34 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * * Compute T_{1,1} recursively * - CALL DLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, LDT) + CALL DLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, + $ LDT) * * Compute T_{2,2} recursively * CALL DLARFT(DIRECT, STOREV, N, L, V(1, K-L+1), LDV, - $ TAU(K-L+1), T(K-L+1, K-L+1), LDT) + $ TAU(K-L+1), T(K-L+1,K-L+1), LDT) * * Compute T_{2,1} * T_{2,1} = V_{2,2}' * DO J = 1, K-L DO I = 1, L - T(K-L+I, J) = V(N-K+J, K-L+I) + T(K-L+I,J) = V(N-K+J, K-L+I) END DO END DO * * T_{2,1} = T_{2,1}*V_{2,1} * CALL DTRMM('Right', 'Upper', 'No transpose', 'Unit', L, - $ K-L, ONE, V(N-K+1, 1), LDV, T(K-L+1, 1), LDT) + $ K-L, ONE, V(N-K+1,1), LDV, T(K-L+1,1), LDT) * * T_{2,1} = V_{2,2}'*V_{2,1} + T_{2,1} * Note: We assume K <= N, and GEMM will do nothing if N=K * CALL DGEMM('Transpose', 'No transpose', L, K-L, N-K, ONE, - $ V(1, K-L+1), LDV, V, LDV, ONE, T(K-L+1, 1), - $ LDT) + $ V(1,K-L+1), LDV, V, LDV, ONE, T(K-L+1,1), LDT) * * At this point, we have that T_{2,1} = V_2'*V_1 * All that is left is to pre and post multiply by -T_{2,2} and T_{1,1} @@ -528,17 +705,13 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{2,1} = -T_{2,2}*T_{2,1} * CALL DTRMM('Left', 'Lower', 'No transpose', 'Non-unit', L, - $ K-L, NEG_ONE, T(K-L+1, K-L+1), LDT, - $ T(K-L+1, 1), LDT) + $ K-L, NEG_ONE, T(K-L+1,K-L+1), LDT, T(K-L+1,1), LDT) * * T_{2,1} = T_{2,1}*T_{1,1} * CALL DTRMM('Right', 'Lower', 'No transpose', 'Non-unit', L, - $ K-L, ONE, T, LDT, T(K-L+1, 1), LDT) - ELSE -* -* Else means RQ case -* + $ K-L, ONE, T, LDT, T(K-L+1,1), LDT) + ELSE IF(RQ) THEN * Break V apart into 6 components * * V = |-----------------------| @@ -553,13 +726,13 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * V_{2,2}\in\R^{l,k-l} rectangular * V_{2,3}\in\R^{l,l} unit lower triangular * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} 0 | * |T_{2,1} T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -570,51 +743,51 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * Where l = floor(k/2) * * Then, consider the product: -* -* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) -* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 -* +* +* (I - V_2'*T_{2,2}'*V_2)*(I - V_1'*T_{1,1}'*V_1) +* = I - V_2'*T_{2,2}'*V_2 - V_1'*T_{1,1}'*V_1 + V_2'*T_{2,2}'*V_2*V_1'*T_{1,1}'*V_1 +* * Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |---| * |V_1| * |V_2| * |---| -* +* * So, our product is equivalent to the matrix product -* I - V'*T*V +* I - V'*T'*V * This means, we can compute T_{1,1} and T_{2,2}, then use this information * to compute T_{2,1} * * Compute T_{1,1} recursively * - CALL DLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, LDT) + CALL DLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, + $ LDT) * * Compute T_{2,2} recursively * - CALL DLARFT(DIRECT, STOREV, N, L, V(K-L+1, 1), LDV, - $ TAU(K-L+1), T(K-L+1, K-L+1), LDT) + CALL DLARFT(DIRECT, STOREV, N, L, V(K-L+1,1), LDV, + $ TAU(K-L+1), T(K-L+1,K-L+1), LDT) * * Compute T_{2,1} * T_{2,1} = V_{2,2} * - CALL DLACPY('All', L, K-L, V(K-L+1, N-K+1), LDV, - $ T(K-L+1, 1), LDT) + CALL DLACPY('All', L, K-L, V(K-L+1,N-K+1), LDV, T(K-L+1,1), + $ LDT) * * T_{2,1} = T_{2,1}*V_{1,2}' * CALL DTRMM('Right', 'Lower', 'Transpose', 'Unit', L, K-L, - $ ONE, V(1, N-K+1), LDV, T(K-L+1, 1), LDT) + $ ONE, V(1, N-K+1), LDV, T(K-L+1,1), LDT) * -* T_{2,1} = V_{2,1}*V_{1,1}' + T_{2,1} +* T_{2,1} = V_{2,1}*V_{1,1}' + T_{2,1} * Note: We assume K <= N, and GEMM will do nothing if N=K * - CALL DGEMM('No transpose', 'Transpose', L, K-L, N-K, ONE, - $ V(K-L+1, 1), LDV, V, LDV, ONE, T(K-L+1, 1), - $ LDT) + CALL DGEMM('No transpose', 'Transpose', L, K-L, N-K, ONE, + $ V(K-L+1,1), LDV, V, LDV, ONE, T(K-L+1,1), LDT) * * At this point, we have that T_{2,1} = V_2*V_1' @@ -623,14 +796,104 @@ RECURSIVE SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, * * T_{2,1} = -T_{2,2}*T_{2,1} * - CALL DTRMM('Left', 'Lower', 'No tranpose', 'Non-unit', L, - $ K-L, NEG_ONE, T(K-L+1, K-L+1), LDT, - $ T(K-L+1, 1), LDT) + CALL DTRMM('Left', 'Lower', 'No transpose', 'Non-unit', L, + $ K-L, NEG_ONE, T(K-L+1,K-L+1), LDT, T(K-L+1,1), LDT) * * T_{2,1} = T_{2,1}*T_{1,1} * - CALL DTRMM('Right', 'Lower', 'No tranpose', 'Non-unit', L, - $ K-L, ONE, T, LDT, T(K-L+1, 1), LDT) + CALL DTRMM('Right', 'Lower', 'No transpose', 'Non-unit', L, + $ K-L, ONE, T, LDT, T(K-L+1,1), LDT) + ELSE IF(RQT) THEN +* Break V apart into 6 components +* +* V = |-----------------------| +* |V_{1,1} V_{1,2} 0 | +* |V_{2,1} V_{2,2} V_{2,3}| +* |-----------------------| +* +* V_{1,1}\in\R^{k-l,n-k} rectangular +* V_{1,2}\in\R^{k-l,k-l} unit lower triangular +* +* V_{2,1}\in\R^{l,n-k} rectangular +* V_{2,2}\in\R^{l,k-l} rectangular +* V_{2,3}\in\R^{l,l} unit lower triangular +* +* We will construct the T matrix +* T = |---------------| +* |T_{1,1} T_{1,2}| +* | 0 T_{2,2}| +* |---------------| +* +* T is the triangular factor obtained from block reflectors. +* To motivate the structure, assume we have already computed T_{1,1} +* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 +* +* T_{1,1}\in\R^{k-l, k-l} non-unit upper triangular +* T_{2,2}\in\R^{l, l} non-unit upper triangular +* T_{1,2}\in\R^{k-l, l} rectangular +* +* Where l = floor(k/2) +* +* Then, consider the product: +* +* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) +* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 +* +* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} +* +* Then, we can define the matrix V as +* V = |---| +* |V_1| +* |V_2| +* |---| +* +* So, our product is equivalent to the matrix product +* I - V'*T*V +* This means, we can compute T_{1,1} and T_{2,2}, then use this information +* to compute T_{1,2} +* +* Compute T_{1,1} recursively +* + CALL DLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, + $ LDT) +* +* Compute T_{2,2} recursively +* + CALL DLARFT(DIRECT, STOREV, N, L, V(K-L+1,1), LDV, + $ TAU(K-L+1), T(K-L+1,K-L+1), LDT) +* +* Compute T_{1,2} +* T_{1,2} = V_{2,2}' +* + DO I = 1, K-L + DO J = 1, L + T(I,K-L+J) = V(K-L+J, N-K+I) + END DO + END DO +* +* T_{1,2} = V_{1,2}T_{1,2} +* + CALL DTRMM('Left', 'Lower', 'No Transpose', 'Unit', K-L, L, + $ ONE, V(1,N-K+1), LDV, T(1,K-L+1), LDT) +* +* T_{1,2} = V_{1,1}V_{2,1}' + T_{1,2} +* + CALL DGEMM('No Transpose', 'Transpose', K-L, L, N-K, ONE, V, + $ LDV, V(K-L+1,1), LDV, ONE, T(1, K-L+1), LDT) +* +* At this point, we have that T_{1,2} = V_1*V_2' +* All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} +* respectively. +* +* T_{1,2} = -T_{1,1}*T_{1,2} +* + CALL DTRMM('Left', 'Upper', 'No Transpose', 'Non-Unit', + $ K-L, L, NEG_ONE, T, LDT, T(1, K-L+1), LDT) +* +* T_{1,2} = T_{1,2}*T_{2,2} +* + CALL DTRMM('Right', 'Upper', 'No Transpose', 'Non-Unit', + $ K-L, L, ONE, T(K-L+1,K-L+1), LDT, T(1, K-L+1), LDT) END IF END SUBROUTINE diff --git a/lapack-netlib/SRC/dlarft_lvl2.c b/lapack-netlib/SRC/dlarft_lvl2.c index ff17bca48a..20d0d79d22 100644 --- a/lapack-netlib/SRC/dlarft_lvl2.c +++ b/lapack-netlib/SRC/dlarft_lvl2.c @@ -223,31 +223,20 @@ typedef struct Namelist Namelist; /* Table of constant values */ static integer c__1 = 1; -static doublereal c_b6 = 1.; +static doublereal c_b11 = 1.; -/* > \brief \b DLARFT_LVL2: Level 2 BLAS version for terminating case of DLARFT. */ +/* > \brief \b DLARFT_LVL2 forms the triangular factor T of a block reflector H = I - vtvH */ /* =========== DOCUMENTATION =========== */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > Download DLARFT_LVL2 + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ - /* Definition: */ /* =========== */ /* SUBROUTINE DLARFT_LVL2( DIRECT, STOREV, N, K, V, LDV, TAU, */ -/* T, LDT ) */ +/* $ T, LDT ) */ /* CHARACTER DIRECT, STOREV */ /* INTEGER K, LDT, LDV, N */ @@ -275,6 +264,9 @@ f"> */ /* > H(i) is stored in the i-th row of the array V, and */ /* > */ /* > H = I - V**T * T * V */ +/* > */ +/* > If DIRECT or STOREV = 'T', see Further Details for the shape of T */ +/* > */ /* > \endverbatim */ /* Arguments: */ @@ -287,6 +279,8 @@ f"> */ /* > multiplied to form the block reflector: */ /* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ /* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) */ +/* > but we return the T matrix that is already (conjugate) transposed */ /* > \endverbatim */ /* > */ /* > \param[in] STOREV */ @@ -294,8 +288,10 @@ f"> */ /* > STOREV is CHARACTER*1 */ /* > Specifies how the vectors which define the elementary */ /* > reflectors are stored (see also Further Details): */ -/* > = 'C': columnwise */ -/* > = 'R': rowwise */ +/* > = 'C': column-wise */ +/* > = 'R': row-wise */ +/* > = 'T': (With DIRECT='F') Row-wise, but we return the T */ +/* > matrix that is already (conjugate) transposed. */ /* > \endverbatim */ /* > */ /* > \param[in] N */ @@ -381,6 +377,29 @@ f"> */ /* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ /* > ( 1 v3 ) */ /* > ( 1 ) */ +/* > */ +/* > In addition, the shape of T is determined by these same flags as */ +/* > in the below table. */ +/* > 'U' denotes upper triangular */ +/* > 'L' denotes lower triangular */ +/* > 'X' denotes no current implementation */ +/* > We also provide the logical variable that represents the case */ +/* > in the code if it is implemented */ +/* > */ +/* > |-----------------------------------------------------------| */ +/* > | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | */ +/* > |--------------+--------------+--------------+--------------| */ +/* > | STOREV = 'C' | U (QR) | L (QL) | X | */ +/* > | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | */ +/* > | STOREV = 'T' | L (LQT) | X | X | */ +/* > |-----------------------------------------------------------| */ +/* > */ +/* > Finally, the relationship between the (conjugate) transposed T matrices */ +/* > are as follows: (Note that T_{FC} denotes the T associated with calling */ +/* > this routine with DIRECT = 'F' and STOREV = 'C') */ +/* > */ +/* > T_{TR} = (T_{BR})**H */ +/* > T_{FT} = (T_{FR})**H */ /* > \endverbatim */ /* > */ /* ===================================================================== */ @@ -393,14 +412,19 @@ f"> */ doublereal d__1; /* Local variables */ - integer i__, j, prevlastv; + integer i__, j; + logical lq, ql, qr, rq; + integer kmi, nmi; + logical lqt, rqt, dirb, dirf; + integer info; + logical dirt; extern logical lsame_(char *, char *); extern /* Subroutine */ void dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *); - integer lastv; - extern /* Subroutine */ void dtrmv_(char *, char *, char *, integer *, - doublereal *, integer *, doublereal *, integer *), mecago_(); + doublereal *, doublereal *, integer *), dtrmv_(char *, + char *, char *, integer *, doublereal *, integer *, doublereal *, + integer *), xerbla_(char *, integer *, ftnlen); + logical storec, storer, storet; /* -- LAPACK auxiliary routine -- */ @@ -408,10 +432,16 @@ f"> */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* ===================================================================== */ -/* Quick return if possible */ + + + + + + + +/* Convert our character flags to logical flags for later */ /* Parameter adjustments */ v_dim1 = *ldv; @@ -423,171 +453,565 @@ f"> */ t -= t_offset; /* Function Body */ - if (*n == 0) { + dirf = lsame_(direct, "F"); + dirb = lsame_(direct, "B"); + dirt = lsame_(direct, "T"); + storec = lsame_(storev, "C"); + storer = lsame_(storev, "R"); + storet = lsame_(storev, "T"); + +/* Error handling for our character flags */ + + info = 0; + if (! (dirf || dirb || dirt)) { + +/* DIRECT holds an illegal value */ + + info = 1; + } else if (! (storec || storer || storet)) { + +/* STOREV holds an illegal value */ + + info = 2; + } else if (dirb && storet) { + +/* This case is purposefully not implemented, but any other value for */ +/* STOREV is valid, so we report STOREV as the invalid input */ + + info = 2; + } else if (dirt && storec) { + +/* This case is purposefully not implemented, but any other value for */ +/* DIRECT is valid, so we report DIRECT as the invalid input */ + + info = 1; + } else if (dirt && storet) { + +/* This case is purposefully not implemented, and is ambiguous what */ +/* the user wants to do, so we arbitrarily say DIRECT is the incorrect */ +/* character flag. */ + + info = 1; + } + if (info != 0) { + xerbla_("DLARFT_LVL2", &info, (ftnlen)11); + return; + } + +/* Quick return if possible */ + + if (*n == 0 || *k == 0) { + return; + } + +/* Now we determine what factorization our flags are associated with */ + +/* QR happens when we have forward direction in column storage */ + + qr = dirf && storec; + +/* LQT happens when we have forward direction in row storage and want to compute the transpose of */ +/* the T we would normally compute */ + + lqt = dirf && storet; + +/* LQ happens when we have forward direction in row storage and want to compute the T we would */ +/* normally compute */ + + lq = dirf && storer; + +/* QL happens when we have backward direction in column storage */ + + ql = dirb && storec; + +/* RQT happens when we have backward direction in row storage and want to compute the transpose */ +/* of the T we would normally compute */ + + rqt = dirt && storer; + +/* RQ happens when we have backward direction in row storage and want to compute the T that we */ +/* would normally compute */ + + rq = dirb && storer; + if (*n == 1 || *k == 1) { + t[t_dim1 + 1] = tau[1]; return; } + if (qr) { + +/* Break V into 9 components */ + +/* V = |-----------------------| */ +/* |V_{1,1} 0 0 | i-1 */ +/* |V_{2,1} V_{2,2} 0 | 1 */ +/* |V_{3,1} V_{3,2} V_{3,3}| n-i */ +/* |-----------------------| */ +/* i-1 1 k-i */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{3,3} and repeat until we */ +/* reach the end. On each iteration V_{3,3} is not referenced */ + +/* We will construct T one column at a time from left to right */ +/* after initializing T(1,1) = TAU(1) */ + +/* T = |-------------------------| */ +/* | T_{1,1} T_{1,2} T_{1,3} | i-1 */ +/* | 0 T_{2,2} T_{2,3} | 1 */ +/* | 0 0 T_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 k-i */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{1,2} and T_{2,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On */ +/* each iteration, T_{1:3,3} are not referenced. See dlarft.f */ +/* for details on how these formulae were constructed. */ + +/* We now get */ + +/* T_{1,2} = -T_{1,1}[V_{1,1}\\V_{2,1}\\V_{3,1}]' */ +/* [0\\V_{2,2}\\V_{3,2}]T_{2,2} */ + +/* T_{1,2} = -T_{1,1}(V_{2,1}' + V_{3,1}'V_{3,2})T_{2,2} */ - if (lsame_(direct, "F")) { - prevlastv = *n; +/* This means we will do the following */ + +/* T_{1,2} = -V_{2,1}'T_{2,2} = -\tau_{i}V_{2,1}' */ +/* T_{1,2} = -\tau_{i}V_{3,2}' V_{3,1} + T_{1,2} */ +/* T_{1,2} = T_{1,1}T_{1,2} */ +/* T_{2,2} = \tau{i} */ + + t[t_dim1 + 1] = tau[1]; i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - prevlastv = f2cmax(i__,prevlastv); - if (tau[i__] == 0.) { - -/* H(i) = I */ - - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = 0.; - } - } else { - -/* general case */ - - if (lsame_(storev, "C")) { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - if (v[lastv + i__ * v_dim1] != 0.) { - myexit_(); - } - } - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1]; - } - j = f2cmin(lastv,prevlastv); - -/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) */ - - i__2 = j - i__; - i__3 = i__ - 1; - d__1 = -tau[i__]; - dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + 1 + - v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, & - c_b6, &t[i__ * t_dim1 + 1], &c__1); - } else { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - if (v[i__ + lastv * v_dim1] != 0.) { - myexit_(); - } - } - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1]; - } - j = f2cmin(lastv,prevlastv); - -/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T */ - - i__2 = i__ - 1; - i__3 = j - i__; - d__1 = -tau[i__]; - dgemv_("No transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) * - v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], - ldv, &c_b6, &t[i__ * t_dim1 + 1], &c__1); - } - -/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ - - i__2 = i__ - 1; - dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ - t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); - t[i__ + i__ * t_dim1] = tau[i__]; - if (i__ > 1) { - prevlastv = f2cmax(prevlastv,lastv); - } else { - prevlastv = lastv; - } + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T_{1,2} = -V_{2,1}'V_{2,2}T_{2,2} = -\tau_i V_{2,1}' */ +/* We must do this at copy time as otherwise gemv will do nothing */ +/* on the last column when n=k, but we neet to make sure we are */ +/* scaled by this value */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = -v[i__ + j * v_dim1] * tau[i__]; } + +/* T_{1,2} = -V_{3,1}'V_{3,2}T_{2,2} + T_{1,2} */ +/* = -\tau{i} V_{3,2}'V_{3,1} + T_{1,2} */ + + i__2 = *n - i__; + i__3 = i__ - 1; + d__1 = -tau[i__]; + dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + 1 + v_dim1], + ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, &c_b11, &t[i__ * + t_dim1 + 1], &c__1); + +/* T_{1,2} = T_{1,1}T_{1,2} */ + + i__2 = i__ - 1; + dtrmv_("Upper", "No Transpose", "Non-unit", &i__2, &t[t_offset], + ldt, &t[i__ * t_dim1 + 1], &c__1); + +/* T_{2,2} = \tau{i} */ + + t[i__ + i__ * t_dim1] = tau[i__]; } - } else { - prevlastv = 1; - for (i__ = *k; i__ >= 1; --i__) { - if (tau[i__] == 0.) { - -/* H(i) = I */ - - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - t[j + i__ * t_dim1] = 0.; - } - } else { - -/* general case */ - - if (i__ < *k) { - if (lsame_(storev, "C")) { -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[lastv + i__ * v_dim1] != 0.) { - myexit_(); - } - } - i__1 = *k; - for (j = i__ + 1; j <= i__1; ++j) { - t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__ - + j * v_dim1]; - } - j = f2cmax(lastv,prevlastv); - -/* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) */ - - i__1 = *n - *k + i__ - j; - i__2 = *k - i__; - d__1 = -tau[i__]; - dgemv_("Transpose", &i__1, &i__2, &d__1, &v[j + (i__ - + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], & - c__1, &c_b6, &t[i__ + 1 + i__ * t_dim1], & - c__1); - } else { -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[i__ + lastv * v_dim1] != 0.) { - myexit_(); - } - } - i__1 = *k; - for (j = i__ + 1; j <= i__1; ++j) { - t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k - + i__) * v_dim1]; - } - j = f2cmax(lastv,prevlastv); - -/* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T */ - - i__1 = *k - i__; - i__2 = *n - *k + i__ - j; - d__1 = -tau[i__]; - dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ + - 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], - ldv, &c_b6, &t[i__ + 1 + i__ * t_dim1], &c__1); - } - -/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ - - i__1 = *k - i__; - dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ - + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * - t_dim1], &c__1) - ; - if (i__ > 1) { - prevlastv = f2cmin(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - t[i__ + i__ * t_dim1] = tau[i__]; + } else if (lq) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} V_{1,2} V_{1,3} | i-1 */ +/* | 0 V_{2,2} V_{2,3} | 1 */ +/* | 0 0 V_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 n-i */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{3,3} and repeat until we */ +/* reach the end. On each iteration V_{3,3} is not referenced */ + +/* We will construct T one column at a time from left to right */ +/* after initializing T(1,1) = TAU(1) */ + +/* T = |-------------------------| */ +/* | T_{1,1} T_{1,2} T_{1,3} | i-1 */ +/* | 0 T_{2,2} T_{2,3} | 1 */ +/* | 0 0 T_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 k-i */ + +/* Similarly as above, we will construct T_{1,2} and T_{2,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On */ +/* each iteration, T_{1:3,3} are not referenced. See dlarft.f */ +/* for details on how these formulae were constructed. */ + +/* We now get */ + +/* T_{1,2} = -T_{1,1}[V_{1,1} V_{1,2} V_{1,3}][ 0 V_{2,2} V_{2,3} ]'T_{2,2} */ + +/* T_{1,2} = -T_{1,1}(V_{1,2} + V_{1,3}V_{2,3}')T_{2,2} */ + +/* This means we will do the following */ + +/* T_{1,2} = -V_{1,2}T_{2,2} = -\tau_{i}V_{1,2} */ +/* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} */ +/* T_{1,2} = T_{1,1}T_{1,2} */ +/* T_{2,2} = \tau{i} */ + + t[t_dim1 + 1] = tau[1]; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T_{1,2} = -\tau_{i}V_{1,2} */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1]; } + +/* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + d__1 = -tau[i__]; + dgemv_("No Transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) * v_dim1 + + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], ldv, &c_b11, &t[ + i__ * t_dim1 + 1], &c__1); + +/* T_{1,2} = T_{1,1}T_{1,2} */ + + i__2 = i__ - 1; + dtrmv_("Upper", "No Transpose", "Non-unit", &i__2, &t[t_offset], + ldt, &t[i__ * t_dim1 + 1], &c__1); + +/* T_{2,2} = \tau{i} */ + + t[i__ + i__ * t_dim1] = tau[i__]; } - } - return; + } else if (lqt) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} V_{1,2} V_{1,3} | i-1 */ +/* | 0 V_{2,2} V_{2,3} | 1 */ +/* | 0 0 V_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 n-i */ -/* End of DLARFT_LVL2 */ +/* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular */ +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{3,3} and repeat until we */ +/* reach the end. On each iteration V_{3,3} is not referenced */ + +/* We will construct T one column at a time from left to right */ +/* after initializing T(1,1) = TAU(1) */ + +/* T = |-------------------------| */ +/* | T_{1,1} 0 0 | i-1 */ +/* | T_{2,1} T_{2,2} 0 | 1 */ +/* | T_{3,1} T_{3,2} T_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 k-i */ + +/* Similarly as above, we will construct T_{2,1} and T_{2,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{3,1:3}. On */ +/* each iteration, T_{3,1:3} are not referenced. See dlarft.f */ +/* for details on how these formulae were constructed. */ + +/* We now get */ + +/* T_{2,1} = -T_{2,2}[0 V_{2,2} V_{2,3}][V_{1,1} V_{1,2} V_{1,3}]'T_{1,1} */ + +/* T_{2,1} = -T_{2,2}(V_{1,2}' + V_{2,3}V_{1,3}')T_{1,1} */ + +/* This means we will do the following */ + +/* T_{2,1} = -T_{2,2}V_{1,2}' = -\tau_{i}V_{1,2}' */ +/* T_{2,1} = -\tau_{i}V_{1,3}V_{2,3}' + T_{2,1} */ +/* T_{2,1} = T_{1,1}'T_{2,1} */ +/* T_{2,2} = \tau{i} */ + + t[t_dim1 + 1] = tau[1]; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T_{2,1} = -\tau_{i}V_{1,2}' */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[i__ + j * t_dim1] = -tau[i__] * v[j + i__ * v_dim1]; + } + +/* T_{2,1} = -\tau_{i}V_{1,3}V_{2,3}' + T_{2,1} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + d__1 = -tau[i__]; + dgemv_("No transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) * v_dim1 + + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], ldv, &c_b11, &t[ + i__ + t_dim1], ldt); + +/* T_{2,1} = T_{1,1}'T_{2,1}' */ + + i__2 = i__ - 1; + dtrmv_("Lower", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt, + &t[i__ + t_dim1], ldt); + t[i__ + i__ * t_dim1] = tau[i__]; + } + } else if (ql) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} V_{1,2} V_{1,3} | n-i */ +/* | 0 V_{2,2} V_{2,3} | 1 */ +/* | 0 0 V_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{1,1} and repeat until we */ +/* reach the end. On each iteration V_{1,1} is not referenced */ + +/* We will construct T one column at a time from right to left */ +/* after initializing T(K,K) = TAU(K) */ + +/* T = |-------------------------| */ +/* | T_{1,1} 0 0 | k-i */ +/* | T_{2,1} T_{2,2} 0 | 1 */ +/* | T_{3,1} T_{3,2} T_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{2,2} and T_{3,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On */ +/* each iteration, T_{1:3,1} are not referenced. See dlarft.f */ +/* for details on how these formulae were constructed. */ + +/* We get that */ + +/* T_{3,2} = -T_{3,3}[V_{1,3}\\V_{2,3}\\V_{3,3}]' */ +/* [V_{1,2}\\V_{2,2}\\0]T_{2,2} */ + +/* T_{3,2} = -T_{3,3}(V_{1,3}'V_{1,2} + V_{2,3}')T_{2,2} */ + +/* Thus, we will compute */ + +/* T_{2,2} = \tau_{k-i+1} */ +/* T_{3,2} = -T_{3,3}V_{3,2}' = -\tau_{k-i+1}V_{3,2}' */ +/* T_{3,2} = -\tau_{k-i+1}V_{1,3}'V_{1,2} + T_{3,2} */ +/* T_{3,2} = T_{3,3}T_{3,2} */ + + t[*k + *k * t_dim1] = tau[*k]; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + kmi = *k - i__ + 1; + nmi = *n - i__ + 1; + +/* T_{2,2} = \tau(k-i+1) */ + + t[kmi + kmi * t_dim1] = tau[kmi]; + +/* T_{3,2} = -\tau(k-i+1)V_{2,3}' */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[kmi + j + kmi * t_dim1] = -tau[kmi] * v[nmi + (kmi + j) * + v_dim1]; + } + +/* T_{3,2} = -\tau(k-i+1)V_{1,3}'V_{1,2} + T_{3,2} */ + + i__2 = *n - i__; + i__3 = i__ - 1; + d__1 = -tau[kmi]; + dgemv_("Transpose", &i__2, &i__3, &d__1, &v[(kmi + 1) * v_dim1 + + 1], ldv, &v[kmi * v_dim1 + 1], &c__1, &c_b11, &t[kmi + 1 + + kmi * t_dim1], &c__1); + +/* T_{3,2} = T_{3,3}T_{3,2} */ + + i__2 = i__ - 1; + dtrmv_("Lower", "No Transpose", "Non-unit", &i__2, &t[kmi + 1 + ( + kmi + 1) * t_dim1], ldt, &t[kmi + 1 + kmi * t_dim1], & + c__1); + } + } else if (rq) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} 0 0 | k-i */ +/* | V_{2,1} V_{2,2} 0 | 1 */ +/* | V_{3,1} V_{3,2} V_{3,3} | i-1 */ +/* |-------------------------| */ +/* n-i 1 i-1 */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{1,1} and repeat until we */ +/* reach the end. On each iteration V_{1,1} is not referenced */ + +/* We will construct T one column at a time from right to left */ +/* after initializing T(K,K) = TAU(K) */ + +/* T = |-------------------------| */ +/* | T_{1,1} 0 0 | k-i */ +/* | T_{2,1} T_{2,2} 0 | 1 */ +/* | T_{3,1} T_{3,2} T_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{2,2} and T_{3,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On */ +/* each iteration, T_{1:3,1} are not referenced. See dlarft.f */ +/* for details on how these formulae were constructed. */ + +/* We get that */ + +/* T_{3,2} = -T_{3,3}[V_{3,1} V_{3,2} V_{3,3}][V_{2,1} V_{2,2} 0]'T_{2,2} */ + +/* T_{3,2} = -T_{3,3}(V_{3,1}V_{2,1}' + V_{3,2})T_{2,2} */ + +/* Thus, we will compute */ + +/* T_{2,2} = \tau_{k-i+1} */ +/* T_{3,2} = -\tau_{k-i+1}V_{3,2} */ +/* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} */ +/* T_{3,2} = T_{3,3}T_{3,2} */ + + t[*k + *k * t_dim1] = tau[*k]; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + kmi = *k - i__ + 1; + nmi = *n - i__ + 1; + +/* T_{2,2} = \tau_{k-i+1} */ + + t[kmi + kmi * t_dim1] = tau[kmi]; + +/* T_{3,2} = -\tau_{k-i+1}V_{3,2} */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[kmi + j + kmi * t_dim1] = -tau[kmi] * v[kmi + j + nmi * + v_dim1]; + } + +/* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + d__1 = -tau[kmi]; + dgemv_("No Transpose", &i__2, &i__3, &d__1, &v[kmi + 1 + v_dim1], + ldv, &v[kmi + v_dim1], ldv, &c_b11, &t[kmi + 1 + kmi * + t_dim1], &c__1); + +/* T_{3,2} = T_{3,3}T_{3,2} */ + + i__2 = i__ - 1; + dtrmv_("Lower", "No Transpose", "Non-unit", &i__2, &t[kmi + 1 + ( + kmi + 1) * t_dim1], ldt, &t[kmi + 1 + kmi * t_dim1], & + c__1); + } + } else if (rqt) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} 0 0 | k-i */ +/* | V_{2,1} V_{2,2} 0 | 1 */ +/* | V_{3,1} V_{3,2} V_{3,3} | i-1 */ +/* |-------------------------| */ +/* n-i 1 i-1 */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{1,1} and repeat until we */ +/* reach the end. On each iteration V_{1,1} is not referenced */ + +/* We will construct T one column at a time from right to left */ +/* after initializing T(K,K) = TAU(K) */ + +/* T = |-------------------------| */ +/* | T_{1,1} T_{1,2} T_{1,3} | k-i */ +/* | 0 T_{2,2} T_{2,3} | 1 */ +/* | 0 0 T_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{2,2} and T_{2,3} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1,1:3}. On */ +/* each iteration, T_{1,1:3} are not referenced. See dlarft.f */ +/* for details on how these formulae were constructed. */ + +/* We get that */ + +/* T_{2,3} = -T_{2,2}[V_{2,1} V_{2,2} 0][V_{3,1} V_{3,2} V_{3,3}]'T_{3,3} */ + +/* After transposing when necessary to fit our blas routines' interface, */ +/* we get */ +/* T_{3,2} = -T_{2,2}(V_{3,1}V_{2,1} + V_{3,2})T_{3,3} */ + +/* Thus, we will compute */ + +/* T_{2,2} = \tau_{k-i+1} */ +/* T_{2,3} = -\tau_{k-i+1}V_{3,2}' */ +/* T_{2,3} = -\tau_{k-i+1}V_{3,1}V_{2,1} + T_{2,3} */ +/* T_{2,3} = T_{3,3}'T_{2,3} */ + + t[*k + *k * t_dim1] = tau[*k]; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + kmi = *k - i__ + 1; + nmi = *n - i__ + 1; + +/* T_{2,2} = \tau_{k-i+1} */ + + t[kmi + kmi * t_dim1] = tau[kmi]; + +/* T_{2,3} = -\tau_{k-i+1}V_{3,2}' */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[kmi + (kmi + j) * t_dim1] = -tau[kmi] * v[kmi + j + nmi * + v_dim1]; + } + +/* T_{2,3} = -\tau_{k-i+1}V_{3,1}V_{2,1} + T_{2,3} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + d__1 = -tau[kmi]; + dgemv_("No Transpose", &i__2, &i__3, &d__1, &v[kmi + 1 + v_dim1], + ldv, &v[kmi + v_dim1], ldv, &c_b11, &t[kmi + (kmi + 1) * + t_dim1], ldt); + +/* T_{2,3} = T_{3,3}'T_{2,3} */ + + i__2 = i__ - 1; + dtrmv_("Upper", "Transpose", "Non-unit", &i__2, &t[kmi + 1 + (kmi + + 1) * t_dim1], ldt, &t[kmi + (kmi + 1) * t_dim1], ldt); + } + } + return; } /* dlarft_lvl2__ */ diff --git a/lapack-netlib/SRC/dlarft_lvl2.f b/lapack-netlib/SRC/dlarft_lvl2.f index 9614df466d..df8b358d36 100644 --- a/lapack-netlib/SRC/dlarft_lvl2.f +++ b/lapack-netlib/SRC/dlarft_lvl2.f @@ -1,23 +1,15 @@ -*> \brief \b DLARFT_LVL2: Level 2 BLAS version for terminating case of DLARFT. +*> \brief \b DLARFT_LVL2 forms the triangular factor T of a block reflector H = I - vtvH * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> Download DLARFT_LVL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -* * Definition: * =========== * * SUBROUTINE DLARFT_LVL2( DIRECT, STOREV, N, K, V, LDV, TAU, -* T, LDT ) +* $ T, LDT ) * * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV @@ -49,6 +41,9 @@ *> H(i) is stored in the i-th row of the array V, and *> *> H = I - V**T * T * V +*> +*> If DIRECT or STOREV = 'T', see Further Details for the shape of T +*> *> \endverbatim * * Arguments: @@ -61,6 +56,8 @@ *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) +*> = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) +*> but we return the T matrix that is already (conjugate) transposed *> \endverbatim *> *> \param[in] STOREV @@ -68,8 +65,10 @@ *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise +*> = 'C': column-wise +*> = 'R': row-wise +*> = 'T': (With DIRECT='F') Row-wise, but we return the T +*> matrix that is already (conjugate) transposed. *> \endverbatim *> *> \param[in] N @@ -155,6 +154,29 @@ *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) +*> +*> In addition, the shape of T is determined by these same flags as +*> in the below table. +*> 'U' denotes upper triangular +*> 'L' denotes lower triangular +*> 'X' denotes no current implementation +*> We also provide the logical variable that represents the case +*> in the code if it is implemented +*> +*> |-----------------------------------------------------------| +*> | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | +*> |--------------+--------------+--------------+--------------| +*> | STOREV = 'C' | U (QR) | L (QL) | X | +*> | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | +*> | STOREV = 'T' | L (LQT) | X | X | +*> |-----------------------------------------------------------| +*> +*> Finally, the relationship between the (conjugate) transposed T matrices +*> are as follows: (Note that T_{FC} denotes the T associated with calling +*> this routine with DIRECT = 'F' and STOREV = 'C') +*> +*> T_{TR} = (T_{BR})**H +*> T_{FT} = (T_{FR})**H *> \endverbatim *> * ===================================================================== @@ -170,157 +192,549 @@ SUBROUTINE DLARFT_LVL2( DIRECT, STOREV, N, K, V, LDV, TAU, INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. +* DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. * -* ===================================================================== -* * .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. +* + DOUBLE PRECISION ONE + PARAMETER(ONE=1.0D+0) +* * .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV -* .. +* + INTEGER I,J,KMI,NMI,INFO + LOGICAL QR, LQ, QL, RQ, LQT, RQT, + $ DIRF, DIRB, DIRT, + $ STOREC, STORER, STORET +* * .. External Subroutines .. - EXTERNAL DGEMV, DTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME +* + EXTERNAL DTRMV,DGEMV,XERBLA +* +* .. External Functions.. +* + LOGICAL LSAME + EXTERNAL LSAME * .. * .. Executable Statements .. * +* Convert our character flags to logical flags for later +* + DIRF = LSAME(DIRECT,'F') + DIRB = LSAME(DIRECT,'B') + DIRT = LSAME(DIRECT,'T') + STOREC = LSAME(STOREV,'C') + STORER = LSAME(STOREV,'R') + STORET = LSAME(STOREV,'T') +* +* Error handling for our character flags +* + INFO = 0 + IF( .NOT.(DIRF.OR.DIRB.OR.DIRT) ) THEN +* +* DIRECT holds an illegal value +* + INFO = 1 + ELSE IF( .NOT.(STOREC.OR.STORER.OR.STORET) ) THEN +* +* STOREV holds an illegal value +* + INFO = 2 + ELSE IF( DIRB.AND.STORET ) THEN +* +* This case is purposefully not implemented, but any other value for +* STOREV is valid, so we report STOREV as the invalid input +* + INFO = 2 + ELSE IF( DIRT.AND.STOREC ) THEN +* +* This case is purposefully not implemented, but any other value for +* DIRECT is valid, so we report DIRECT as the invalid input +* + INFO = 1 + ELSE IF( DIRT.AND.STORET ) THEN +* +* This case is purposefully not implemented, and is ambiguous what +* the user wants to do, so we arbitrarily say DIRECT is the incorrect +* character flag. +* + INFO = 1 + END IF + + IF( INFO.NE.0 ) THEN + CALL XERBLA('DLARFT_LVL2', INFO) + RETURN + END IF +* * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO I = 1, K - PREVLASTV = MAX( I, PREVLASTV ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = 1, I - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( I , J ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) -* - CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ), - $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, - $ T( 1, I ), 1 ) - ELSE -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( J , I ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T -* - CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE, - $ T( 1, I ), 1 ) - END IF -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF + IF(N.EQ.0.OR.K.EQ.0) THEN + RETURN + END IF +* +* Now we determine what factorization our flags are associated with +* +* QR happens when we have forward direction in column storage +* + QR = DIRF.AND.STOREC +* +* LQT happens when we have forward direction in row storage and want to compute the transpose of +* the T we would normally compute +* + LQT = DIRF.AND.STORET +* +* LQ happens when we have forward direction in row storage and want to compute the T we would +* normally compute +* + LQ = DIRF.AND.STORER +* +* QL happens when we have backward direction in column storage +* + QL = DIRB.AND.STOREC +* +* RQT happens when we have backward direction in row storage and want to compute the transpose +* of the T we would normally compute +* + RQT = DIRT.AND.STORER +* +* RQ happens when we have backward direction in row storage and want to compute the T that we +* would normally compute +* + RQ = DIRB.AND.STORER + IF( N.EQ.1.OR.K.EQ.1) THEN + T(1,1) = TAU(1) + RETURN + END IF + IF (QR) THEN +* +* Break V into 9 components +* +* V = |-----------------------| +* |V_{1,1} 0 0 | i-1 +* |V_{2,1} V_{2,2} 0 | 1 +* |V_{3,1} V_{3,2} V_{3,3}| n-i +* |-----------------------| +* i-1 1 k-i +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{3,3} and repeat until we +* reach the end. On each iteration V_{3,3} is not referenced +* +* We will construct T one column at a time from left to right +* after initializing T(1,1) = TAU(1) +* +* T = |-------------------------| +* | T_{1,1} T_{1,2} T_{1,3} | i-1 +* | 0 T_{2,2} T_{2,3} | 1 +* | 0 0 T_{3,3} | k-i +* |-------------------------| +* i-1 1 k-i +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{1,2} and T_{2,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On +* each iteration, T_{1:3,3} are not referenced. See dlarft.f +* for details on how these formulae were constructed. +* +* We now get +* +* T_{1,2} = -T_{1,1}[V_{1,1}\\V_{2,1}\\V_{3,1}]' +* [0\\V_{2,2}\\V_{3,2}]T_{2,2} +* +* T_{1,2} = -T_{1,1}(V_{2,1}' + V_{3,1}'V_{3,2})T_{2,2} +* +* This means we will do the following +* +* T_{1,2} = -V_{2,1}'T_{2,2} = -\tau_{i}V_{2,1}' +* T_{1,2} = -\tau_{i}V_{3,2}' V_{3,1} + T_{1,2} +* T_{1,2} = T_{1,1}T_{1,2} +* T_{2,2} = \tau{i} +* + T(1,1) = TAU(1) + DO I = 2, K +* +* T_{1,2} = -V_{2,1}'V_{2,2}T_{2,2} = -\tau_i V_{2,1}' +* We must do this at copy time as otherwise gemv will do nothing +* on the last column when n=k, but we neet to make sure we are +* scaled by this value +* + DO J = 1, I-1 + T(J,I) = -V(I,J)*TAU(I) + END DO +* +* T_{1,2} = -V_{3,1}'V_{3,2}T_{2,2} + T_{1,2} +* = -\tau{i} V_{3,2}'V_{3,1} + T_{1,2} +* + CALL DGEMV('Transpose', N-I, I-1, -TAU(I), V(I+1,1), + $ LDV, V(I+1,I), 1, ONE, T(1, I), 1) +* +* T_{1,2} = T_{1,1}T_{1,2} +* + CALL DTRMV('Upper', 'No Transpose', 'Non-unit', I-1, + $ T, LDT, T(1,I), 1) +* +* T_{2,2} = \tau{i} +* + T(I,I) = TAU(I) END DO - ELSE - PREVLASTV = 1 - DO I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = I, K - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( N-K+I , J ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I-J, K-I, - $ -TAU( I ), - $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, - $ T( I+1, I ), 1 ) - ELSE -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T -* - CALL DGEMV( 'No transpose', K-I, N-K+I-J, - $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), 1 ) - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', - $ K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF + ELSE IF (LQ) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} V_{1,2} V_{1,3} | i-1 +* | 0 V_{2,2} V_{2,3} | 1 +* | 0 0 V_{3,3} | k-i +* |-------------------------| +* i-1 1 n-i +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{3,3} and repeat until we +* reach the end. On each iteration V_{3,3} is not referenced +* +* We will construct T one column at a time from left to right +* after initializing T(1,1) = TAU(1) +* +* T = |-------------------------| +* | T_{1,1} T_{1,2} T_{1,3} | i-1 +* | 0 T_{2,2} T_{2,3} | 1 +* | 0 0 T_{3,3} | k-i +* |-------------------------| +* i-1 1 k-i +* +* Similarly as above, we will construct T_{1,2} and T_{2,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On +* each iteration, T_{1:3,3} are not referenced. See dlarft.f +* for details on how these formulae were constructed. +* +* We now get +* +* T_{1,2} = -T_{1,1}[V_{1,1} V_{1,2} V_{1,3}][ 0 V_{2,2} V_{2,3} ]'T_{2,2} +* +* T_{1,2} = -T_{1,1}(V_{1,2} + V_{1,3}V_{2,3}')T_{2,2} +* +* This means we will do the following +* +* T_{1,2} = -V_{1,2}T_{2,2} = -\tau_{i}V_{1,2} +* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} +* T_{1,2} = T_{1,1}T_{1,2} +* T_{2,2} = \tau{i} +* + T(1,1) = TAU(1) + DO I = 2, K +* +* T_{1,2} = -\tau_{i}V_{1,2} +* + DO J = 1, I-1 + T(J, I) = -TAU(I)*V(J, I) + END DO +* +* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} +* + CALL DGEMV('No Transpose', I-1, N-I, -TAU(I), V(1, I+1), + $ LDV, V(I, I+1), LDV, ONE, T(1,I), 1) +* +* T_{1,2} = T_{1,1}T_{1,2} +* + CALL DTRMV('Upper', 'No Transpose', 'Non-unit', I-1, + $ T, LDT, T(1,I), 1) +* +* T_{2,2} = \tau{i} +* + T(I,I) = TAU(I) END DO - END IF - RETURN + ELSE IF (LQT) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} V_{1,2} V_{1,3} | i-1 +* | 0 V_{2,2} V_{2,3} | 1 +* | 0 0 V_{3,3} | k-i +* |-------------------------| +* i-1 1 n-i +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{3,3} and repeat until we +* reach the end. On each iteration V_{3,3} is not referenced +* +* We will construct T one column at a time from left to right +* after initializing T(1,1) = TAU(1) +* +* T = |-------------------------| +* | T_{1,1} 0 0 | i-1 +* | T_{2,1} T_{2,2} 0 | 1 +* | T_{3,1} T_{3,2} T_{3,3} | k-i +* |-------------------------| +* i-1 1 k-i +* +* Similarly as above, we will construct T_{2,1} and T_{2,2} at +* each iteration i = 2, \dots k, and then grow into T_{3,1:3}. On +* each iteration, T_{3,1:3} are not referenced. See dlarft.f +* for details on how these formulae were constructed. +* +* We now get +* +* T_{2,1} = -T_{2,2}[0 V_{2,2} V_{2,3}][V_{1,1} V_{1,2} V_{1,3}]'T_{1,1} +* +* T_{2,1} = -T_{2,2}(V_{1,2}' + V_{2,3}V_{1,3}')T_{1,1} +* +* This means we will do the following +* +* T_{2,1} = -T_{2,2}V_{1,2}' = -\tau_{i}V_{1,2}' +* T_{2,1} = -\tau_{i}V_{1,3}V_{2,3}' + T_{2,1} +* T_{2,1} = T_{1,1}'T_{2,1} +* T_{2,2} = \tau{i} +* + T(1,1) = TAU(1) + DO I = 2, K +* +* T_{2,1} = -\tau_{i}V_{1,2}' +* + DO J = 1, I-1 + T(I,J) = -TAU(I)*V(J,I) + END DO +* +* T_{2,1} = -\tau_{i}V_{1,3}V_{2,3}' + T_{2,1} +* + CALL DGEMV('No transpose', I-1, N-I, -TAU(I), V(1, I+1), + $ LDV, V(I, I+1), LDV, ONE, T(I, 1), LDT) +* +* T_{2,1} = T_{1,1}'T_{2,1}' +* + CALL DTRMV('Lower', 'Transpose', 'Non-unit', I-1, + $ T, LDT, T(I,1), LDT) + T(I,I) = TAU(I) + END DO + ELSE IF (QL) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} V_{1,2} V_{1,3} | n-i +* | 0 V_{2,2} V_{2,3} | 1 +* | 0 0 V_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{1,1} and repeat until we +* reach the end. On each iteration V_{1,1} is not referenced +* +* We will construct T one column at a time from right to left +* after initializing T(K,K) = TAU(K) +* +* T = |-------------------------| +* | T_{1,1} 0 0 | k-i +* | T_{2,1} T_{2,2} 0 | 1 +* | T_{3,1} T_{3,2} T_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{2,2} and T_{3,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On +* each iteration, T_{1:3,1} are not referenced. See dlarft.f +* for details on how these formulae were constructed. +* +* We get that +* +* T_{3,2} = -T_{3,3}[V_{1,3}\\V_{2,3}\\V_{3,3}]' +* [V_{1,2}\\V_{2,2}\\0]T_{2,2} +* +* T_{3,2} = -T_{3,3}(V_{1,3}'V_{1,2} + V_{2,3}')T_{2,2} +* +* Thus, we will compute +* +* T_{2,2} = \tau_{k-i+1} +* T_{3,2} = -T_{3,3}V_{3,2}' = -\tau_{k-i+1}V_{3,2}' +* T_{3,2} = -\tau_{k-i+1}V_{1,3}'V_{1,2} + T_{3,2} +* T_{3,2} = T_{3,3}T_{3,2} +* + T(K,K) = TAU(K) + DO I = 2, K + KMI = K-I+1 + NMI = N-I+1 +* +* T_{2,2} = \tau(k-i+1) +* + T(KMI,KMI) = TAU(KMI) +* +* T_{3,2} = -\tau(k-i+1)V_{2,3}' +* + DO J = 1, I-1 + T(KMI + J, KMI) = -TAU(KMI)*V(NMI, KMI + J) + END DO +* +* T_{3,2} = -\tau(k-i+1)V_{1,3}'V_{1,2} + T_{3,2} +* + CALL DGEMV('Transpose', N-I, I-1, -TAU(KMI), + $ V(1, KMI + 1), LDV, V(1, KMI), 1, ONE, + $ T(KMI+1, KMI), 1) +* +* T_{3,2} = T_{3,3}T_{3,2} +* + CALL DTRMV('Lower', 'No Transpose', 'Non-unit', I-1, + $ T(KMI + 1, KMI + 1), LDT, T(KMI + 1, KMI), 1) + END DO + ELSE IF (RQ) THEN * -* End of DLARFT_LVL2 +* Break V into 9 components * - END +* V = |-------------------------| +* | V_{1,1} 0 0 | k-i +* | V_{2,1} V_{2,2} 0 | 1 +* | V_{3,1} V_{3,2} V_{3,3} | i-1 +* |-------------------------| +* n-i 1 i-1 +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{1,1} and repeat until we +* reach the end. On each iteration V_{1,1} is not referenced +* +* We will construct T one column at a time from right to left +* after initializing T(K,K) = TAU(K) +* +* T = |-------------------------| +* | T_{1,1} 0 0 | k-i +* | T_{2,1} T_{2,2} 0 | 1 +* | T_{3,1} T_{3,2} T_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{2,2} and T_{3,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On +* each iteration, T_{1:3,1} are not referenced. See dlarft.f +* for details on how these formulae were constructed. +* +* We get that +* +* T_{3,2} = -T_{3,3}[V_{3,1} V_{3,2} V_{3,3}][V_{2,1} V_{2,2} 0]'T_{2,2} +* +* T_{3,2} = -T_{3,3}(V_{3,1}V_{2,1}' + V_{3,2})T_{2,2} +* +* Thus, we will compute +* +* T_{2,2} = \tau_{k-i+1} +* T_{3,2} = -\tau_{k-i+1}V_{3,2} +* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} +* T_{3,2} = T_{3,3}T_{3,2} +* + T(K,K) = TAU(K) + DO I = 2, K + KMI = K-I+1 + NMI = N-I+1 +* +* T_{2,2} = \tau_{k-i+1} +* + T(KMI,KMI) = TAU(KMI) +* +* T_{3,2} = -\tau_{k-i+1}V_{3,2} +* + DO J = 1, I-1 + T(KMI + J, KMI) = -TAU(KMI)*V(KMI + J, NMI) + END DO +* +* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} +* + CALL DGEMV('No Transpose', I-1, N-I, -TAU(KMI), + $ V(KMI+1, 1), LDV, V(KMI, 1), LDV, ONE, T(KMI+1, KMI), + $ 1) +* +* T_{3,2} = T_{3,3}T_{3,2} +* + CALL DTRMV('Lower', 'No Transpose', 'Non-unit', I-1, + $ T(KMI+1, KMI+1), LDT, T(KMI+1, KMI), 1) + END DO + ELSE IF (RQT) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} 0 0 | k-i +* | V_{2,1} V_{2,2} 0 | 1 +* | V_{3,1} V_{3,2} V_{3,3} | i-1 +* |-------------------------| +* n-i 1 i-1 +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{1,1} and repeat until we +* reach the end. On each iteration V_{1,1} is not referenced +* +* We will construct T one column at a time from right to left +* after initializing T(K,K) = TAU(K) +* +* T = |-------------------------| +* | T_{1,1} T_{1,2} T_{1,3} | k-i +* | 0 T_{2,2} T_{2,3} | 1 +* | 0 0 T_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{2,2} and T_{2,3} at +* each iteration i = 2, \dots k, and then grow into T_{1,1:3}. On +* each iteration, T_{1,1:3} are not referenced. See dlarft.f +* for details on how these formulae were constructed. +* +* We get that +* +* T_{2,3} = -T_{2,2}[V_{2,1} V_{2,2} 0][V_{3,1} V_{3,2} V_{3,3}]'T_{3,3} +* +* After transposing when necessary to fit our blas routines' interface, +* we get +* T_{3,2} = -T_{2,2}(V_{3,1}V_{2,1} + V_{3,2})T_{3,3} +* +* Thus, we will compute +* +* T_{2,2} = \tau_{k-i+1} +* T_{2,3} = -\tau_{k-i+1}V_{3,2}' +* T_{2,3} = -\tau_{k-i+1}V_{3,1}V_{2,1} + T_{2,3} +* T_{2,3} = T_{3,3}'T_{2,3} +* + T(K,K) = TAU(K) + DO I = 2, K + KMI = K-I+1 + NMI = N-I+1 +* +* T_{2,2} = \tau_{k-i+1} +* + T(KMI,KMI) = TAU(KMI) +* +* T_{2,3} = -\tau_{k-i+1}V_{3,2}' +* + DO J = 1, I-1 + T(KMI, KMI + J) = -TAU(KMI)*V(KMI + J, NMI) + END DO +* +* T_{2,3} = -\tau_{k-i+1}V_{3,1}V_{2,1} + T_{2,3} +* + CALL DGEMV('No Transpose', I-1, N-I, -TAU(KMI), + $ V(KMI+1, 1), LDV, V(KMI, 1), LDV, ONE, T(KMI, KMI+1), + $ LDT) +* +* T_{2,3} = T_{3,3}'T_{2,3} +* + CALL DTRMV('Upper', 'Transpose', 'Non-unit', I-1, + $ T(KMI+1, KMI+1), LDT, T(KMI, KMI+1), LDT) + END DO + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/slarft.c b/lapack-netlib/SRC/slarft.c index eb69a6163b..ba66893688 100644 --- a/lapack-netlib/SRC/slarft.c +++ b/lapack-netlib/SRC/slarft.c @@ -296,8 +296,8 @@ static integer smaxloc_(float *w, integer s, integer e, integer *n) static integer c__3 = 3; static integer c_n1 = -1; static integer c__2 = 2; -static real c_b13 = 1.f; -static real c_b22 = -1.f; +static real c_b18 = 1.f; +static real c_b27 = -1.f; /* > \brief \b SLARFT forms the triangular factor T of a block reflector H = I - vtvH */ @@ -348,6 +348,9 @@ f"> */ /* > H(i) is stored in the i-th row of the array V, and */ /* > */ /* > H = I - V**T * T * V */ +/* > */ +/* > If DIRECT or STOREV = 'T', see Further Details for the shape of T */ +/* > */ /* > \endverbatim */ /* Arguments: */ @@ -360,6 +363,8 @@ f"> */ /* > multiplied to form the block reflector: */ /* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ /* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) */ +/* > but we return the T matrix that is already (conjugate) transposed */ /* > \endverbatim */ /* > */ /* > \param[in] STOREV */ @@ -367,8 +372,10 @@ f"> */ /* > STOREV is CHARACTER*1 */ /* > Specifies how the vectors which define the elementary */ /* > reflectors are stored (see also Further Details): */ -/* > = 'C': columnwise */ -/* > = 'R': rowwise */ +/* > = 'C': column-wise */ +/* > = 'R': row-wise */ +/* > = 'T': (With DIRECT='F') Row-wise, but we return the T */ +/* > matrix that is already (conjugate) transposed. */ /* > \endverbatim */ /* > */ /* > \param[in] N */ @@ -425,7 +432,7 @@ f"> */ /* > \author Univ. of Tennessee */ /* > \author Univ. of California Berkeley */ -/* > \author Johnathan Rhyne, Univ. of Colorado Denver (original author, 2024) */ +/* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ /* > \ingroup larft */ @@ -439,7 +446,7 @@ f"> */ /* > the H(i) is best illustrated by the following example with n = 5 and */ /* > k = 3. The elements equal to 1 are not stored. */ /* > */ -/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ +/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and (STOREV = 'R' or STOREV = 'T'): */ /* > */ /* > V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ /* > ( v1 1 ) ( 1 v2 v2 v2 ) */ @@ -447,13 +454,36 @@ f"> */ /* > ( v1 v2 v3 ) */ /* > ( v1 v2 v3 ) */ /* > */ -/* > DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ +/* > DIRECT = 'B' and STOREV = 'C': (DIRECT = 'B' or DIRECT = 'T') and STOREV = 'R': */ /* > */ /* > V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ /* > ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ /* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ /* > ( 1 v3 ) */ /* > ( 1 ) */ +/* > */ +/* > In addition, the shape of T is determined by these same flags as */ +/* > in the below table. */ +/* > 'U' denotes upper triangular */ +/* > 'L' denotes lower triangular */ +/* > 'X' denotes no current implementation */ +/* > We also provide the logical variable that represents the case */ +/* > in the code if it is implemented */ +/* > */ +/* > |-----------------------------------------------------------| */ +/* > | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | */ +/* > |--------------+--------------+--------------+--------------| */ +/* > | STOREV = 'C' | U (QR) | L (QL) | X | */ +/* > | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | */ +/* > | STOREV = 'T' | L (LQT) | X | X | */ +/* > |-----------------------------------------------------------| */ +/* > */ +/* > Finally, the relationship between the (conjugate) transposed T matrices */ +/* > are as follows: (Note that T_{FC} denotes the T associated with calling */ +/* > this routine with DIRECT = 'F' and STOREV = 'C') */ +/* > */ +/* > T_{TR} = (T_{BR})**H */ +/* > T_{FT} = (T_{FR})**H */ /* > \endverbatim */ /* > */ /* ===================================================================== */ @@ -467,21 +497,24 @@ f"> */ /* Local variables */ integer i__, j, l; - logical lq, ql, qr; + logical lq, ql, qr, rq; integer nx; extern /* Subroutine */ void slarft_lvl2__(char *, char *, integer *, integer *, real *, integer *, real *, real *, integer *); - logical dirf, colv; + logical lqt, rqt, dirb, dirf; + integer info; + logical dirt; extern logical lsame_(char *, char *); extern /* Subroutine */ void sgemm_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *), strmm_(char *, char *, char *, char *, integer *, integer *, real *, real *, integer *, real *, - integer *); + integer *), xerbla_(char *, integer *, ftnlen); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ void slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *); + logical storec, storer, storet; /* -- LAPACK auxiliary routine -- */ @@ -504,7 +537,7 @@ f"> */ /* Based on the algorithm of Elmroth and Gustavson, */ /* IBM J. Res. Develop. Vol 44 No. 4 July 2000. */ -/* Quick return if possible */ +/* Convert our character flags to logical flags for later */ /* Parameter adjustments */ v_dim1 = *ldv; @@ -516,10 +549,87 @@ f"> */ t -= t_offset; /* Function Body */ + dirf = lsame_(direct, "F"); + dirb = lsame_(direct, "B"); + dirt = lsame_(direct, "T"); + storec = lsame_(storev, "C"); + storer = lsame_(storev, "R"); + storet = lsame_(storev, "T"); + +/* Error handling for our character flags */ + + info = 0; + if (! (dirf || dirb || dirt)) { + +/* DIRECT holds an illegal value */ + + info = 1; + } else if (! (storec || storer || storet)) { + +/* STOREV holds an illegal value */ + + info = 2; + } else if (dirb && storet) { + +/* This case is purposefully not implemented, but any other value for */ +/* STOREV is valid, so we report STOREV as the invalid input */ + + info = 2; + } else if (dirt && storec) { + +/* This case is purposefully not implemented, but any other value for */ +/* DIRECT is valid, so we report DIRECT as the invalid input */ + + info = 1; + } else if (dirt && storet) { + +/* This case is purposefully not implemented, and is ambiguous what */ +/* the user wants to do, so we arbitrarily say DIRECT is the incorrect */ +/* character flag. */ + + info = 1; + } + if (info != 0) { + xerbla_("SLARFT", &info, (ftnlen)6); + return; + } + +/* Quick return if possible */ + if (*n == 0 || *k == 0) { return; } +/* Now we determine what factorization our flags are associated with */ + +/* QR happens when we have forward direction in column storage */ + + qr = dirf && storec; + +/* LQT happens when we have forward direction in row storage and want to compute the transpose of */ +/* the T we would normally compute */ + + lqt = dirf && storet; + +/* LQ happens when we have forward direction in row storage and want to compute the T we would */ +/* normally compute */ + + lq = dirf && storer; + +/* QL happens when we have backward direction in column storage */ + + ql = dirb && storec; + +/* RQT happens when we have backward direction in row storage and want to compute the transpose */ +/* of the T we would normally compute */ + + rqt = dirt && storer; + +/* RQ happens when we have backward direction in row storage and want to compute the T that we */ +/* would normally compute */ + + rq = dirb && storer; + /* Base case */ if (*n == 1 || *k == 1) { @@ -527,7 +637,7 @@ f"> */ return; } -/* Determine when to cross over into the level 2 based implementation */ +/* Determine crossover point from level 2 to level 3 BLAS implementation */ /* Writing concatenation */ i__1[0] = 1, a__1[0] = direct; @@ -536,41 +646,17 @@ f"> */ nx = ilaenv_(&c__3, "SLARFT", ch__1, n, k, &c_n1, &c_n1, (ftnlen)6, ( ftnlen)2); if (*k < nx) { + +/* Finish this component with a level 2 BLAS implementation */ + slarft_lvl2__(direct, storev, n, k, &v[v_offset], ldv, &tau[1], &t[ t_offset], ldt); return; } -/* Beginning of executable statements */ +/* Beginning of executable statements for the recursive case */ l = *k / 2; - -/* Determine what kind of Q we need to compute */ -/* We assume that if the user doesn't provide 'F' for DIRECT, */ -/* then they meant to provide 'B' and if they don't provide */ -/* 'C' for STOREV, then they meant to provide 'R' */ - - dirf = lsame_(direct, "F"); - colv = lsame_(storev, "C"); - -/* QR happens when we have forward direction in column storage */ - - qr = dirf && colv; - -/* LQ happens when we have forward direction in row storage */ - - lq = dirf && ! colv; - -/* QL happens when we have backward direction in column storage */ - - ql = ! dirf && colv; - -/* The last case is RQ. Due to how we structured this, if the */ -/* above 3 are false, then RQ must be true, so we never store */ -/* this */ -/* RQ happens when we have backward direction in row storage */ -/* RQ = (.NOT.DIRF).AND.(.NOT.COLV) */ - if (qr) { /* Break V apart into 6 components */ @@ -647,7 +733,7 @@ f"> */ /* T_{1,2} = T_{1,2}*V_{2,2} */ i__2 = *k - l; - strmm_("Right", "Lower", "No transpose", "Unit", &l, &i__2, &c_b13, & + strmm_("Right", "Lower", "No transpose", "Unit", &l, &i__2, &c_b18, & v[l + 1 + (l + 1) * v_dim1], ldv, &t[(l + 1) * t_dim1 + 1], ldt); @@ -656,8 +742,8 @@ f"> */ i__2 = *k - l; i__3 = *n - *k; - sgemm_("Transpose", "No transpose", &l, &i__2, &i__3, &c_b13, &v[*k + - 1 + v_dim1], ldv, &v[*k + 1 + (l + 1) * v_dim1], ldv, &c_b13, + sgemm_("Transpose", "No transpose", &l, &i__2, &i__3, &c_b18, &v[*k + + 1 + v_dim1], ldv, &v[*k + 1 + (l + 1) * v_dim1], ldv, &c_b18, &t[(l + 1) * t_dim1 + 1], ldt); /* At this point, we have that T_{1,2} = V_1'*V_2 */ @@ -667,14 +753,14 @@ f"> */ /* T_{1,2} = -T_{1,1}*T_{1,2} */ i__2 = *k - l; - strmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__2, &c_b22, + strmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__2, &c_b27, &t[t_offset], ldt, &t[(l + 1) * t_dim1 + 1], ldt); /* T_{1,2} = T_{1,2}*T_{2,2} */ i__2 = *k - l; strmm_("Right", "Upper", "No transpose", "Non-unit", &l, &i__2, & - c_b13, &t[l + 1 + (l + 1) * t_dim1], ldt, &t[(l + 1) * t_dim1 + c_b18, &t[l + 1 + (l + 1) * t_dim1], ldt, &t[(l + 1) * t_dim1 + 1], ldt); } else if (lq) { @@ -710,8 +796,8 @@ f"> */ /* Then, consider the product: */ -/* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) */ -/* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 */ +/* (I - V_1'*T_{1,1}'*V_1)*(I - V_2'*T_{2,2}'*V_2) */ +/* = I - V_1'*T_{1,1}'*V_1 - V_2'*T_{2,2}'*V_2 + V_1'*T_{1,1}'*V_1*V_2'*T_{2,2}'*V_2 */ /* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} */ @@ -722,7 +808,7 @@ f"> */ /* |---| */ /* So, our product is equivalent to the matrix product */ -/* I - V'*T*V */ +/* I - V'*T'*V */ /* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ /* to compute T_{1,2} */ @@ -748,7 +834,7 @@ f"> */ /* T_{1,2} = T_{1,2}*V_{2,2}' */ i__2 = *k - l; - strmm_("Right", "Upper", "Transpose", "Unit", &l, &i__2, &c_b13, &v[l + strmm_("Right", "Upper", "Transpose", "Unit", &l, &i__2, &c_b18, &v[l + 1 + (l + 1) * v_dim1], ldv, &t[(l + 1) * t_dim1 + 1], ldt); /* T_{1,2} = V_{1,3}*V_{2,3}' + T_{1,2} */ @@ -756,9 +842,9 @@ f"> */ i__2 = *k - l; i__3 = *n - *k; - sgemm_("No transpose", "Transpose", &l, &i__2, &i__3, &c_b13, &v[(*k + sgemm_("No transpose", "Transpose", &l, &i__2, &i__3, &c_b18, &v[(*k + 1) * v_dim1 + 1], ldv, &v[l + 1 + (*k + 1) * v_dim1], ldv, & - c_b13, &t[(l + 1) * t_dim1 + 1], ldt); + c_b18, &t[(l + 1) * t_dim1 + 1], ldt); /* At this point, we have that T_{1,2} = V_1*V_2' */ /* All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} */ @@ -767,15 +853,118 @@ f"> */ /* T_{1,2} = -T_{1,1}*T_{1,2} */ i__2 = *k - l; - strmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__2, &c_b22, + strmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__2, &c_b27, &t[t_offset], ldt, &t[(l + 1) * t_dim1 + 1], ldt); /* T_{1,2} = T_{1,2}*T_{2,2} */ i__2 = *k - l; strmm_("Right", "Upper", "No transpose", "Non-unit", &l, &i__2, & - c_b13, &t[l + 1 + (l + 1) * t_dim1], ldt, &t[(l + 1) * t_dim1 + c_b18, &t[l + 1 + (l + 1) * t_dim1], ldt, &t[(l + 1) * t_dim1 + 1], ldt); + } else if (lqt) { + +/* Break V apart into 6 components */ + +/* V = |----------------------| */ +/* |V_{1,1} V_{1,2} V{1,3}| */ +/* |0 V_{2,2} V{2,3}| */ +/* |----------------------| */ + +/* V_{1,1}\in\R^{l,l} unit upper triangular */ +/* V_{1,2}\in\R^{l,k-l} rectangular */ +/* V_{1,3}\in\R^{l,n-k} rectangular */ + +/* V_{2,2}\in\R^{k-l,k-l} unit upper triangular */ +/* V_{2,3}\in\R^{k-l,n-k} rectangular */ + +/* Where l = floor(k/2) */ + +/* We will construct the T matrix */ +/* T = |---------------| */ +/* |T_{1,1} 0 | */ +/* |T_{2,1} T_{2,2}| */ +/* |---------------| */ + +/* T is the triangular factor obtained from block reflectors. */ +/* To motivate the structure, assume we have already computed T_{1,1} */ +/* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 */ + +/* T_{1,1}\in\R^{l, l} lower triangular */ +/* T_{2,2}\in\R^{k-l, k-l} lower triangular */ +/* T_{2,1}\in\R^{k-l, l} rectangular */ + +/* Then, consider the product: */ + +/* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) */ +/* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 */ + +/* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} */ + +/* Then, we can define the matrix V as */ +/* V = |---| */ +/* |V_1| */ +/* |V_2| */ +/* |---| */ + +/* So, our product is equivalent to the matrix product */ +/* I - V'*T*V */ +/* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ +/* to compute T_{2,1} */ + +/* Compute T_{1,1} recursively */ + + slarft_(direct, storev, n, &l, &v[v_offset], ldv, &tau[1], &t[ + t_offset], ldt); + +/* Compute T_{2,2} recursively */ + + i__2 = *n - l; + i__3 = *k - l; + slarft_(direct, storev, &i__2, &i__3, &v[l + 1 + (l + 1) * v_dim1], + ldv, &tau[l + 1], &t[l + 1 + (l + 1) * t_dim1], ldt); + +/* Compute T_{2,1} */ +/* T_{2,1} = V_{1,2}' */ + + i__2 = *k - l; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = l; + for (j = 1; j <= i__3; ++j) { + t[l + i__ + j * t_dim1] = v[j + (l + i__) * v_dim1]; + } + } + +/* T_{2,1} = V_{2,2}*T_{2,1} */ + + i__2 = *k - l; + strmm_("Left", "Upper", "No Transpose", "Unit", &i__2, &l, &c_b18, &v[ + l + 1 + (l + 1) * v_dim1], ldv, &t[l + 1 + t_dim1], ldt); + +/* T_{2,1} = V_{2,3}*V_{1,3}' + T_{2,1} */ +/* Note: We assume K <= N, and GEMM will do nothing if N=K */ + + i__2 = *k - l; + i__3 = *n - *k; + sgemm_("No Transpose", "Transpose", &i__2, &l, &i__3, &c_b18, &v[l + + 1 + (*k + 1) * v_dim1], ldv, &v[(*k + 1) * v_dim1 + 1], ldv, & + c_b18, &t[l + 1 + t_dim1], ldt); + +/* At this point, we have that T_{2,1} = V_2*V_1' */ +/* All that is left is to pre and post multiply by -T_{2,2} and T_{1,1} */ +/* respectively. */ + +/* T_{2,1} = -T_{2,2}*T_{2,1} */ + + i__2 = *k - l; + strmm_("Left", "Lower", "No Transpose", "Non-unit", &i__2, &l, &c_b27, + &t[l + 1 + (l + 1) * t_dim1], ldt, &t[l + 1 + t_dim1], ldt); + +/* T_{2,1} = T_{2,1}*T_{1,1} */ + + i__2 = *k - l; + strmm_("Right", "Lower", "No Transpose", "Non-unit", &i__2, &l, & + c_b18, &t[t_offset], ldt, &t[l + 1 + t_dim1], ldt); } else if (ql) { /* Break V apart into 6 components */ @@ -853,7 +1042,7 @@ f"> */ /* T_{2,1} = T_{2,1}*V_{2,1} */ i__2 = *k - l; - strmm_("Right", "Upper", "No transpose", "Unit", &l, &i__2, &c_b13, & + strmm_("Right", "Upper", "No transpose", "Unit", &l, &i__2, &c_b18, & v[*n - *k + 1 + v_dim1], ldv, &t[*k - l + 1 + t_dim1], ldt); /* T_{2,1} = V_{2,2}'*V_{2,1} + T_{2,1} */ @@ -861,8 +1050,8 @@ f"> */ i__2 = *k - l; i__3 = *n - *k; - sgemm_("Transpose", "No transpose", &l, &i__2, &i__3, &c_b13, &v[(*k - - l + 1) * v_dim1 + 1], ldv, &v[v_offset], ldv, &c_b13, &t[*k + sgemm_("Transpose", "No transpose", &l, &i__2, &i__3, &c_b18, &v[(*k + - l + 1) * v_dim1 + 1], ldv, &v[v_offset], ldv, &c_b18, &t[*k - l + 1 + t_dim1], ldt); /* At this point, we have that T_{2,1} = V_2'*V_1 */ @@ -872,7 +1061,7 @@ f"> */ /* T_{2,1} = -T_{2,2}*T_{2,1} */ i__2 = *k - l; - strmm_("Left", "Lower", "No transpose", "Non-unit", &l, &i__2, &c_b22, + strmm_("Left", "Lower", "No transpose", "Non-unit", &l, &i__2, &c_b27, &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[*k - l + 1 + t_dim1], ldt); @@ -880,11 +1069,8 @@ f"> */ i__2 = *k - l; strmm_("Right", "Lower", "No transpose", "Non-unit", &l, &i__2, & - c_b13, &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); - } else { - -/* Else means RQ case */ - + c_b18, &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); + } else if (rq) { /* Break V apart into 6 components */ /* V = |-----------------------| */ @@ -917,8 +1103,8 @@ f"> */ /* Then, consider the product: */ -/* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) */ -/* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 */ +/* (I - V_2'*T_{2,2}'*V_2)*(I - V_1'*T_{1,1}'*V_1) */ +/* = I - V_2'*T_{2,2}'*V_2 - V_1'*T_{1,1}'*V_1 + V_2'*T_{2,2}'*V_2*V_1'*T_{1,1}'*V_1 */ /* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} */ @@ -929,7 +1115,7 @@ f"> */ /* |---| */ /* So, our product is equivalent to the matrix product */ -/* I - V'TV */ +/* I - V'*T'*V */ /* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ /* to compute T_{2,1} */ @@ -955,7 +1141,7 @@ f"> */ /* T_{2,1} = T_{2,1}*V_{1,2}' */ i__2 = *k - l; - strmm_("Right", "Lower", "Transpose", "Unit", &l, &i__2, &c_b13, &v[(* + strmm_("Right", "Lower", "Transpose", "Unit", &l, &i__2, &c_b18, &v[(* n - *k + 1) * v_dim1 + 1], ldv, &t[*k - l + 1 + t_dim1], ldt); /* T_{2,1} = V_{2,1}*V_{1,1}' + T_{2,1} */ @@ -963,8 +1149,8 @@ f"> */ i__2 = *k - l; i__3 = *n - *k; - sgemm_("No transpose", "Transpose", &l, &i__2, &i__3, &c_b13, &v[*k - - l + 1 + v_dim1], ldv, &v[v_offset], ldv, &c_b13, &t[*k - l + + sgemm_("No transpose", "Transpose", &l, &i__2, &i__3, &c_b18, &v[*k - + l + 1 + v_dim1], ldv, &v[v_offset], ldv, &c_b18, &t[*k - l + 1 + t_dim1], ldt); /* At this point, we have that T_{2,1} = V_2*V_1' */ @@ -974,15 +1160,119 @@ f"> */ /* T_{2,1} = -T_{2,2}*T_{2,1} */ i__2 = *k - l; - strmm_("Left", "Lower", "No tranpose", "Non-unit", &l, &i__2, &c_b22, - &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[*k - l + 1 + + strmm_("Left", "Lower", "No transpose", "Non-unit", &l, &i__2, &c_b27, + &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[*k - l + 1 + t_dim1], ldt); /* T_{2,1} = T_{2,1}*T_{1,1} */ i__2 = *k - l; - strmm_("Right", "Lower", "No tranpose", "Non-unit", &l, &i__2, &c_b13, - &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); + strmm_("Right", "Lower", "No transpose", "Non-unit", &l, &i__2, & + c_b18, &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); + } else if (rqt) { +/* Break V apart into 6 components */ + +/* V = |-----------------------| */ +/* |V_{1,1} V_{1,2} 0 | */ +/* |V_{2,1} V_{2,2} V_{2,3}| */ +/* |-----------------------| */ + +/* V_{1,1}\in\R^{k-l,n-k} rectangular */ +/* V_{1,2}\in\R^{k-l,k-l} unit lower triangular */ + +/* V_{2,1}\in\R^{l,n-k} rectangular */ +/* V_{2,2}\in\R^{l,k-l} rectangular */ +/* V_{2,3}\in\R^{l,l} unit lower triangular */ + +/* We will construct the T matrix */ +/* T = |---------------| */ +/* |T_{1,1} T_{1,2}| */ +/* | 0 T_{2,2}| */ +/* |---------------| */ + +/* T is the triangular factor obtained from block reflectors. */ +/* To motivate the structure, assume we have already computed T_{1,1} */ +/* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 */ + +/* T_{1,1}\in\R^{k-l, k-l} non-unit upper triangular */ +/* T_{2,2}\in\R^{l, l} non-unit upper triangular */ +/* T_{1,2}\in\R^{k-l, l} rectangular */ + +/* Where l = floor(k/2) */ + +/* Then, consider the product: */ + +/* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) */ +/* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 */ + +/* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} */ + +/* Then, we can define the matrix V as */ +/* V = |---| */ +/* |V_1| */ +/* |V_2| */ +/* |---| */ + +/* So, our product is equivalent to the matrix product */ +/* I - V'*T*V */ +/* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ +/* to compute T_{1,2} */ + +/* Compute T_{1,1} recursively */ + + i__2 = *n - l; + i__3 = *k - l; + slarft_(direct, storev, &i__2, &i__3, &v[v_offset], ldv, &tau[1], &t[ + t_offset], ldt); + +/* Compute T_{2,2} recursively */ + + slarft_(direct, storev, n, &l, &v[*k - l + 1 + v_dim1], ldv, &tau[*k + - l + 1], &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt); + +/* Compute T_{1,2} */ +/* T_{1,2} = V_{2,2}' */ + + i__2 = *k - l; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = l; + for (j = 1; j <= i__3; ++j) { + t[i__ + (*k - l + j) * t_dim1] = v[*k - l + j + (*n - *k + + i__) * v_dim1]; + } + } + +/* T_{1,2} = V_{1,2}T_{1,2} */ + + i__2 = *k - l; + strmm_("Left", "Lower", "No Transpose", "Unit", &i__2, &l, &c_b18, &v[ + (*n - *k + 1) * v_dim1 + 1], ldv, &t[(*k - l + 1) * t_dim1 + + 1], ldt); + +/* T_{1,2} = V_{1,1}V_{2,1}' + T_{1,2} */ + + i__2 = *k - l; + i__3 = *n - *k; + sgemm_("No Transpose", "Transpose", &i__2, &l, &i__3, &c_b18, &v[ + v_offset], ldv, &v[*k - l + 1 + v_dim1], ldv, &c_b18, &t[(*k + - l + 1) * t_dim1 + 1], ldt); + +/* At this point, we have that T_{1,2} = V_1*V_2' */ +/* All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} */ +/* respectively. */ + +/* T_{1,2} = -T_{1,1}*T_{1,2} */ + + i__2 = *k - l; + strmm_("Left", "Upper", "No Transpose", "Non-Unit", &i__2, &l, &c_b27, + &t[t_offset], ldt, &t[(*k - l + 1) * t_dim1 + 1], ldt); + +/* T_{1,2} = T_{1,2}*T_{2,2} */ + + i__2 = *k - l; + strmm_("Right", "Upper", "No Transpose", "Non-Unit", &i__2, &l, & + c_b18, &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[(*k - + l + 1) * t_dim1 + 1], ldt); } return; } /* slarft_ */ diff --git a/lapack-netlib/SRC/slarft.f b/lapack-netlib/SRC/slarft.f index 3e0eac751e..a994a92498 100644 --- a/lapack-netlib/SRC/slarft.f +++ b/lapack-netlib/SRC/slarft.f @@ -48,6 +48,9 @@ *> H(i) is stored in the i-th row of the array V, and *> *> H = I - V**T * T * V +*> +*> If DIRECT or STOREV = 'T', see Further Details for the shape of T +*> *> \endverbatim * * Arguments: @@ -60,6 +63,8 @@ *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) +*> = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) +*> but we return the T matrix that is already (conjugate) transposed *> \endverbatim *> *> \param[in] STOREV @@ -67,8 +72,10 @@ *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise +*> = 'C': column-wise +*> = 'R': row-wise +*> = 'T': (With DIRECT='F') Row-wise, but we return the T +*> matrix that is already (conjugate) transposed. *> \endverbatim *> *> \param[in] N @@ -125,7 +132,7 @@ * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley -*> \author Johnathan Rhyne, Univ. of Colorado Denver (original author, 2024) +*> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \ingroup larft @@ -139,7 +146,7 @@ *> the H(i) is best illustrated by the following example with n = 5 and *> k = 3. The elements equal to 1 are not stored. *> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and (STOREV = 'R' or STOREV = 'T'): *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) @@ -147,13 +154,36 @@ *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +*> DIRECT = 'B' and STOREV = 'C': (DIRECT = 'B' or DIRECT = 'T') and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) +*> +*> In addition, the shape of T is determined by these same flags as +*> in the below table. +*> 'U' denotes upper triangular +*> 'L' denotes lower triangular +*> 'X' denotes no current implementation +*> We also provide the logical variable that represents the case +*> in the code if it is implemented +*> +*> |-----------------------------------------------------------| +*> | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | +*> |--------------+--------------+--------------+--------------| +*> | STOREV = 'C' | U (QR) | L (QL) | X | +*> | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | +*> | STOREV = 'T' | L (LQT) | X | X | +*> |-----------------------------------------------------------| +*> +*> Finally, the relationship between the (conjugate) transposed T matrices +*> are as follows: (Note that T_{FC} denotes the T associated with calling +*> this routine with DIRECT = 'F' and STOREV = 'C') +*> +*> T_{TR} = (T_{BR})**H +*> T_{FT} = (T_{FR})**H *> \endverbatim *> * ===================================================================== @@ -177,24 +207,26 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * * .. Parameters .. * - REAL ONE, NEG_ONE, ZERO - PARAMETER(ONE=1.0E+0, ZERO = 0.0E+0, NEG_ONE=-1.0E+0) + REAL ONE, NEG_ONE + PARAMETER(ONE=1.0E+0, NEG_ONE=-1.0E+0) * * .. Local Scalars .. * - INTEGER I,J,L,NX - LOGICAL QR,LQ,QL,DIRF,COLV + INTEGER I,J,L,NX,INFO + LOGICAL QR, LQ, QL, RQ, LQT, RQT, + $ DIRF, DIRB, DIRT, + $ STOREC, STORER, STORET * * .. External Subroutines .. * - EXTERNAL STRMM,SGEMM,SLACPY + EXTERNAL SLARFT_LVL2, STRMM, SGEMM, SLACPY, XERBLA * * .. External Functions.. * LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV -* +* * The general scheme used is inspired by the approach inside DGEQRT3 * which was (at the time of writing this code): * Based on the algorithm of Elmroth and Gustavson, @@ -202,12 +234,90 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * .. * .. Executable Statements .. * +* Convert our character flags to logical flags for later +* + DIRF = LSAME(DIRECT,'F') + DIRB = LSAME(DIRECT,'B') + DIRT = LSAME(DIRECT,'T') + STOREC = LSAME(STOREV,'C') + STORER = LSAME(STOREV,'R') + STORET = LSAME(STOREV,'T') +* +* Error handling for our character flags +* + INFO = 0 + IF( .NOT.(DIRF.OR.DIRB.OR.DIRT) ) THEN +* +* DIRECT holds an illegal value +* + INFO = 1 + ELSE IF( .NOT.(STOREC.OR.STORER.OR.STORET) ) THEN +* +* STOREV holds an illegal value +* + INFO = 2 + ELSE IF( DIRB.AND.STORET ) THEN +* +* This case is purposefully not implemented, but any other value for +* STOREV is valid, so we report STOREV as the invalid input +* + INFO = 2 + ELSE IF( DIRT.AND.STOREC ) THEN +* +* This case is purposefully not implemented, but any other value for +* DIRECT is valid, so we report DIRECT as the invalid input +* + INFO = 1 + ELSE IF( DIRT.AND.STORET ) THEN +* +* This case is purposefully not implemented, and is ambiguous what +* the user wants to do, so we arbitrarily say DIRECT is the incorrect +* character flag. +* + INFO = 1 + END IF + + IF( INFO.NE.0 ) THEN + CALL XERBLA('SLARFT', INFO) + RETURN + END IF +* * Quick return if possible * IF(N.EQ.0.OR.K.EQ.0) THEN RETURN END IF * +* Now we determine what factorization our flags are associated with +* +* QR happens when we have forward direction in column storage +* + QR = DIRF.AND.STOREC +* +* LQT happens when we have forward direction in row storage and want to compute the transpose of +* the T we would normally compute +* + LQT = DIRF.AND.STORET +* +* LQ happens when we have forward direction in row storage and want to compute the T we would +* normally compute +* + LQ = DIRF.AND.STORER +* +* QL happens when we have backward direction in column storage +* + QL = DIRB.AND.STOREC +* +* RQT happens when we have backward direction in row storage and want to compute the transpose +* of the T we would normally compute +* + RQT = DIRT.AND.STORER +* +* RQ happens when we have backward direction in row storage and want to compute the T that we +* would normally compute +* + RQ = DIRB.AND.STORER +* * Base case * IF(N.EQ.1.OR.K.EQ.1) THEN @@ -215,44 +325,20 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, RETURN END IF * -* Determine when to cross over into the level 2 based implementation +* Determine crossover point from level 2 to level 3 BLAS implementation * NX = ILAENV(3, "SLARFT", DIRECT // STOREV, N, K, -1, -1) IF(K.LT.NX) THEN +* +* Finish this component with a level 2 BLAS implementation +* CALL SLARFT_LVL2(DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT) RETURN END IF * -* Beginning of executable statements +* Beginning of executable statements for the recursive case * L = K / 2 -* -* Determine what kind of Q we need to compute -* We assume that if the user doesn't provide 'F' for DIRECT, -* then they meant to provide 'B' and if they don't provide -* 'C' for STOREV, then they meant to provide 'R' -* - DIRF = LSAME(DIRECT,'F') - COLV = LSAME(STOREV,'C') -* -* QR happens when we have forward direction in column storage -* - QR = DIRF.AND.COLV -* -* LQ happens when we have forward direction in row storage -* - LQ = DIRF.AND.(.NOT.COLV) -* -* QL happens when we have backward direction in column storage -* - QL = (.NOT.DIRF).AND.COLV -* -* The last case is RQ. Due to how we structured this, if the -* above 3 are false, then RQ must be true, so we never store -* this -* RQ happens when we have backward direction in row storage -* RQ = (.NOT.DIRF).AND.(.NOT.COLV) -* IF(QR) THEN * * Break V apart into 6 components @@ -266,17 +352,17 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * V_{1,1}\in\R^{l,l} unit lower triangular * V_{2,1}\in\R^{k-l,l} rectangular * V_{3,1}\in\R^{n-k,l} rectangular -* +* * V_{2,2}\in\R^{k-l,k-l} unit lower triangular * V_{3,2}\in\R^{n-k,k-l} rectangular * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} T_{1,2}| * |0 T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -287,17 +373,17 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * Where l = floor(k/2) * * Then, consider the product: -* +* * (I - V_1*T_{1,1}*V_1')*(I - V_2*T_{2,2}*V_2') * = I - V_1*T_{1,1}*V_1' - V_2*T_{2,2}*V_2' + V_1*T_{1,1}*V_1'*V_2*T_{2,2}*V_2' -* +* * Define T_{1,2} = -T_{1,1}*V_1'*V_2*T_{2,2} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |-------| * |V_1 V_2| * |-------| -* +* * So, our product is equivalent to the matrix product * I - V*T*V' * This means, we can compute T_{1,1} and T_{2,2}, then use this information @@ -309,30 +395,29 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * * Compute T_{2,2} recursively * - CALL SLARFT(DIRECT, STOREV, N-L, K-L, V(L+1, L+1), LDV, - $ TAU(L+1), T(L+1, L+1), LDT) + CALL SLARFT(DIRECT, STOREV, N-L, K-L, V(L+1,L+1), LDV, + $ TAU(L+1), T(L+1,L+1), LDT) * -* Compute T_{1,2} +* Compute T_{1,2} * T_{1,2} = V_{2,1}' * DO J = 1, L DO I = 1, K-L - T(J, L+I) = V(L+I, J) + T(J,L+I) = V(L+I,J) END DO END DO * * T_{1,2} = T_{1,2}*V_{2,2} * CALL STRMM('Right', 'Lower', 'No transpose', 'Unit', L, - $ K-L, ONE, V(L+1, L+1), LDV, T(1, L+1), LDT) + $ K-L, ONE, V(L+1, L+1), LDV, T(1, L+1), LDT) * * T_{1,2} = V_{3,1}'*V_{3,2} + T_{1,2} * Note: We assume K <= N, and GEMM will do nothing if N=K * - CALL SGEMM('Transpose', 'No transpose', L, K-L, N-K, ONE, - $ V(K+1, 1), LDV, V(K+1, L+1), LDV, ONE, - $ T(1, L+1), LDT) + CALL SGEMM('Transpose', 'No transpose', L, K-L, N-K, ONE, + $ V(K+1, 1), LDV, V(K+1,L+1), LDV, ONE, T(1, L+1), LDT) * * At this point, we have that T_{1,2} = V_1'*V_2 * All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} @@ -341,12 +426,12 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{1,2} = -T_{1,1}*T_{1,2} * CALL STRMM('Left', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT) + $ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT) * * T_{1,2} = T_{1,2}*T_{2,2} * - CALL STRMM('Right', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, ONE, T(L+1, L+1), LDT, T(1, L+1), LDT) + CALL STRMM('Right', 'Upper', 'No transpose', 'Non-unit', L, + $ K-L, ONE, T(L+1,L+1), LDT, T(1, L+1), LDT) ELSE IF(LQ) THEN * @@ -360,19 +445,19 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * V_{1,1}\in\R^{l,l} unit upper triangular * V_{1,2}\in\R^{l,k-l} rectangular * V_{1,3}\in\R^{l,n-k} rectangular -* +* * V_{2,2}\in\R^{k-l,k-l} unit upper triangular * V_{2,3}\in\R^{k-l,n-k} rectangular * * Where l = floor(k/2) * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} T_{1,2}| * |0 T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -381,20 +466,20 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{1,2}\in\R^{l, k-l} rectangular * * Then, consider the product: -* -* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) -* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 -* +* +* (I - V_1'*T_{1,1}'*V_1)*(I - V_2'*T_{2,2}'*V_2) +* = I - V_1'*T_{1,1}'*V_1 - V_2'*T_{2,2}'*V_2 + V_1'*T_{1,1}'*V_1*V_2'*T_{2,2}'*V_2 +* * Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |---| * |V_1| * |V_2| * |---| -* +* * So, our product is equivalent to the matrix product -* I - V'*T*V +* I - V'*T'*V * This means, we can compute T_{1,1} and T_{2,2}, then use this information * to compute T_{1,2} * @@ -404,27 +489,26 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * * Compute T_{2,2} recursively * - CALL SLARFT(DIRECT, STOREV, N-L, K-L, V(L+1, L+1), LDV, - $ TAU(L+1), T(L+1, L+1), LDT) + CALL SLARFT(DIRECT, STOREV, N-L, K-L, V(L+1,L+1), LDV, + $ TAU(L+1), T(L+1,L+1), LDT) * * Compute T_{1,2} * T_{1,2} = V_{1,2} * - CALL SLACPY('All', L, K-L, V(1, L+1), LDV, T(1, L+1), LDT) + CALL SLACPY('All', L, K - L, V(1,L+1), LDV, T(1, L+1), LDT) * * T_{1,2} = T_{1,2}*V_{2,2}' * CALL STRMM('Right', 'Upper', 'Transpose', 'Unit', L, K-L, - $ ONE, V(L+1, L+1), LDV, T(1, L+1), LDT) + $ ONE, V(L+1, L+1), LDV, T(1, L+1), LDT) * * T_{1,2} = V_{1,3}*V_{2,3}' + T_{1,2} * Note: We assume K <= N, and GEMM will do nothing if N=K * CALL SGEMM('No transpose', 'Transpose', L, K-L, N-K, ONE, - $ V(1, K+1), LDV, V(L+1, K+1), LDV, ONE, - $ T(1, L+1), LDT) + $ V(1, K+1), LDV, V(L+1, K+1), LDV, ONE, T(1, L+1), LDT) * * At this point, we have that T_{1,2} = V_1*V_2' * All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} @@ -433,13 +517,106 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{1,2} = -T_{1,1}*T_{1,2} * CALL STRMM('Left', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT) + $ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT) * * T_{1,2} = T_{1,2}*T_{2,2} * CALL STRMM('Right', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, ONE, T(L+1, L+1), LDT, T(1, L+1), LDT) + $ K-L, ONE, T(L+1,L+1), LDT, T(1, L+1), LDT) + ELSE IF(LQT) THEN +* +* Break V apart into 6 components +* +* V = |----------------------| +* |V_{1,1} V_{1,2} V{1,3}| +* |0 V_{2,2} V{2,3}| +* |----------------------| +* +* V_{1,1}\in\R^{l,l} unit upper triangular +* V_{1,2}\in\R^{l,k-l} rectangular +* V_{1,3}\in\R^{l,n-k} rectangular +* +* V_{2,2}\in\R^{k-l,k-l} unit upper triangular +* V_{2,3}\in\R^{k-l,n-k} rectangular +* +* Where l = floor(k/2) +* +* We will construct the T matrix +* T = |---------------| +* |T_{1,1} 0 | +* |T_{2,1} T_{2,2}| +* |---------------| +* +* T is the triangular factor obtained from block reflectors. +* To motivate the structure, assume we have already computed T_{1,1} +* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 +* +* T_{1,1}\in\R^{l, l} lower triangular +* T_{2,2}\in\R^{k-l, k-l} lower triangular +* T_{2,1}\in\R^{k-l, l} rectangular +* +* Then, consider the product: +* +* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) +* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 +* +* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} +* +* Then, we can define the matrix V as +* V = |---| +* |V_1| +* |V_2| +* |---| +* +* So, our product is equivalent to the matrix product +* I - V'*T*V +* This means, we can compute T_{1,1} and T_{2,2}, then use this information +* to compute T_{2,1} +* +* Compute T_{1,1} recursively +* + CALL SLARFT(DIRECT, STOREV, N, L, V, LDV, TAU, T, LDT) +* +* Compute T_{2,2} recursively +* + CALL SLARFT(DIRECT, STOREV, N-L, K-L, V(L+1,L+1), LDV, + $ TAU(L+1), T(L+1,L+1), LDT) + +* +* Compute T_{2,1} +* T_{2,1} = V_{1,2}' +* + DO I = 1, K-L + DO J = 1, L + T(L+I,J) = V(J,L+I) + END DO + END DO +* +* T_{2,1} = V_{2,2}*T_{2,1} +* + CALL STRMM('Left', 'Upper', 'No Transpose', 'Unit', K-L, L, + $ ONE, V(L+1,L+1), LDV, T(L+1,1), LDT) +* +* T_{2,1} = V_{2,3}*V_{1,3}' + T_{2,1} +* Note: We assume K <= N, and GEMM will do nothing if N=K +* + CALL SGEMM('No Transpose', 'Transpose', K-L, L, N-K, ONE, + $ V(L+1,K+1), LDV, V(1, K+1), LDV, ONE, T(L+1,1), LDT) +* +* At this point, we have that T_{2,1} = V_2*V_1' +* All that is left is to pre and post multiply by -T_{2,2} and T_{1,1} +* respectively. +* +* T_{2,1} = -T_{2,2}*T_{2,1} +* + CALL STRMM('Left', 'Lower', 'No Transpose', 'Non-unit', + $ K-L, L, NEG_ONE, T(L+1,L+1), LDT, T(L+1,1), LDT) +* +* T_{2,1} = T_{2,1}*T_{1,1} +* + CALL STRMM('Right', 'Lower', 'No Transpose', 'Non-unit', + $ K-L, L, ONE, T, LDT, T(L+1,1), LDT) ELSE IF(QL) THEN * * Break V apart into 6 components @@ -452,18 +629,18 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * * V_{1,1}\in\R^{n-k,k-l} rectangular * V_{2,1}\in\R^{k-l,k-l} unit upper triangular -* +* * V_{1,2}\in\R^{n-k,l} rectangular * V_{2,2}\in\R^{k-l,l} rectangular * V_{3,2}\in\R^{l,l} unit upper triangular * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} 0 | * |T_{2,1} T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -474,17 +651,17 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * Where l = floor(k/2) * * Then, consider the product: -* +* * (I - V_2*T_{2,2}*V_2')*(I - V_1*T_{1,1}*V_1') * = I - V_2*T_{2,2}*V_2' - V_1*T_{1,1}*V_1' + V_2*T_{2,2}*V_2'*V_1*T_{1,1}*V_1' -* +* * Define T_{2,1} = -T_{2,2}*V_2'*V_1*T_{1,1} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |-------| * |V_1 V_2| * |-------| -* +* * So, our product is equivalent to the matrix product * I - V*T*V' * This means, we can compute T_{1,1} and T_{2,2}, then use this information @@ -492,34 +669,34 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * * Compute T_{1,1} recursively * - CALL SLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, LDT) + CALL SLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, + $ LDT) * * Compute T_{2,2} recursively * CALL SLARFT(DIRECT, STOREV, N, L, V(1, K-L+1), LDV, - $ TAU(K-L+1), T(K-L+1, K-L+1), LDT) + $ TAU(K-L+1), T(K-L+1,K-L+1), LDT) * * Compute T_{2,1} * T_{2,1} = V_{2,2}' * DO J = 1, K-L DO I = 1, L - T(K-L+I, J) = V(N-K+J, K-L+I) + T(K-L+I,J) = V(N-K+J, K-L+I) END DO END DO * * T_{2,1} = T_{2,1}*V_{2,1} * CALL STRMM('Right', 'Upper', 'No transpose', 'Unit', L, - $ K-L, ONE, V(N-K+1, 1), LDV, T(K-L+1, 1), LDT) + $ K-L, ONE, V(N-K+1,1), LDV, T(K-L+1,1), LDT) * * T_{2,1} = V_{2,2}'*V_{2,1} + T_{2,1} * Note: We assume K <= N, and GEMM will do nothing if N=K * CALL SGEMM('Transpose', 'No transpose', L, K-L, N-K, ONE, - $ V(1, K-L+1), LDV, V, LDV, ONE, T(K-L+1, 1), - $ LDT) + $ V(1,K-L+1), LDV, V, LDV, ONE, T(K-L+1,1), LDT) * * At this point, we have that T_{2,1} = V_2'*V_1 * All that is left is to pre and post multiply by -T_{2,2} and T_{1,1} @@ -528,17 +705,13 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{2,1} = -T_{2,2}*T_{2,1} * CALL STRMM('Left', 'Lower', 'No transpose', 'Non-unit', L, - $ K-L, NEG_ONE, T(K-L+1, K-L+1), LDT, - $ T(K-L+1, 1), LDT) + $ K-L, NEG_ONE, T(K-L+1,K-L+1), LDT, T(K-L+1,1), LDT) * * T_{2,1} = T_{2,1}*T_{1,1} * CALL STRMM('Right', 'Lower', 'No transpose', 'Non-unit', L, - $ K-L, ONE, T, LDT, T(K-L+1, 1), LDT) - ELSE -* -* Else means RQ case -* + $ K-L, ONE, T, LDT, T(K-L+1,1), LDT) + ELSE IF(RQ) THEN * Break V apart into 6 components * * V = |-----------------------| @@ -553,13 +726,13 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * V_{2,2}\in\R^{l,k-l} rectangular * V_{2,3}\in\R^{l,l} unit lower triangular * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} 0 | * |T_{2,1} T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -570,51 +743,51 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * Where l = floor(k/2) * * Then, consider the product: -* -* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) -* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 -* +* +* (I - V_2'*T_{2,2}'*V_2)*(I - V_1'*T_{1,1}'*V_1) +* = I - V_2'*T_{2,2}'*V_2 - V_1'*T_{1,1}'*V_1 + V_2'*T_{2,2}'*V_2*V_1'*T_{1,1}'*V_1 +* * Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |---| * |V_1| * |V_2| * |---| -* +* * So, our product is equivalent to the matrix product -* I - V'TV +* I - V'*T'*V * This means, we can compute T_{1,1} and T_{2,2}, then use this information * to compute T_{2,1} * * Compute T_{1,1} recursively * - CALL SLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, LDT) + CALL SLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, + $ LDT) * * Compute T_{2,2} recursively * - CALL SLARFT(DIRECT, STOREV, N, L, V(K-L+1, 1), LDV, - $ TAU(K-L+1), T(K-L+1, K-L+1), LDT) + CALL SLARFT(DIRECT, STOREV, N, L, V(K-L+1,1), LDV, + $ TAU(K-L+1), T(K-L+1,K-L+1), LDT) * * Compute T_{2,1} * T_{2,1} = V_{2,2} * - CALL SLACPY('All', L, K-L, V(K-L+1, N-K+1), LDV, - $ T(K-L+1, 1), LDT) + CALL SLACPY('All', L, K-L, V(K-L+1,N-K+1), LDV, T(K-L+1,1), + $ LDT) * * T_{2,1} = T_{2,1}*V_{1,2}' * CALL STRMM('Right', 'Lower', 'Transpose', 'Unit', L, K-L, - $ ONE, V(1, N-K+1), LDV, T(K-L+1, 1), LDT) + $ ONE, V(1, N-K+1), LDV, T(K-L+1,1), LDT) * -* T_{2,1} = V_{2,1}*V_{1,1}' + T_{2,1} +* T_{2,1} = V_{2,1}*V_{1,1}' + T_{2,1} * Note: We assume K <= N, and GEMM will do nothing if N=K * - CALL SGEMM('No transpose', 'Transpose', L, K-L, N-K, ONE, - $ V(K-L+1, 1), LDV, V, LDV, ONE, T(K-L+1, 1), - $ LDT) + CALL SGEMM('No transpose', 'Transpose', L, K-L, N-K, ONE, + $ V(K-L+1,1), LDV, V, LDV, ONE, T(K-L+1,1), LDT) * * At this point, we have that T_{2,1} = V_2*V_1' @@ -623,14 +796,104 @@ RECURSIVE SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, * * T_{2,1} = -T_{2,2}*T_{2,1} * - CALL STRMM('Left', 'Lower', 'No tranpose', 'Non-unit', L, - $ K-L, NEG_ONE, T(K-L+1, K-L+1), LDT, - $ T(K-L+1, 1), LDT) + CALL STRMM('Left', 'Lower', 'No transpose', 'Non-unit', L, + $ K-L, NEG_ONE, T(K-L+1,K-L+1), LDT, T(K-L+1,1), LDT) * * T_{2,1} = T_{2,1}*T_{1,1} * - CALL STRMM('Right', 'Lower', 'No tranpose', 'Non-unit', L, - $ K-L, ONE, T, LDT, T(K-L+1, 1), LDT) + CALL STRMM('Right', 'Lower', 'No transpose', 'Non-unit', L, + $ K-L, ONE, T, LDT, T(K-L+1,1), LDT) + ELSE IF(RQT) THEN +* Break V apart into 6 components +* +* V = |-----------------------| +* |V_{1,1} V_{1,2} 0 | +* |V_{2,1} V_{2,2} V_{2,3}| +* |-----------------------| +* +* V_{1,1}\in\R^{k-l,n-k} rectangular +* V_{1,2}\in\R^{k-l,k-l} unit lower triangular +* +* V_{2,1}\in\R^{l,n-k} rectangular +* V_{2,2}\in\R^{l,k-l} rectangular +* V_{2,3}\in\R^{l,l} unit lower triangular +* +* We will construct the T matrix +* T = |---------------| +* |T_{1,1} T_{1,2}| +* | 0 T_{2,2}| +* |---------------| +* +* T is the triangular factor obtained from block reflectors. +* To motivate the structure, assume we have already computed T_{1,1} +* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 +* +* T_{1,1}\in\R^{k-l, k-l} non-unit upper triangular +* T_{2,2}\in\R^{l, l} non-unit upper triangular +* T_{1,2}\in\R^{k-l, l} rectangular +* +* Where l = floor(k/2) +* +* Then, consider the product: +* +* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) +* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 +* +* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} +* +* Then, we can define the matrix V as +* V = |---| +* |V_1| +* |V_2| +* |---| +* +* So, our product is equivalent to the matrix product +* I - V'*T*V +* This means, we can compute T_{1,1} and T_{2,2}, then use this information +* to compute T_{1,2} +* +* Compute T_{1,1} recursively +* + CALL SLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, + $ LDT) +* +* Compute T_{2,2} recursively +* + CALL SLARFT(DIRECT, STOREV, N, L, V(K-L+1,1), LDV, + $ TAU(K-L+1), T(K-L+1,K-L+1), LDT) +* +* Compute T_{1,2} +* T_{1,2} = V_{2,2}' +* + DO I = 1, K-L + DO J = 1, L + T(I,K-L+J) = V(K-L+J, N-K+I) + END DO + END DO +* +* T_{1,2} = V_{1,2}T_{1,2} +* + CALL STRMM('Left', 'Lower', 'No Transpose', 'Unit', K-L, L, + $ ONE, V(1,N-K+1), LDV, T(1,K-L+1), LDT) +* +* T_{1,2} = V_{1,1}V_{2,1}' + T_{1,2} +* + CALL SGEMM('No Transpose', 'Transpose', K-L, L, N-K, ONE, V, + $ LDV, V(K-L+1,1), LDV, ONE, T(1, K-L+1), LDT) +* +* At this point, we have that T_{1,2} = V_1*V_2' +* All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} +* respectively. +* +* T_{1,2} = -T_{1,1}*T_{1,2} +* + CALL STRMM('Left', 'Upper', 'No Transpose', 'Non-Unit', + $ K-L, L, NEG_ONE, T, LDT, T(1, K-L+1), LDT) +* +* T_{1,2} = T_{1,2}*T_{2,2} +* + CALL STRMM('Right', 'Upper', 'No Transpose', 'Non-Unit', + $ K-L, L, ONE, T(K-L+1,K-L+1), LDT, T(1, K-L+1), LDT) END IF END SUBROUTINE diff --git a/lapack-netlib/SRC/slarft_lvl2.c b/lapack-netlib/SRC/slarft_lvl2.c index 4e6189793f..28d837bbc1 100644 --- a/lapack-netlib/SRC/slarft_lvl2.c +++ b/lapack-netlib/SRC/slarft_lvl2.c @@ -220,69 +220,18 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -/* -- translated by f2c (version 20000121). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - - /* Table of constant values */ static integer c__1 = 1; -static real c_b6 = 1.f; +static real c_b11 = 1.f; -/* > \brief \b SLARFT_LVL2: Level 2 BLAS version for terminating case of SLARFT. */ +/* > \brief \b SLARFT_LVL2 forms the triangular factor T of a block reflector H = I - vtvH */ /* =========== DOCUMENTATION =========== */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > Download SLARFT_LVL2 + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ - /* Definition: */ /* =========== */ @@ -315,6 +264,9 @@ f"> */ /* > H(i) is stored in the i-th row of the array V, and */ /* > */ /* > H = I - V**T * T * V */ +/* > */ +/* > If DIRECT or STOREV = 'T', see Further Details for the shape of T */ +/* > */ /* > \endverbatim */ /* Arguments: */ @@ -327,6 +279,8 @@ f"> */ /* > multiplied to form the block reflector: */ /* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ /* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) */ +/* > but we return the T matrix that is already (conjugate) transposed */ /* > \endverbatim */ /* > */ /* > \param[in] STOREV */ @@ -334,8 +288,10 @@ f"> */ /* > STOREV is CHARACTER*1 */ /* > Specifies how the vectors which define the elementary */ /* > reflectors are stored (see also Further Details): */ -/* > = 'C': columnwise */ -/* > = 'R': rowwise */ +/* > = 'C': column-wise */ +/* > = 'R': row-wise */ +/* > = 'T': (With DIRECT='F') Row-wise, but we return the T */ +/* > matrix that is already (conjugate) transposed. */ /* > \endverbatim */ /* > */ /* > \param[in] N */ @@ -421,6 +377,29 @@ f"> */ /* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ /* > ( 1 v3 ) */ /* > ( 1 ) */ +/* > */ +/* > In addition, the shape of T is determined by these same flags as */ +/* > in the below table. */ +/* > 'U' denotes upper triangular */ +/* > 'L' denotes lower triangular */ +/* > 'X' denotes no current implementation */ +/* > We also provide the logical variable that represents the case */ +/* > in the code if it is implemented */ +/* > */ +/* > |-----------------------------------------------------------| */ +/* > | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | */ +/* > |--------------+--------------+--------------+--------------| */ +/* > | STOREV = 'C' | U (QR) | L (QL) | X | */ +/* > | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | */ +/* > | STOREV = 'T' | L (LQT) | X | X | */ +/* > |-----------------------------------------------------------| */ +/* > */ +/* > Finally, the relationship between the (conjugate) transposed T matrices */ +/* > are as follows: (Note that T_{FC} denotes the T associated with calling */ +/* > this routine with DIRECT = 'F' and STOREV = 'C') */ +/* > */ +/* > T_{TR} = (T_{BR})**H */ +/* > T_{FT} = (T_{FR})**H */ /* > \endverbatim */ /* > */ /* ===================================================================== */ @@ -432,14 +411,18 @@ f"> */ real r__1; /* Local variables */ - integer i__, j, prevlastv; + integer i__, j; + logical lq, ql, qr, rq; + integer kmi, nmi; + logical lqt, rqt, dirb, dirf; + integer info; + logical dirt; extern logical lsame_(char *, char *); extern /* Subroutine */ void sgemv_(char *, integer *, integer *, real *, - real *, integer *, real *, integer *, real *, real *, integer *); - integer lastv; - extern /* Subroutine */ void strmv_(char *, char *, char *, integer *, - real *, integer *, real *, integer *), - mecago_(); + real *, integer *, real *, integer *, real *, real *, integer *), strmv_(char *, char *, char *, integer *, real *, + integer *, real *, integer *), xerbla_( + char *, integer *, ftnlen); + logical storec, storer, storet; /* -- LAPACK auxiliary routine -- */ @@ -447,10 +430,16 @@ f"> */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* ===================================================================== */ -/* Quick return if possible */ + + + + + + + +/* Convert our character flags to logical flags for later */ /* Parameter adjustments */ v_dim1 = *ldv; @@ -462,171 +451,565 @@ f"> */ t -= t_offset; /* Function Body */ - if (*n == 0) { + dirf = lsame_(direct, "F"); + dirb = lsame_(direct, "B"); + dirt = lsame_(direct, "T"); + storec = lsame_(storev, "C"); + storer = lsame_(storev, "R"); + storet = lsame_(storev, "T"); + +/* Error handling for our character flags */ + + info = 0; + if (! (dirf || dirb || dirt)) { + +/* DIRECT holds an illegal value */ + + info = 1; + } else if (! (storec || storer || storet)) { + +/* STOREV holds an illegal value */ + + info = 2; + } else if (dirb && storet) { + +/* This case is purposefully not implemented, but any other value for */ +/* STOREV is valid, so we report STOREV as the invalid input */ + + info = 2; + } else if (dirt && storec) { + +/* This case is purposefully not implemented, but any other value for */ +/* DIRECT is valid, so we report DIRECT as the invalid input */ + + info = 1; + } else if (dirt && storet) { + +/* This case is purposefully not implemented, and is ambiguous what */ +/* the user wants to do, so we arbitrarily say DIRECT is the incorrect */ +/* character flag. */ + + info = 1; + } + if (info != 0) { + xerbla_("SLARFT_LVL2", &info, (ftnlen)11); + return; + } + +/* Quick return if possible */ + + if (*n == 0 || *k == 0) { + return; + } + +/* Now we determine what factorization our flags are associated with */ + +/* QR happens when we have forward direction in column storage */ + + qr = dirf && storec; + +/* LQT happens when we have forward direction in row storage and want to compute the transpose of */ +/* the T we would normally compute */ + + lqt = dirf && storet; + +/* LQ happens when we have forward direction in row storage and want to compute the T we would */ +/* normally compute */ + + lq = dirf && storer; + +/* QL happens when we have backward direction in column storage */ + + ql = dirb && storec; + +/* RQT happens when we have backward direction in row storage and want to compute the transpose */ +/* of the T we would normally compute */ + + rqt = dirt && storer; + +/* RQ happens when we have backward direction in row storage and want to compute the T that we */ +/* would normally compute */ + + rq = dirb && storer; + if (*n == 1 || *k == 1) { + t[t_dim1 + 1] = tau[1]; return; } + if (qr) { + +/* Break V into 9 components */ + +/* V = |-----------------------| */ +/* |V_{1,1} 0 0 | i-1 */ +/* |V_{2,1} V_{2,2} 0 | 1 */ +/* |V_{3,1} V_{3,2} V_{3,3}| n-i */ +/* |-----------------------| */ +/* i-1 1 k-i */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{3,3} and repeat until we */ +/* reach the end. On each iteration V_{3,3} is not referenced */ + +/* We will construct T one column at a time from left to right */ +/* after initializing T(1,1) = TAU(1) */ + +/* T = |-------------------------| */ +/* | T_{1,1} T_{1,2} T_{1,3} | i-1 */ +/* | 0 T_{2,2} T_{2,3} | 1 */ +/* | 0 0 T_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 k-i */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{1,2} and T_{2,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On */ +/* each iteration, T_{1:3,3} are not referenced. See slarft.f */ +/* for details on how these formulae were constructed. */ + +/* We now get */ + +/* T_{1,2} = -T_{1,1}[V_{1,1}\\V_{2,1}\\V_{3,1}]' */ +/* [0\\V_{2,2}\\V_{3,2}]T_{2,2} */ + +/* T_{1,2} = -T_{1,1}(V_{2,1}' + V_{3,1}'V_{3,2})T_{2,2} */ + +/* This means we will do the following */ + +/* T_{1,2} = -V_{2,1}'T_{2,2} = -\tau_{i}V_{2,1}' */ +/* T_{1,2} = -\tau_{i}V_{3,2}' V_{3,1} + T_{1,2} */ +/* T_{1,2} = T_{1,1}T_{1,2} */ +/* T_{2,2} = \tau{i} */ + + t[t_dim1 + 1] = tau[1]; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T_{1,2} = -V_{2,1}'V_{2,2}T_{2,2} = -\tau_i V_{2,1}' */ +/* We must do this at copy time as otherwise gemv will do nothing */ +/* on the last column when n=k, but we neet to make sure we are */ +/* scaled by this value */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = -v[i__ + j * v_dim1] * tau[i__]; + } + +/* T_{1,2} = -V_{3,1}'V_{3,2}T_{2,2} + T_{1,2} */ +/* = -\tau{i} V_{3,2}'V_{3,1} + T_{1,2} */ + + i__2 = *n - i__; + i__3 = i__ - 1; + r__1 = -tau[i__]; + sgemv_("Transpose", &i__2, &i__3, &r__1, &v[i__ + 1 + v_dim1], + ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, &c_b11, &t[i__ * + t_dim1 + 1], &c__1); + +/* T_{1,2} = T_{1,1}T_{1,2} */ + + i__2 = i__ - 1; + strmv_("Upper", "No Transpose", "Non-unit", &i__2, &t[t_offset], + ldt, &t[i__ * t_dim1 + 1], &c__1); + +/* T_{2,2} = \tau{i} */ + + t[i__ + i__ * t_dim1] = tau[i__]; + } + } else if (lq) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} V_{1,2} V_{1,3} | i-1 */ +/* | 0 V_{2,2} V_{2,3} | 1 */ +/* | 0 0 V_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 n-i */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{3,3} and repeat until we */ +/* reach the end. On each iteration V_{3,3} is not referenced */ + +/* We will construct T one column at a time from left to right */ +/* after initializing T(1,1) = TAU(1) */ + +/* T = |-------------------------| */ +/* | T_{1,1} T_{1,2} T_{1,3} | i-1 */ +/* | 0 T_{2,2} T_{2,3} | 1 */ +/* | 0 0 T_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 k-i */ + +/* Similarly as above, we will construct T_{1,2} and T_{2,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On */ +/* each iteration, T_{1:3,3} are not referenced. See slarft.f */ +/* for details on how these formulae were constructed. */ + +/* We now get */ + +/* T_{1,2} = -T_{1,1}[V_{1,1} V_{1,2} V_{1,3}][ 0 V_{2,2} V_{2,3} ]'T_{2,2} */ + +/* T_{1,2} = -T_{1,1}(V_{1,2} + V_{1,3}V_{2,3}')T_{2,2} */ + +/* This means we will do the following */ + +/* T_{1,2} = -V_{1,2}T_{2,2} = -\tau_{i}V_{1,2} */ +/* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} */ +/* T_{1,2} = T_{1,1}T_{1,2} */ +/* T_{2,2} = \tau{i} */ + + t[t_dim1 + 1] = tau[1]; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T_{1,2} = -\tau_{i}V_{1,2} */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1]; + } - if (lsame_(direct, "F")) { - prevlastv = *n; +/* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + r__1 = -tau[i__]; + sgemv_("No Transpose", &i__2, &i__3, &r__1, &v[(i__ + 1) * v_dim1 + + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], ldv, &c_b11, &t[ + i__ * t_dim1 + 1], &c__1); + +/* T_{1,2} = T_{1,1}T_{1,2} */ + + i__2 = i__ - 1; + strmv_("Upper", "No Transpose", "Non-unit", &i__2, &t[t_offset], + ldt, &t[i__ * t_dim1 + 1], &c__1); + +/* T_{2,2} = \tau{i} */ + + t[i__ + i__ * t_dim1] = tau[i__]; + } + } else if (lqt) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} V_{1,2} V_{1,3} | i-1 */ +/* | 0 V_{2,2} V_{2,3} | 1 */ +/* | 0 0 V_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 n-i */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{3,3} and repeat until we */ +/* reach the end. On each iteration V_{3,3} is not referenced */ + +/* We will construct T one column at a time from left to right */ +/* after initializing T(1,1) = TAU(1) */ + +/* T = |-------------------------| */ +/* | T_{1,1} 0 0 | i-1 */ +/* | T_{2,1} T_{2,2} 0 | 1 */ +/* | T_{3,1} T_{3,2} T_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 k-i */ + +/* Similarly as above, we will construct T_{2,1} and T_{2,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{3,1:3}. On */ +/* each iteration, T_{3,1:3} are not referenced. See slarft.f */ +/* for details on how these formulae were constructed. */ + +/* We now get */ + +/* T_{2,1} = -T_{2,2}[0 V_{2,2} V_{2,3}][V_{1,1} V_{1,2} V_{1,3}]'T_{1,1} */ + +/* T_{2,1} = -T_{2,2}(V_{1,2}' + V_{2,3}V_{1,3}')T_{1,1} */ + +/* This means we will do the following */ + +/* T_{2,1} = -T_{2,2}V_{1,2}' = -\tau_{i}V_{1,2}' */ +/* T_{2,1} = -\tau_{i}V_{1,3}V_{2,3}' + T_{2,1} */ +/* T_{2,1} = T_{1,1}'T_{2,1} */ +/* T_{2,2} = \tau{i} */ + + t[t_dim1 + 1] = tau[1]; i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - prevlastv = f2cmax(i__,prevlastv); - if (tau[i__] == 0.f) { - -/* H(i) = I */ - - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = 0.f; - } - } else { - -/* general case */ - - if (lsame_(storev, "C")) { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - if (v[lastv + i__ * v_dim1] != 0.f) { - myexit_(); - } - } - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1]; - } - j = f2cmin(lastv,prevlastv); - -/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) */ - - i__2 = j - i__; - i__3 = i__ - 1; - r__1 = -tau[i__]; - sgemv_("Transpose", &i__2, &i__3, &r__1, &v[i__ + 1 + - v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, & - c_b6, &t[i__ * t_dim1 + 1], &c__1); - } else { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - if (v[i__ + lastv * v_dim1] != 0.f) { - myexit_(); - } - } - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1]; - } - j = f2cmin(lastv,prevlastv); - -/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T */ - - i__2 = i__ - 1; - i__3 = j - i__; - r__1 = -tau[i__]; - sgemv_("No transpose", &i__2, &i__3, &r__1, &v[(i__ + 1) * - v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], - ldv, &c_b6, &t[i__ * t_dim1 + 1], &c__1); - } - -/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ - - i__2 = i__ - 1; - strmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ - t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); - t[i__ + i__ * t_dim1] = tau[i__]; - if (i__ > 1) { - prevlastv = f2cmax(prevlastv,lastv); - } else { - prevlastv = lastv; - } + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T_{2,1} = -\tau_{i}V_{1,2}' */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[i__ + j * t_dim1] = -tau[i__] * v[j + i__ * v_dim1]; } + +/* T_{2,1} = -\tau_{i}V_{1,3}V_{2,3}' + T_{2,1} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + r__1 = -tau[i__]; + sgemv_("No transpose", &i__2, &i__3, &r__1, &v[(i__ + 1) * v_dim1 + + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], ldv, &c_b11, &t[ + i__ + t_dim1], ldt); + +/* T_{2,1}' = T_{1,1}'T_{2,1}' */ + + i__2 = i__ - 1; + strmv_("Lower", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt, + &t[i__ + t_dim1], ldt); + t[i__ + i__ * t_dim1] = tau[i__]; } - } else { - prevlastv = 1; - for (i__ = *k; i__ >= 1; --i__) { - if (tau[i__] == 0.f) { - -/* H(i) = I */ - - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - t[j + i__ * t_dim1] = 0.f; - } - } else { - -/* general case */ - - if (i__ < *k) { - if (lsame_(storev, "C")) { -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[lastv + i__ * v_dim1] != 0.f) { - myexit_(); - } - } - i__1 = *k; - for (j = i__ + 1; j <= i__1; ++j) { - t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__ - + j * v_dim1]; - } - j = f2cmax(lastv,prevlastv); - -/* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) */ - - i__1 = *n - *k + i__ - j; - i__2 = *k - i__; - r__1 = -tau[i__]; - sgemv_("Transpose", &i__1, &i__2, &r__1, &v[j + (i__ - + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], & - c__1, &c_b6, &t[i__ + 1 + i__ * t_dim1], & - c__1); - } else { -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[i__ + lastv * v_dim1] != 0.f) { - myexit_(); - } - } - i__1 = *k; - for (j = i__ + 1; j <= i__1; ++j) { - t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k - + i__) * v_dim1]; - } - j = f2cmax(lastv,prevlastv); - -/* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T */ - - i__1 = *k - i__; - i__2 = *n - *k + i__ - j; - r__1 = -tau[i__]; - sgemv_("No transpose", &i__1, &i__2, &r__1, &v[i__ + - 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], - ldv, &c_b6, &t[i__ + 1 + i__ * t_dim1], &c__1); - } - -/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ - - i__1 = *k - i__; - strmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ - + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * - t_dim1], &c__1) - ; - if (i__ > 1) { - prevlastv = f2cmin(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - t[i__ + i__ * t_dim1] = tau[i__]; + } else if (ql) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} V_{1,2} V_{1,3} | n-i */ +/* | 0 V_{2,2} V_{2,3} | 1 */ +/* | 0 0 V_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{1,1} and repeat until we */ +/* reach the end. On each iteration V_{1,1} is not referenced */ + +/* We will construct T one column at a time from right to left */ +/* after initializing T(K,K) = TAU(K) */ + +/* T = |-------------------------| */ +/* | T_{1,1} 0 0 | k-i */ +/* | T_{2,1} T_{2,2} 0 | 1 */ +/* | T_{3,1} T_{3,2} T_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{2,2} and T_{3,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On */ +/* each iteration, T_{1:3,1} are not referenced. See slarft.f */ +/* for details on how these formulae were constructed. */ + +/* We get that */ + +/* T_{3,2} = -T_{3,3}[V_{1,3}\\V_{2,3}\\V_{3,3}]' */ +/* [V_{1,2}\\V_{2,2}\\0]T_{2,2} */ + +/* T_{3,2} = -T_{3,3}(V_{1,3}'V_{1,2} + V_{2,3}')T_{2,2} */ + +/* Thus, we will compute */ + +/* T_{2,2} = \tau_{k-i+1} */ +/* T_{3,2} = -T_{3,3}V_{3,2}' = -\tau_{k-i+1}V_{3,2}' */ +/* T_{3,2} = -\tau_{k-i+1}V_{1,3}'V_{1,2} + T_{3,2} */ +/* T_{3,2} = T_{3,3}T_{3,2} */ + + t[*k + *k * t_dim1] = tau[*k]; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + kmi = *k - i__ + 1; + nmi = *n - i__ + 1; + +/* T_{2,2} = \tau(k-i+1) */ + + t[kmi + kmi * t_dim1] = tau[kmi]; + +/* T_{3,2} = -\tau(k-i+1)V_{2,3}' */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[kmi + j + kmi * t_dim1] = -tau[kmi] * v[nmi + (kmi + j) * + v_dim1]; } + +/* T_{3,2} = -\tau(k-i+1)V_{1,3}'V_{1,2} + T_{3,2} */ + + i__2 = *n - i__; + i__3 = i__ - 1; + r__1 = -tau[kmi]; + sgemv_("Transpose", &i__2, &i__3, &r__1, &v[(kmi + 1) * v_dim1 + + 1], ldv, &v[kmi * v_dim1 + 1], &c__1, &c_b11, &t[kmi + 1 + + kmi * t_dim1], &c__1); + +/* T_{3,2} = T_{3,3}T_{3,2} */ + + i__2 = i__ - 1; + strmv_("Lower", "No Transpose", "Non-unit", &i__2, &t[kmi + 1 + ( + kmi + 1) * t_dim1], ldt, &t[kmi + 1 + kmi * t_dim1], & + c__1); } - } - return; + } else if (rq) { -/* End of SLARFT_LVL2 */ +/* Break V into 9 components */ +/* V = |-------------------------| */ +/* | V_{1,1} 0 0 | k-i */ +/* | V_{2,1} V_{2,2} 0 | 1 */ +/* | V_{3,1} V_{3,2} V_{3,3} | i-1 */ +/* |-------------------------| */ +/* n-i 1 i-1 */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{1,1} and repeat until we */ +/* reach the end. On each iteration V_{1,1} is not referenced */ + +/* We will construct T one column at a time from right to left */ +/* after initializing T(K,K) = TAU(K) */ + +/* T = |-------------------------| */ +/* | T_{1,1} 0 0 | k-i */ +/* | T_{2,1} T_{2,2} 0 | 1 */ +/* | T_{3,1} T_{3,2} T_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{2,2} and T_{3,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On */ +/* each iteration, T_{1:3,1} are not referenced. See slarft.f */ +/* for details on how these formulae were constructed. */ + +/* We get that */ + +/* T_{3,2} = -T_{3,3}[V_{3,1} V_{3,2} V_{3,3}][V_{2,1} V_{2,2} 0]'T_{2,2} */ + +/* T_{3,2} = -T_{3,3}(V_{3,1}V_{2,1}' + V_{3,2})T_{2,2} */ + +/* Thus, we will compute */ + +/* T_{2,2} = \tau_{k-i+1} */ +/* T_{3,2} = -\tau_{k-i+1}V_{3,2} */ +/* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} */ +/* T_{3,2} = T_{3,3}T_{3,2} */ + + t[*k + *k * t_dim1] = tau[*k]; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + kmi = *k - i__ + 1; + nmi = *n - i__ + 1; + +/* T_{2,2} = \tau_{k-i+1} */ + + t[kmi + kmi * t_dim1] = tau[kmi]; + +/* T_{3,2} = -\tau_{k-i+1}V_{3,2} */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[kmi + j + kmi * t_dim1] = -tau[kmi] * v[kmi + j + nmi * + v_dim1]; + } + +/* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + r__1 = -tau[kmi]; + sgemv_("No Transpose", &i__2, &i__3, &r__1, &v[kmi + 1 + v_dim1], + ldv, &v[kmi + v_dim1], ldv, &c_b11, &t[kmi + 1 + kmi * + t_dim1], &c__1); + +/* T_{3,2} = T_{3,3}T_{3,2} */ + + i__2 = i__ - 1; + strmv_("Lower", "No Transpose", "Non-unit", &i__2, &t[kmi + 1 + ( + kmi + 1) * t_dim1], ldt, &t[kmi + 1 + kmi * t_dim1], & + c__1); + } + } else if (rqt) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} 0 0 | k-i */ +/* | V_{2,1} V_{2,2} 0 | 1 */ +/* | V_{3,1} V_{3,2} V_{3,3} | i-1 */ +/* |-------------------------| */ +/* n-i 1 i-1 */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{1,1} and repeat until we */ +/* reach the end. On each iteration V_{1,1} is not referenced */ + +/* We will construct T one column at a time from right to left */ +/* after initializing T(K,K) = TAU(K) */ + +/* T = |-------------------------| */ +/* | T_{1,1} T_{1,2} T_{1,3} | k-i */ +/* | 0 T_{2,2} T_{2,3} | 1 */ +/* | 0 0 T_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{2,2} and T_{2,3} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1,1:3}. On */ +/* each iteration, T_{1,1:3} are not referenced. See slarft.f */ +/* for details on how these formulae were constructed. */ + +/* We get that */ + +/* T_{2,3} = -T_{2,2}[V_{2,1} V_{2,2} 0][V_{3,1} V_{3,2} V_{3,3}]'T_{3,3} */ + +/* After transposing when necessary to fit our blas routines' interface, */ +/* we get */ +/* T_{3,2} = -T_{2,2}(V_{3,1}V_{2,1} + V_{3,2})T_{3,3} */ + +/* Thus, we will compute */ + +/* T_{2,2} = \tau_{k-i+1} */ +/* T_{2,3} = -\tau_{k-i+1}V_{3,2}' */ +/* T_{2,3} = -\tau_{k-i+1}V_{3,1}V_{2,1} + T_{2,3} */ +/* T_{2,3} = T_{3,3}'T_{2,3} */ + + t[*k + *k * t_dim1] = tau[*k]; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + kmi = *k - i__ + 1; + nmi = *n - i__ + 1; + +/* T_{2,2} = \tau_{k-i+1} */ + + t[kmi + kmi * t_dim1] = tau[kmi]; + +/* T_{2,3} = -\tau_{k-i+1}V_{3,2}' */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[kmi + (kmi + j) * t_dim1] = -tau[kmi] * v[kmi + j + nmi * + v_dim1]; + } + +/* T_{2,3} = -\tau_{k-i+1}V_{3,1}V_{2,1} + T_{2,3} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + r__1 = -tau[kmi]; + sgemv_("No Transpose", &i__2, &i__3, &r__1, &v[kmi + 1 + v_dim1], + ldv, &v[kmi + v_dim1], ldv, &c_b11, &t[kmi + (kmi + 1) * + t_dim1], ldt); + +/* T_{2,3} = T_{3,3}'T_{2,3} */ + + i__2 = i__ - 1; + strmv_("Upper", "Transpose", "Non-unit", &i__2, &t[kmi + 1 + (kmi + + 1) * t_dim1], ldt, &t[kmi + (kmi + 1) * t_dim1], ldt); + } + } + return; } /* slarft_lvl2__ */ diff --git a/lapack-netlib/SRC/slarft_lvl2.f b/lapack-netlib/SRC/slarft_lvl2.f index 7107a91d5d..2a4f5bd8ee 100644 --- a/lapack-netlib/SRC/slarft_lvl2.f +++ b/lapack-netlib/SRC/slarft_lvl2.f @@ -1,18 +1,10 @@ -*> \brief \b SLARFT_LVL2: Level 2 BLAS version for terminating case of SLARFT. +*> \brief \b SLARFT_LVL2 forms the triangular factor T of a block reflector H = I - vtvH * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> Download SLARFT_LVL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -* * Definition: * =========== * @@ -49,6 +41,9 @@ *> H(i) is stored in the i-th row of the array V, and *> *> H = I - V**T * T * V +*> +*> If DIRECT or STOREV = 'T', see Further Details for the shape of T +*> *> \endverbatim * * Arguments: @@ -61,6 +56,8 @@ *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) +*> = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) +*> but we return the T matrix that is already (conjugate) transposed *> \endverbatim *> *> \param[in] STOREV @@ -68,8 +65,10 @@ *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise +*> = 'C': column-wise +*> = 'R': row-wise +*> = 'T': (With DIRECT='F') Row-wise, but we return the T +*> matrix that is already (conjugate) transposed. *> \endverbatim *> *> \param[in] N @@ -155,6 +154,29 @@ *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) +*> +*> In addition, the shape of T is determined by these same flags as +*> in the below table. +*> 'U' denotes upper triangular +*> 'L' denotes lower triangular +*> 'X' denotes no current implementation +*> We also provide the logical variable that represents the case +*> in the code if it is implemented +*> +*> |-----------------------------------------------------------| +*> | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | +*> |--------------+--------------+--------------+--------------| +*> | STOREV = 'C' | U (QR) | L (QL) | X | +*> | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | +*> | STOREV = 'T' | L (LQT) | X | X | +*> |-----------------------------------------------------------| +*> +*> Finally, the relationship between the (conjugate) transposed T matrices +*> are as follows: (Note that T_{FC} denotes the T associated with calling +*> this routine with DIRECT = 'F' and STOREV = 'C') +*> +*> T_{TR} = (T_{BR})**H +*> T_{FT} = (T_{FR})**H *> \endverbatim *> * ===================================================================== @@ -170,157 +192,555 @@ SUBROUTINE SLARFT_LVL2( DIRECT, STOREV, N, K, V, LDV, TAU, INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. +* REAL T( LDT, * ), TAU( * ), V( LDV, * ) * .. * -* ===================================================================== -* * .. Parameters .. - REAL ONE, ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. +* + REAL ONE + PARAMETER(ONE=1.0E+0) +* * .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV -* .. +* + INTEGER I,J,KMI,NMI,INFO + LOGICAL QR, LQ, QL, RQ, LQT, RQT, + $ DIRF, DIRB, DIRT, + $ STOREC, STORER, STORET +* * .. External Subroutines .. - EXTERNAL SGEMV, STRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME +* + EXTERNAL STRMV,SGEMV,XERBLA +* +* .. External Functions.. +* + LOGICAL LSAME + EXTERNAL LSAME * .. * .. Executable Statements .. * +* Convert our character flags to logical flags for later +* + DIRF = LSAME(DIRECT,'F') + DIRB = LSAME(DIRECT,'B') + DIRT = LSAME(DIRECT,'T') + STOREC = LSAME(STOREV,'C') + STORER = LSAME(STOREV,'R') + STORET = LSAME(STOREV,'T') +* +* Error handling for our character flags +* + INFO = 0 + IF( .NOT.(DIRF.OR.DIRB.OR.DIRT) ) THEN +* +* DIRECT holds an illegal value +* + INFO = 1 + ELSE IF( .NOT.(STOREC.OR.STORER.OR.STORET) ) THEN +* +* STOREV holds an illegal value +* + INFO = 2 + ELSE IF( DIRB.AND.STORET ) THEN +* +* This case is purposefully not implemented, but any other value for +* STOREV is valid, so we report STOREV as the invalid input +* + INFO = 2 + ELSE IF( DIRT.AND.STOREC ) THEN +* +* This case is purposefully not implemented, but any other value for +* DIRECT is valid, so we report DIRECT as the invalid input +* + INFO = 1 + ELSE IF( DIRT.AND.STORET ) THEN +* +* This case is purposefully not implemented, and is ambiguous what +* the user wants to do, so we arbitrarily say DIRECT is the incorrect +* character flag. +* + INFO = 1 + END IF + + IF( INFO.NE.0 ) THEN + CALL XERBLA('SLARFT_LVL2', INFO) + RETURN + END IF +* * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO I = 1, K - PREVLASTV = MAX( I, PREVLASTV ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = 1, I - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( I , J ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) -* - CALL SGEMV( 'Transpose', J-I, I-1, -TAU( I ), - $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, - $ T( 1, I ), 1 ) - ELSE -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( J , I ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T -* - CALL SGEMV( 'No transpose', I-1, J-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, - $ ONE, T( 1, I ), 1 ) - END IF -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL STRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF + IF(N.EQ.0.OR.K.EQ.0) THEN + RETURN + END IF +* +* Now we determine what factorization our flags are associated with +* +* QR happens when we have forward direction in column storage +* + QR = DIRF.AND.STOREC +* +* LQT happens when we have forward direction in row storage and want to compute the transpose of +* the T we would normally compute +* + LQT = DIRF.AND.STORET +* +* LQ happens when we have forward direction in row storage and want to compute the T we would +* normally compute +* + LQ = DIRF.AND.STORER +* +* QL happens when we have backward direction in column storage +* + QL = DIRB.AND.STOREC +* +* RQT happens when we have backward direction in row storage and want to compute the transpose +* of the T we would normally compute +* + RQT = DIRT.AND.STORER +* +* RQ happens when we have backward direction in row storage and want to compute the T that we +* would normally compute +* + RQ = DIRB.AND.STORER + IF( N.EQ.1.OR.K.EQ.1) THEN + T(1,1) = TAU(1) + RETURN + END IF + IF (QR) THEN +* +* Break V into 9 components +* +* V = |-----------------------| +* |V_{1,1} 0 0 | i-1 +* |V_{2,1} V_{2,2} 0 | 1 +* |V_{3,1} V_{3,2} V_{3,3}| n-i +* |-----------------------| +* i-1 1 k-i +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{3,3} and repeat until we +* reach the end. On each iteration V_{3,3} is not referenced +* +* We will construct T one column at a time from left to right +* after initializing T(1,1) = TAU(1) +* +* T = |-------------------------| +* | T_{1,1} T_{1,2} T_{1,3} | i-1 +* | 0 T_{2,2} T_{2,3} | 1 +* | 0 0 T_{3,3} | k-i +* |-------------------------| +* i-1 1 k-i +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{1,2} and T_{2,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On +* each iteration, T_{1:3,3} are not referenced. See slarft.f +* for details on how these formulae were constructed. +* +* We now get +* +* T_{1,2} = -T_{1,1}[V_{1,1}\\V_{2,1}\\V_{3,1}]' +* [0\\V_{2,2}\\V_{3,2}]T_{2,2} +* +* T_{1,2} = -T_{1,1}(V_{2,1}' + V_{3,1}'V_{3,2})T_{2,2} +* +* This means we will do the following +* +* T_{1,2} = -V_{2,1}'T_{2,2} = -\tau_{i}V_{2,1}' +* T_{1,2} = -\tau_{i}V_{3,2}' V_{3,1} + T_{1,2} +* T_{1,2} = T_{1,1}T_{1,2} +* T_{2,2} = \tau{i} +* + T(1,1) = TAU(1) + + DO I = 2, K +* +* T_{1,2} = -V_{2,1}'V_{2,2}T_{2,2} = -\tau_i V_{2,1}' +* We must do this at copy time as otherwise gemv will do nothing +* on the last column when n=k, but we neet to make sure we are +* scaled by this value +* + DO J = 1, I-1 + T(J,I) = -V(I,J)*TAU(I) + END DO + +* +* T_{1,2} = -V_{3,1}'V_{3,2}T_{2,2} + T_{1,2} +* = -\tau{i} V_{3,2}'V_{3,1} + T_{1,2} +* + CALL SGEMV('Transpose', N-I, I-1, -TAU(I), V(I+1,1), + $ LDV, V(I+1,I), 1, ONE, T(1, I), 1) + + +* +* T_{1,2} = T_{1,1}T_{1,2} +* + CALL STRMV('Upper', 'No Transpose', 'Non-unit', I-1, + $ T, LDT, T(1,I), 1) + +* +* T_{2,2} = \tau{i} +* + T(I,I) = TAU(I) END DO - ELSE - PREVLASTV = 1 - DO I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = I, K - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( N-K+I , J ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) -* - CALL SGEMV( 'Transpose', N-K+I-J, K-I, - $ -TAU( I ), - $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, - $ T( I+1, I ), 1 ) - ELSE -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T -* - CALL SGEMV( 'No transpose', K-I, N-K+I-J, - $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), 1 ) - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL STRMV( 'Lower', 'No transpose', 'Non-unit', - $ K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF + ELSE IF (LQ) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} V_{1,2} V_{1,3} | i-1 +* | 0 V_{2,2} V_{2,3} | 1 +* | 0 0 V_{3,3} | k-i +* |-------------------------| +* i-1 1 n-i +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{3,3} and repeat until we +* reach the end. On each iteration V_{3,3} is not referenced +* +* We will construct T one column at a time from left to right +* after initializing T(1,1) = TAU(1) +* +* T = |-------------------------| +* | T_{1,1} T_{1,2} T_{1,3} | i-1 +* | 0 T_{2,2} T_{2,3} | 1 +* | 0 0 T_{3,3} | k-i +* |-------------------------| +* i-1 1 k-i +* +* Similarly as above, we will construct T_{1,2} and T_{2,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On +* each iteration, T_{1:3,3} are not referenced. See slarft.f +* for details on how these formulae were constructed. +* +* We now get +* +* T_{1,2} = -T_{1,1}[V_{1,1} V_{1,2} V_{1,3}][ 0 V_{2,2} V_{2,3} ]'T_{2,2} +* +* T_{1,2} = -T_{1,1}(V_{1,2} + V_{1,3}V_{2,3}')T_{2,2} +* +* This means we will do the following +* +* T_{1,2} = -V_{1,2}T_{2,2} = -\tau_{i}V_{1,2} +* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} +* T_{1,2} = T_{1,1}T_{1,2} +* T_{2,2} = \tau{i} +* + T(1,1) = TAU(1) + DO I = 2, K +* +* T_{1,2} = -\tau_{i}V_{1,2} +* + DO J = 1, I-1 + T(J, I) = -TAU(I)*V(J, I) + END DO +* +* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} +* + CALL SGEMV('No Transpose', I-1, N-I, -TAU(I), V(1, I+1), + $ LDV, V(I, I+1), LDV, ONE, T(1,I), 1) +* +* T_{1,2} = T_{1,1}T_{1,2} +* + CALL STRMV('Upper', 'No Transpose', 'Non-unit', I-1, + $ T, LDT, T(1,I), 1) +* +* T_{2,2} = \tau{i} +* + T(I,I) = TAU(I) END DO - END IF - RETURN + ELSE IF (LQT) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} V_{1,2} V_{1,3} | i-1 +* | 0 V_{2,2} V_{2,3} | 1 +* | 0 0 V_{3,3} | k-i +* |-------------------------| +* i-1 1 n-i +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{3,3} and repeat until we +* reach the end. On each iteration V_{3,3} is not referenced +* +* We will construct T one column at a time from left to right +* after initializing T(1,1) = TAU(1) +* +* T = |-------------------------| +* | T_{1,1} 0 0 | i-1 +* | T_{2,1} T_{2,2} 0 | 1 +* | T_{3,1} T_{3,2} T_{3,3} | k-i +* |-------------------------| +* i-1 1 k-i +* +* Similarly as above, we will construct T_{2,1} and T_{2,2} at +* each iteration i = 2, \dots k, and then grow into T_{3,1:3}. On +* each iteration, T_{3,1:3} are not referenced. See slarft.f +* for details on how these formulae were constructed. +* +* We now get +* +* T_{2,1} = -T_{2,2}[0 V_{2,2} V_{2,3}][V_{1,1} V_{1,2} V_{1,3}]'T_{1,1} +* +* T_{2,1} = -T_{2,2}(V_{1,2}' + V_{2,3}V_{1,3}')T_{1,1} +* +* This means we will do the following +* +* T_{2,1} = -T_{2,2}V_{1,2}' = -\tau_{i}V_{1,2}' +* T_{2,1} = -\tau_{i}V_{1,3}V_{2,3}' + T_{2,1} +* T_{2,1} = T_{1,1}'T_{2,1} +* T_{2,2} = \tau{i} +* + T(1,1) = TAU(1) + DO I = 2, K +* +* T_{2,1} = -\tau_{i}V_{1,2}' +* + DO J = 1, I-1 + T(I,J) = -TAU(I)*V(J,I) + END DO +* +* T_{2,1} = -\tau_{i}V_{1,3}V_{2,3}' + T_{2,1} +* + CALL SGEMV('No transpose', I-1, N-I, -TAU(I), V(1, I+1), + $ LDV, V(I, I+1), LDV, ONE, T(I, 1), LDT) + +* +* T_{2,1}' = T_{1,1}'T_{2,1}' +* + CALL STRMV('Lower', 'Transpose', 'Non-unit', I-1, + $ T, LDT, T(I,1), LDT) + T(I,I) = TAU(I) + END DO + ELSE IF (QL) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} V_{1,2} V_{1,3} | n-i +* | 0 V_{2,2} V_{2,3} | 1 +* | 0 0 V_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{1,1} and repeat until we +* reach the end. On each iteration V_{1,1} is not referenced +* +* We will construct T one column at a time from right to left +* after initializing T(K,K) = TAU(K) +* +* T = |-------------------------| +* | T_{1,1} 0 0 | k-i +* | T_{2,1} T_{2,2} 0 | 1 +* | T_{3,1} T_{3,2} T_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{2,2} and T_{3,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On +* each iteration, T_{1:3,1} are not referenced. See slarft.f +* for details on how these formulae were constructed. +* +* We get that +* +* T_{3,2} = -T_{3,3}[V_{1,3}\\V_{2,3}\\V_{3,3}]' +* [V_{1,2}\\V_{2,2}\\0]T_{2,2} +* +* T_{3,2} = -T_{3,3}(V_{1,3}'V_{1,2} + V_{2,3}')T_{2,2} +* +* Thus, we will compute +* +* T_{2,2} = \tau_{k-i+1} +* T_{3,2} = -T_{3,3}V_{3,2}' = -\tau_{k-i+1}V_{3,2}' +* T_{3,2} = -\tau_{k-i+1}V_{1,3}'V_{1,2} + T_{3,2} +* T_{3,2} = T_{3,3}T_{3,2} +* + T(K,K) = TAU(K) + DO I = 2, K + KMI = K-I+1 + NMI = N-I+1 +* +* T_{2,2} = \tau(k-i+1) +* + T(KMI,KMI) = TAU(KMI) +* +* T_{3,2} = -\tau(k-i+1)V_{2,3}' +* + DO J = 1, I-1 + T(KMI + J, KMI) = -TAU(KMI)*V(NMI, KMI + J) + END DO +* +* T_{3,2} = -\tau(k-i+1)V_{1,3}'V_{1,2} + T_{3,2} +* + CALL SGEMV('Transpose', N-I, I-1, -TAU(KMI), + $ V(1, KMI + 1), LDV, V(1, KMI), 1, ONE, + $ T(KMI+1, KMI), 1) +* +* T_{3,2} = T_{3,3}T_{3,2} +* + CALL STRMV('Lower', 'No Transpose', 'Non-unit', I-1, + $ T(KMI + 1, KMI + 1), LDT, T(KMI + 1, KMI), 1) + END DO + ELSE IF (RQ) THEN * -* End of SLARFT_LVL2 +* Break V into 9 components * - END +* V = |-------------------------| +* | V_{1,1} 0 0 | k-i +* | V_{2,1} V_{2,2} 0 | 1 +* | V_{3,1} V_{3,2} V_{3,3} | i-1 +* |-------------------------| +* n-i 1 i-1 +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{1,1} and repeat until we +* reach the end. On each iteration V_{1,1} is not referenced +* +* We will construct T one column at a time from right to left +* after initializing T(K,K) = TAU(K) +* +* T = |-------------------------| +* | T_{1,1} 0 0 | k-i +* | T_{2,1} T_{2,2} 0 | 1 +* | T_{3,1} T_{3,2} T_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{2,2} and T_{3,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On +* each iteration, T_{1:3,1} are not referenced. See slarft.f +* for details on how these formulae were constructed. +* +* We get that +* +* T_{3,2} = -T_{3,3}[V_{3,1} V_{3,2} V_{3,3}][V_{2,1} V_{2,2} 0]'T_{2,2} +* +* T_{3,2} = -T_{3,3}(V_{3,1}V_{2,1}' + V_{3,2})T_{2,2} +* +* Thus, we will compute +* +* T_{2,2} = \tau_{k-i+1} +* T_{3,2} = -\tau_{k-i+1}V_{3,2} +* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} +* T_{3,2} = T_{3,3}T_{3,2} +* + T(K,K) = TAU(K) + DO I = 2, K + KMI = K-I+1 + NMI = N-I+1 +* +* T_{2,2} = \tau_{k-i+1} +* + T(KMI,KMI) = TAU(KMI) +* +* T_{3,2} = -\tau_{k-i+1}V_{3,2} +* + DO J = 1, I-1 + T(KMI + J, KMI) = -TAU(KMI)*V(KMI + J, NMI) + END DO +* +* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} +* + CALL SGEMV('No Transpose', I-1, N-I, -TAU(KMI), + $ V(KMI+1, 1), LDV, V(KMI, 1), LDV, ONE, T(KMI+1, KMI), + $ 1) +* +* T_{3,2} = T_{3,3}T_{3,2} +* + CALL STRMV('Lower', 'No Transpose', 'Non-unit', I-1, + $ T(KMI+1, KMI+1), LDT, T(KMI+1, KMI), 1) + END DO + ELSE IF (RQT) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} 0 0 | k-i +* | V_{2,1} V_{2,2} 0 | 1 +* | V_{3,1} V_{3,2} V_{3,3} | i-1 +* |-------------------------| +* n-i 1 i-1 +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{1,1} and repeat until we +* reach the end. On each iteration V_{1,1} is not referenced +* +* We will construct T one column at a time from right to left +* after initializing T(K,K) = TAU(K) +* +* T = |-------------------------| +* | T_{1,1} T_{1,2} T_{1,3} | k-i +* | 0 T_{2,2} T_{2,3} | 1 +* | 0 0 T_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{2,2} and T_{2,3} at +* each iteration i = 2, \dots k, and then grow into T_{1,1:3}. On +* each iteration, T_{1,1:3} are not referenced. See slarft.f +* for details on how these formulae were constructed. +* +* We get that +* +* T_{2,3} = -T_{2,2}[V_{2,1} V_{2,2} 0][V_{3,1} V_{3,2} V_{3,3}]'T_{3,3} +* +* After transposing when necessary to fit our blas routines' interface, +* we get +* T_{3,2} = -T_{2,2}(V_{3,1}V_{2,1} + V_{3,2})T_{3,3} +* +* Thus, we will compute +* +* T_{2,2} = \tau_{k-i+1} +* T_{2,3} = -\tau_{k-i+1}V_{3,2}' +* T_{2,3} = -\tau_{k-i+1}V_{3,1}V_{2,1} + T_{2,3} +* T_{2,3} = T_{3,3}'T_{2,3} +* + T(K,K) = TAU(K) + DO I = 2, K + KMI = K-I+1 + NMI = N-I+1 +* +* T_{2,2} = \tau_{k-i+1} +* + T(KMI,KMI) = TAU(KMI) +* +* T_{2,3} = -\tau_{k-i+1}V_{3,2}' +* + DO J = 1, I-1 + T(KMI, KMI + J) = -TAU(KMI)*V(KMI + J, NMI) + END DO +* +* T_{2,3} = -\tau_{k-i+1}V_{3,1}V_{2,1} + T_{2,3} +* + CALL SGEMV('No Transpose', I-1, N-I, -TAU(KMI), + $ V(KMI+1, 1), LDV, V(KMI, 1), LDV, ONE, T(KMI, KMI+1), + $ LDT) +* +* T_{2,3} = T_{3,3}'T_{2,3} +* + CALL STRMV('Upper', 'Transpose', 'Non-unit', I-1, + $ T(KMI+1, KMI+1), LDT, T(KMI, KMI+1), LDT) + END DO + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/zlarft.c b/lapack-netlib/SRC/zlarft.c index af3740e31d..731d3f4616 100644 --- a/lapack-netlib/SRC/zlarft.c +++ b/lapack-netlib/SRC/zlarft.c @@ -261,7 +261,7 @@ typedef struct Namelist Namelist; /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; -static doublecomplex c_b3 = {-1.,0.}; +static doublecomplex c_b2 = {-1.,0.}; static integer c__3 = 3; static integer c_n1 = -1; static integer c__2 = 2; @@ -315,6 +315,9 @@ f"> */ /* > H(i) is stored in the i-th row of the array V, and */ /* > */ /* > H = I - V**H * T * V */ +/* > */ +/* > If DIRECT or STOREV = 'T', see Further Details for the shape of T */ +/* > */ /* > \endverbatim */ /* Arguments: */ @@ -327,6 +330,8 @@ f"> */ /* > multiplied to form the block reflector: */ /* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ /* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) */ +/* > but we return the T matrix that is already (conjugate) transposed */ /* > \endverbatim */ /* > */ /* > \param[in] STOREV */ @@ -334,8 +339,10 @@ f"> */ /* > STOREV is CHARACTER*1 */ /* > Specifies how the vectors which define the elementary */ /* > reflectors are stored (see also Further Details): */ -/* > = 'C': columnwise */ -/* > = 'R': rowwise */ +/* > = 'C': column-wise */ +/* > = 'R': row-wise */ +/* > = 'T': (With DIRECT='F') Row-wise, but we return the T */ +/* > matrix that is already (conjugate) transposed. */ /* > \endverbatim */ /* > */ /* > \param[in] N */ @@ -421,6 +428,29 @@ f"> */ /* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ /* > ( 1 v3 ) */ /* > ( 1 ) */ +/* > */ +/* > In addition, the shape of T is determined by these same flags as */ +/* > in the below table. */ +/* > 'U' denotes upper triangular */ +/* > 'L' denotes lower triangular */ +/* > 'X' denotes no current implementation */ +/* > We also provide the logical variable that represents the case */ +/* > in the code if it is implemented */ +/* > */ +/* > |-----------------------------------------------------------| */ +/* > | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | */ +/* > |--------------+--------------+--------------+--------------| */ +/* > | STOREV = 'C' | U (QR) | L (QL) | X | */ +/* > | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | */ +/* > | STOREV = 'T' | L (LQT) | X | X | */ +/* > |-----------------------------------------------------------| */ +/* > */ +/* > Finally, the relationship between the (conjugate) transposed T matrices */ +/* > are as follows: (Note that T_{FC} denotes the T associated with calling */ +/* > this routine with DIRECT = 'F' and STOREV = 'C') */ +/* > */ +/* > T_{TR} = (T_{BR})**H */ +/* > T_{FT} = (T_{FR})**H */ /* > \endverbatim */ /* > */ /* ===================================================================== */ @@ -436,23 +466,28 @@ f"> */ /* Local variables */ integer i__, j, l; - logical lq, ql, qr; + logical lq, ql, qr, rq; integer nx; extern /* Subroutine */ void zlarft_lvl2__(char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); - logical dirf, colv; + logical lqt, rqt, dirb, dirf; + integer info; + logical dirt; extern logical lsame_(char *, char *); extern /* Subroutine */ void zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), ztrmm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer * - , doublecomplex *, integer *); + , doublecomplex *, integer *), + xerbla_(char *, integer *, ftnlen); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); + logical storec; extern /* Subroutine */ void zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); + logical storer, storet; /* -- LAPACK auxiliary routine -- */ @@ -477,7 +512,7 @@ f"> */ /* Based on the algorithm of Elmroth and Gustavson, */ /* IBM J. Res. Develop. Vol 44 No. 4 July 2000. */ -/* Quick return if possible */ +/* Convert our character flags to logical flags for later */ /* Parameter adjustments */ v_dim1 = *ldv; @@ -489,19 +524,102 @@ f"> */ t -= t_offset; /* Function Body */ + dirf = lsame_(direct, "F"); + dirb = lsame_(direct, "B"); + dirt = lsame_(direct, "T"); + storec = lsame_(storev, "C"); + storer = lsame_(storev, "R"); + storet = lsame_(storev, "T"); + +/* Error handling for our character flags */ + + info = 0; + if (! (dirf || dirb || dirt)) { + +/* DIRECT holds an illegal value */ + + info = 1; + } else if (! (storec || storer || storet)) { + +/* STOREV holds an illegal value */ + + info = 2; + } else if (dirb && storet) { + +/* This case is purposefully not implemented, but any other value for */ +/* STOREV is valid, so we report STOREV as the invalid input */ + + info = 2; + } else if (dirt && storec) { + +/* This case is purposefully not implemented, but any other value for */ +/* DIRECT is valid, so we report DIRECT as the invalid input */ + + info = 1; + } else if (dirt && storet) { + +/* This case is purposefully not implemented, and is ambiguous what */ +/* the user wants to do, so we arbitrarily say DIRECT is the incorrect */ +/* character flag. */ + + info = 1; + } + if (info != 0) { + xerbla_("ZLARFT", &info, (ftnlen)6); + return; + } + +/* Quick return if possible */ + if (*n == 0 || *k == 0) { return; } +/* Now we determine what factorization our flags are associated with */ + +/* QR happens when we have forward direction in column storage */ + + qr = dirf && storec; + +/* LQT happens when we have forward direction in row storage and want to compute the transpose of */ +/* the T we would normally compute */ + + lqt = dirf && storet; + +/* LQ happens when we have forward direction in row storage and want to compute the T we would */ +/* normally compute */ + + lq = dirf && storer; + +/* QL happens when we have backward direction in column storage */ + + ql = dirb && storec; + +/* RQT happens when we have backward direction in row storage and want to compute the transpose */ +/* of the T we would normally compute */ + + rqt = dirt && storer; + +/* RQ happens when we have backward direction in row storage and want to compute the T that we */ +/* would normally compute */ + + rq = dirb && storer; + /* Base case */ if (*n == 1 || *k == 1) { - i__1 = t_dim1 + 1; - t[i__1].r = tau[1].r, t[i__1].i = tau[1].i; + if (lqt || rqt) { + i__1 = t_dim1 + 1; + d_cnjg(&z__1, &tau[1]); + t[i__1].r = z__1.r, t[i__1].i = z__1.i; + } else { + i__1 = t_dim1 + 1; + t[i__1].r = tau[1].r, t[i__1].i = tau[1].i; + } return; } -/* Determine when to cross over into the level 2 based implementation */ +/* Determine crossover point from level 2 to level 3 BLAS implementation */ /* Writing concatenation */ i__2[0] = 1, a__1[0] = direct; @@ -510,41 +628,17 @@ f"> */ nx = ilaenv_(&c__3, "ZLARFT", ch__1, n, k, &c_n1, &c_n1, (ftnlen)6, ( ftnlen)2); if (*k < nx) { + +/* Finish this component with a level 2 BLAS implementation */ + zlarft_lvl2__(direct, storev, n, k, &v[v_offset], ldv, &tau[1], &t[ t_offset], ldt); return; } -/* Beginning of executable statements */ +/* Beginning of executable statements for the recursive case */ l = *k / 2; - -/* Determine what kind of Q we need to compute */ -/* We assume that if the user doesn't provide 'F' for DIRECT, */ -/* then they meant to provide 'B' and if they don't provide */ -/* 'C' for STOREV, then they meant to provide 'R' */ - - dirf = lsame_(direct, "F"); - colv = lsame_(storev, "C"); - -/* QR happens when we have forward direction in column storage */ - - qr = dirf && colv; - -/* LQ happens when we have forward direction in row storage */ - - lq = dirf && ! colv; - -/* QL happens when we have backward direction in column storage */ - - ql = ! dirf && colv; - -/* The last case is RQ. Due to how we structured this, if the */ -/* above 3 are false, then RQ must be true, so we never store */ -/* this */ -/* RQ happens when we have backward direction in row storage */ -/* RQ = (.NOT.DIRF).AND.(.NOT.COLV) */ - if (qr) { /* Break V apart into 6 components */ @@ -642,7 +736,7 @@ f"> */ /* T_{1,2} = -T_{1,1}*T_{1,2} */ i__1 = *k - l; - ztrmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__1, &c_b3, + ztrmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__1, &c_b2, &t[t_offset], ldt, &t[(l + 1) * t_dim1 + 1], ldt); /* T_{1,2} = T_{1,2}*T_{2,2} */ @@ -679,14 +773,14 @@ f"> */ /* To motivate the structure, assume we have already computed T_{1,1} */ /* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 */ -/* T_{1,1}\in\C^{l, l} upper triangular */ -/* T_{2,2}\in\C^{k-l, k-l} upper triangular */ -/* T_{1,2}\in\C^{l, k-l} rectangular */ +/* T_{1,1}\in\C^{l, l} upper triangular */ +/* T_{2,2}\in\C^{k-l, k-l} upper triangular */ +/* T_{1,2}\in\C^{l, k-l} rectangular */ /* Then, consider the product: */ -/* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) */ -/* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 */ +/* (I - V_1'*T_{1,1}'*V_1)*(I - V_2'*T_{2,2}'*V_2) */ +/* = I - V_1'*T_{1,1}'*V_1 - V_2'*T_{2,2}'*V_2 + V_1'*T_{1,1}'*V_1*V_2'*T_{2,2}'*V_2 */ /* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} */ @@ -697,7 +791,7 @@ f"> */ /* |---| */ /* So, our product is equivalent to the matrix product */ -/* I - V'*T*V */ +/* I - V'*T'*V */ /* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ /* to compute T_{1,2} */ @@ -742,7 +836,7 @@ f"> */ /* T_{1,2} = -T_{1,1}*T_{1,2} */ i__1 = *k - l; - ztrmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__1, &c_b3, + ztrmm_("Left", "Upper", "No transpose", "Non-unit", &l, &i__1, &c_b2, &t[t_offset], ldt, &t[(l + 1) * t_dim1 + 1], ldt); /* T_{1,2} = T_{1,2}*T_{2,2} */ @@ -751,6 +845,111 @@ f"> */ ztrmm_("Right", "Upper", "No transpose", "Non-unit", &l, &i__1, &c_b1, &t[l + 1 + (l + 1) * t_dim1], ldt, &t[(l + 1) * t_dim1 + 1], ldt); + } else if (lqt) { + +/* Break V apart into 6 components */ + +/* V = |----------------------| */ +/* |V_{1,1} V_{1,2} V{1,3}| */ +/* |0 V_{2,2} V{2,3}| */ +/* |----------------------| */ + +/* V_{1,1}\in\C^{l,l} unit upper triangular */ +/* V_{1,2}\in\C^{l,k-l} rectangular */ +/* V_{1,3}\in\C^{l,n-k} rectangular */ + +/* V_{2,2}\in\C^{k-l,k-l} unit upper triangular */ +/* V_{2,3}\in\C^{k-l,n-k} rectangular */ + +/* Where l = floor(k/2) */ + +/* We will construct the T matrix */ +/* T = |---------------| */ +/* |T_{1,1} 0 | */ +/* |T_{2,1} T_{2,2}| */ +/* |---------------| */ + +/* T is the triangular factor obtained from block reflectors. */ +/* To motivate the structure, assume we have already computed T_{1,1} */ +/* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 */ + +/* T_{1,1}\in\C^{l, l} lower triangular */ +/* T_{2,2}\in\C^{k-l, k-l} lower triangular */ +/* T_{2,1}\in\C^{k-l, l} rectangular */ + +/* Then, consider the product: */ + +/* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) */ +/* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 */ + +/* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} */ + +/* Then, we can define the matrix V as */ +/* V = |---| */ +/* |V_1| */ +/* |V_2| */ +/* |---| */ + +/* So, our product is equivalent to the matrix product */ +/* I - V'*T*V */ +/* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ +/* to compute T_{2,1} */ + +/* Compute T_{1,1} recursively */ + + zlarft_(direct, storev, n, &l, &v[v_offset], ldv, &tau[1], &t[ + t_offset], ldt); + +/* Compute T_{2,2} recursively */ + + i__1 = *n - l; + i__3 = *k - l; + zlarft_(direct, storev, &i__1, &i__3, &v[l + 1 + (l + 1) * v_dim1], + ldv, &tau[l + 1], &t[l + 1 + (l + 1) * t_dim1], ldt); + +/* Compute T_{2,1} */ +/* T_{2,1} = V_{1,2}' */ + + i__1 = *k - l; + for (i__ = 1; i__ <= i__1; ++i__) { + i__3 = l; + for (j = 1; j <= i__3; ++j) { + i__4 = l + i__ + j * t_dim1; + d_cnjg(&z__1, &v[j + (l + i__) * v_dim1]); + t[i__4].r = z__1.r, t[i__4].i = z__1.i; + } + } + +/* T_{2,1} = V_{2,2}*T_{2,1} */ + + i__1 = *k - l; + ztrmm_("Left", "Upper", "No Transpose", "Unit", &i__1, &l, &c_b1, &v[ + l + 1 + (l + 1) * v_dim1], ldv, &t[l + 1 + t_dim1], ldt); + +/* T_{2,1} = V_{2,3}*V_{1,3}' + T_{2,1} */ +/* Note: We assume K <= N, and GEMM will do nothing if N=K */ + + i__1 = *k - l; + i__3 = *n - *k; + zgemm_("No Transpose", "Conjugate", &i__1, &l, &i__3, &c_b1, &v[l + 1 + + (*k + 1) * v_dim1], ldv, &v[(*k + 1) * v_dim1 + 1], ldv, & + c_b1, &t[l + 1 + t_dim1], ldt); + +/* At this point, we have that T_{2,1} = V_2*V_1' */ +/* All that is left is to pre and post multiply by -T_{2,2} and T_{1,1} */ +/* respectively. */ + +/* T_{2,1} = -T_{2,2}*T_{2,1} */ + + i__1 = *k - l; + ztrmm_("Left", "Lower", "No Transpose", "Non-unit", &i__1, &l, &c_b2, + &t[l + 1 + (l + 1) * t_dim1], ldt, &t[l + 1 + t_dim1], ldt); + +/* T_{2,1} = T_{2,1}*T_{1,1} */ + + i__1 = *k - l; + ztrmm_("Right", "Lower", "No Transpose", "Non-unit", &i__1, &l, &c_b1, + &t[t_offset], ldt, &t[l + 1 + t_dim1], ldt); } else if (ql) { /* Break V apart into 6 components */ @@ -848,7 +1047,7 @@ f"> */ /* T_{2,1} = -T_{2,2}*T_{2,1} */ i__1 = *k - l; - ztrmm_("Left", "Lower", "No transpose", "Non-unit", &l, &i__1, &c_b3, + ztrmm_("Left", "Lower", "No transpose", "Non-unit", &l, &i__1, &c_b2, &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[*k - l + 1 + t_dim1], ldt); @@ -857,10 +1056,7 @@ f"> */ i__1 = *k - l; ztrmm_("Right", "Lower", "No transpose", "Non-unit", &l, &i__1, &c_b1, &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); - } else { - -/* Else means RQ case */ - + } else if (rq) { /* Break V apart into 6 components */ /* V = |-----------------------| */ @@ -893,8 +1089,8 @@ f"> */ /* Then, consider the product: */ -/* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) */ -/* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 */ +/* (I - V_2'*T_{2,2}'*V_2)*(I - V_1'*T_{1,1}'*V_1) */ +/* = I - V_2'*T_{2,2}'*V_2 - V_1'*T_{1,1}'*V_1 + V_2'*T_{2,2}'*V_2*V_1'*T_{1,1}'*V_1 */ /* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} */ @@ -905,7 +1101,7 @@ f"> */ /* |---| */ /* So, our product is equivalent to the matrix product */ -/* I - V'*T*V */ +/* I - V'*T'*V */ /* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ /* to compute T_{2,1} */ @@ -950,15 +1146,120 @@ f"> */ /* T_{2,1} = -T_{2,2}*T_{2,1} */ i__1 = *k - l; - ztrmm_("Left", "Lower", "No tranpose", "Non-unit", &l, &i__1, &c_b3, & - t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[*k - l + 1 + + ztrmm_("Left", "Lower", "No transpose", "Non-unit", &l, &i__1, &c_b2, + &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[*k - l + 1 + t_dim1], ldt); /* T_{2,1} = T_{2,1}*T_{1,1} */ i__1 = *k - l; - ztrmm_("Right", "Lower", "No tranpose", "Non-unit", &l, &i__1, &c_b1, - &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); + ztrmm_("Right", "Lower", "No transpose", "Non-unit", &l, &i__1, &c_b1, + &t[t_offset], ldt, &t[*k - l + 1 + t_dim1], ldt); + } else if (rqt) { +/* Break V apart into 6 components */ + +/* V = |-----------------------| */ +/* |V_{1,1} V_{1,2} 0 | */ +/* |V_{2,1} V_{2,2} V_{2,3}| */ +/* |-----------------------| */ + +/* V_{1,1}\in\C^{k-l,n-k} rectangular */ +/* V_{1,2}\in\C^{k-l,k-l} unit lower triangular */ + +/* V_{2,1}\in\C^{l,n-k} rectangular */ +/* V_{2,2}\in\C^{l,k-l} rectangular */ +/* V_{2,3}\in\C^{l,l} unit lower triangular */ + +/* We will construct the T matrix */ +/* T = |---------------| */ +/* |T_{1,1} T_{1,2}| */ +/* | 0 T_{2,2}| */ +/* |---------------| */ + +/* T is the triangular factor obtained from block reflectors. */ +/* To motivate the structure, assume we have already computed T_{1,1} */ +/* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 */ + +/* T_{1,1}\in\C^{k-l, k-l} non-unit upper triangular */ +/* T_{2,2}\in\C^{l, l} non-unit upper triangular */ +/* T_{1,2}\in\C^{k-l, l} rectangular */ + +/* Where l = floor(k/2) */ + +/* Then, consider the product: */ + +/* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) */ +/* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 */ + +/* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} */ + +/* Then, we can define the matrix V as */ +/* V = |---| */ +/* |V_1| */ +/* |V_2| */ +/* |---| */ + +/* So, our product is equivalent to the matrix product */ +/* I - V'*T*V */ +/* This means, we can compute T_{1,1} and T_{2,2}, then use this information */ +/* to compute T_{1,2} */ + +/* Compute T_{1,1} recursively */ + + i__1 = *n - l; + i__3 = *k - l; + zlarft_(direct, storev, &i__1, &i__3, &v[v_offset], ldv, &tau[1], &t[ + t_offset], ldt); + +/* Compute T_{2,2} recursively */ + + zlarft_(direct, storev, n, &l, &v[*k - l + 1 + v_dim1], ldv, &tau[*k + - l + 1], &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt); + +/* Compute T_{1,2} */ +/* T_{1,2} = V_{2,2}' */ + + i__1 = *k - l; + for (i__ = 1; i__ <= i__1; ++i__) { + i__3 = l; + for (j = 1; j <= i__3; ++j) { + i__4 = i__ + (*k - l + j) * t_dim1; + d_cnjg(&z__1, &v[*k - l + j + (*n - *k + i__) * v_dim1]); + t[i__4].r = z__1.r, t[i__4].i = z__1.i; + } + } + +/* T_{1,2} = V_{1,2}T_{1,2} */ + + i__1 = *k - l; + ztrmm_("Left", "Lower", "No Transpose", "Unit", &i__1, &l, &c_b1, &v[( + *n - *k + 1) * v_dim1 + 1], ldv, &t[(*k - l + 1) * t_dim1 + 1] + , ldt); + +/* T_{1,2} = V_{1,1}V_{2,1}' + T_{1,2} */ + + i__1 = *k - l; + i__3 = *n - *k; + zgemm_("No Transpose", "Conjugate", &i__1, &l, &i__3, &c_b1, &v[ + v_offset], ldv, &v[*k - l + 1 + v_dim1], ldv, &c_b1, &t[(*k - + l + 1) * t_dim1 + 1], ldt); + +/* At this point, we have that T_{1,2} = V_1*V_2' */ +/* All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} */ +/* respectively. */ + +/* T_{1,2} = -T_{1,1}*T_{1,2} */ + + i__1 = *k - l; + ztrmm_("Left", "Upper", "No Transpose", "Non-Unit", &i__1, &l, &c_b2, + &t[t_offset], ldt, &t[(*k - l + 1) * t_dim1 + 1], ldt); + +/* T_{1,2} = T_{1,2}*T_{2,2} */ + + i__1 = *k - l; + ztrmm_("Right", "Upper", "No Transpose", "Non-Unit", &i__1, &l, &c_b1, + &t[*k - l + 1 + (*k - l + 1) * t_dim1], ldt, &t[(*k - l + 1) + * t_dim1 + 1], ldt); } return; } /* zlarft_ */ diff --git a/lapack-netlib/SRC/zlarft.f b/lapack-netlib/SRC/zlarft.f index efd52037d3..8a0d3f0cf7 100644 --- a/lapack-netlib/SRC/zlarft.f +++ b/lapack-netlib/SRC/zlarft.f @@ -48,6 +48,9 @@ *> H(i) is stored in the i-th row of the array V, and *> *> H = I - V**H * T * V +*> +*> If DIRECT or STOREV = 'T', see Further Details for the shape of T +*> *> \endverbatim * * Arguments: @@ -60,6 +63,8 @@ *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) +*> = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) +*> but we return the T matrix that is already (conjugate) transposed *> \endverbatim *> *> \param[in] STOREV @@ -67,8 +72,10 @@ *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise +*> = 'C': column-wise +*> = 'R': row-wise +*> = 'T': (With DIRECT='F') Row-wise, but we return the T +*> matrix that is already (conjugate) transposed. *> \endverbatim *> *> \param[in] N @@ -154,6 +161,29 @@ *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) +*> +*> In addition, the shape of T is determined by these same flags as +*> in the below table. +*> 'U' denotes upper triangular +*> 'L' denotes lower triangular +*> 'X' denotes no current implementation +*> We also provide the logical variable that represents the case +*> in the code if it is implemented +*> +*> |-----------------------------------------------------------| +*> | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | +*> |--------------+--------------+--------------+--------------| +*> | STOREV = 'C' | U (QR) | L (QL) | X | +*> | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | +*> | STOREV = 'T' | L (LQT) | X | X | +*> |-----------------------------------------------------------| +*> +*> Finally, the relationship between the (conjugate) transposed T matrices +*> are as follows: (Note that T_{FC} denotes the T associated with calling +*> this routine with DIRECT = 'F' and STOREV = 'C') +*> +*> T_{TR} = (T_{BR})**H +*> T_{FT} = (T_{FR})**H *> \endverbatim *> * ===================================================================== @@ -167,28 +197,30 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * * .. Scalar Arguments * - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. * - COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) + COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * .. Parameters .. * - COMPLEX*16 ONE, NEG_ONE, ZERO - PARAMETER(ONE=(1.0D+0,0.0D+0), ZERO = (0.0D+0,0.0D+0), - $ NEG_ONE=(-1.0D+0,0.0D+0)) + COMPLEX*16 ONE, NEG_ONE + PARAMETER(ONE=(1.0D+0,0.0D+0), + $ NEG_ONE=(-1.0D+0,0.0D+0)) * * .. Local Scalars .. * - INTEGER I,J,L,NX - LOGICAL QR,LQ,QL,DIRF,COLV + INTEGER I,J,L,NX,INFO + LOGICAL QR, LQ, QL, RQ, LQT, RQT, + $ DIRF, DIRB, DIRT, + $ STOREC, STORER, STORET * * .. External Subroutines .. * - EXTERNAL ZTRMM,ZGEMM,ZLACPY + EXTERNAL ZLARFT_LVL2, ZTRMM, ZGEMM, ZLACPY, XERBLA * * .. External Functions.. * @@ -198,8 +230,8 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * * .. Intrinsic Functions.. * - INTRINSIC CONJG -* + INTRINSIC DCONJG +* * The general scheme used is inspired by the approach inside DGEQRT3 * which was (at the time of writing this code): * Based on the algorithm of Elmroth and Gustavson, @@ -207,57 +239,115 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * .. * .. Executable Statements .. * -* Quick return if possible +* Convert our character flags to logical flags for later * - IF(N.EQ.0.OR.K.EQ.0) THEN - RETURN - END IF + DIRF = LSAME(DIRECT,'F') + DIRB = LSAME(DIRECT,'B') + DIRT = LSAME(DIRECT,'T') + STOREC = LSAME(STOREV,'C') + STORER = LSAME(STOREV,'R') + STORET = LSAME(STOREV,'T') * -* Base case +* Error handling for our character flags * - IF(N.EQ.1.OR.K.EQ.1) THEN - T(1,1) = TAU(1) + INFO = 0 + IF( .NOT.(DIRF.OR.DIRB.OR.DIRT) ) THEN +* +* DIRECT holds an illegal value +* + INFO = 1 + ELSE IF( .NOT.(STOREC.OR.STORER.OR.STORET) ) THEN +* +* STOREV holds an illegal value +* + INFO = 2 + ELSE IF( DIRB.AND.STORET ) THEN +* +* This case is purposefully not implemented, but any other value for +* STOREV is valid, so we report STOREV as the invalid input +* + INFO = 2 + ELSE IF( DIRT.AND.STOREC ) THEN +* +* This case is purposefully not implemented, but any other value for +* DIRECT is valid, so we report DIRECT as the invalid input +* + INFO = 1 + ELSE IF( DIRT.AND.STORET ) THEN +* +* This case is purposefully not implemented, and is ambiguous what +* the user wants to do, so we arbitrarily say DIRECT is the incorrect +* character flag. +* + INFO = 1 + END IF + + IF( INFO.NE.0 ) THEN + CALL XERBLA('ZLARFT', INFO) RETURN END IF * -* Determine when to cross over into the level 2 based implementation +* Quick return if possible * - NX = ILAENV(3, "ZLARFT", DIRECT // STOREV, N, K, -1, -1) - IF(K.LT.NX) THEN - CALL ZLARFT_LVL2(DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT) + IF(N.EQ.0.OR.K.EQ.0) THEN RETURN END IF * -* Beginning of executable statements -* - L = K / 2 +* Now we determine what factorization our flags are associated with * -* Determine what kind of Q we need to compute -* We assume that if the user doesn't provide 'F' for DIRECT, -* then they meant to provide 'B' and if they don't provide -* 'C' for STOREV, then they meant to provide 'R' +* QR happens when we have forward direction in column storage * - DIRF = LSAME(DIRECT,'F') - COLV = LSAME(STOREV,'C') + QR = DIRF.AND.STOREC * -* QR happens when we have forward direction in column storage +* LQT happens when we have forward direction in row storage and want to compute the transpose of +* the T we would normally compute * - QR = DIRF.AND.COLV + LQT = DIRF.AND.STORET * -* LQ happens when we have forward direction in row storage +* LQ happens when we have forward direction in row storage and want to compute the T we would +* normally compute * - LQ = DIRF.AND.(.NOT.COLV) + LQ = DIRF.AND.STORER * * QL happens when we have backward direction in column storage * - QL = (.NOT.DIRF).AND.COLV + QL = DIRB.AND.STOREC +* +* RQT happens when we have backward direction in row storage and want to compute the transpose +* of the T we would normally compute +* + RQT = DIRT.AND.STORER +* +* RQ happens when we have backward direction in row storage and want to compute the T that we +* would normally compute +* + RQ = DIRB.AND.STORER +* +* Base case +* + IF(N.EQ.1.OR.K.EQ.1) THEN + IF( LQT.OR.RQT ) THEN + T(1,1) = DCONJG(TAU(1)) + ELSE + T(1,1) = TAU(1) + END IF + RETURN + END IF +* +* Determine crossover point from level 2 to level 3 BLAS implementation +* + NX = ILAENV(3, "ZLARFT", DIRECT // STOREV, N, K, -1, -1) + IF(K.LT.NX) THEN * -* The last case is RQ. Due to how we structured this, if the -* above 3 are false, then RQ must be true, so we never store -* this -* RQ happens when we have backward direction in row storage -* RQ = (.NOT.DIRF).AND.(.NOT.COLV) +* Finish this component with a level 2 BLAS implementation * + CALL ZLARFT_LVL2(DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT) + RETURN + END IF +* +* Beginning of executable statements for the recursive case +* + L = K / 2 IF(QR) THEN * * Break V apart into 6 components @@ -271,17 +361,17 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * V_{1,1}\in\C^{l,l} unit lower triangular * V_{2,1}\in\C^{k-l,l} rectangular * V_{3,1}\in\C^{n-k,l} rectangular -* +* * V_{2,2}\in\C^{k-l,k-l} unit lower triangular * V_{3,2}\in\C^{n-k,k-l} rectangular * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} T_{1,2}| * |0 T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -292,17 +382,17 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * Where l = floor(k/2) * * Then, consider the product: -* +* * (I - V_1*T_{1,1}*V_1')*(I - V_2*T_{2,2}*V_2') * = I - V_1*T_{1,1}*V_1' - V_2*T_{2,2}*V_2' + V_1*T_{1,1}*V_1'*V_2*T_{2,2}*V_2' -* +* * Define T_{1,2} = -T_{1,1}*V_1'*V_2*T_{2,2} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |-------| * |V_1 V_2| * |-------| -* +* * So, our product is equivalent to the matrix product * I - V*T*V' * This means, we can compute T_{1,1} and T_{2,2}, then use this information @@ -314,30 +404,29 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * * Compute T_{2,2} recursively * - CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V(L+1, L+1), LDV, - $ TAU(L+1), T(L+1, L+1), LDT) + CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V(L+1,L+1), LDV, + $ TAU(L+1), T(L+1,L+1), LDT) * -* Compute T_{1,2} +* Compute T_{1,2} * T_{1,2} = V_{2,1}' * DO J = 1, L DO I = 1, K-L - T(J, L+I) = CONJG(V(L+I, J)) + T(J,L+I) = CONJG(V(L+I,J)) END DO END DO * * T_{1,2} = T_{1,2}*V_{2,2} * CALL ZTRMM('Right', 'Lower', 'No transpose', 'Unit', L, - $ K-L, ONE, V(L+1, L+1), LDV, T(1, L+1), LDT) + $ K-L, ONE, V(L+1, L+1), LDV, T(1, L+1), LDT) * * T_{1,2} = V_{3,1}'*V_{3,2} + T_{1,2} * Note: We assume K <= N, and GEMM will do nothing if N=K * - CALL ZGEMM('Conjugate', 'No transpose', L, K-L, N-K, ONE, - $ V(K+1, 1), LDV, V(K+1, L+1), LDV, ONE, - $ T(1, L+1), LDT) + CALL ZGEMM('Conjugate', 'No transpose', L, K-L, N-K, ONE, + $ V(K+1, 1), LDV, V(K+1,L+1), LDV, ONE, T(1, L+1), LDT) * * At this point, we have that T_{1,2} = V_1'*V_2 * All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} @@ -346,12 +435,12 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{1,2} = -T_{1,1}*T_{1,2} * CALL ZTRMM('Left', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT) + $ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT) * * T_{1,2} = T_{1,2}*T_{2,2} * - CALL ZTRMM('Right', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, ONE, T(L+1, L+1), LDT, T(1, L+1), LDT) + CALL ZTRMM('Right', 'Upper', 'No transpose', 'Non-unit', L, + $ K-L, ONE, T(L+1,L+1), LDT, T(1, L+1), LDT) ELSE IF(LQ) THEN * @@ -365,41 +454,41 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * V_{1,1}\in\C^{l,l} unit upper triangular * V_{1,2}\in\C^{l,k-l} rectangular * V_{1,3}\in\C^{l,n-k} rectangular -* +* * V_{2,2}\in\C^{k-l,k-l} unit upper triangular * V_{2,3}\in\C^{k-l,n-k} rectangular * * Where l = floor(k/2) * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} T_{1,2}| * |0 T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * -* T_{1,1}\in\C^{l, l} upper triangular -* T_{2,2}\in\C^{k-l, k-l} upper triangular -* T_{1,2}\in\C^{l, k-l} rectangular +* T_{1,1}\in\C^{l, l} upper triangular +* T_{2,2}\in\C^{k-l, k-l} upper triangular +* T_{1,2}\in\C^{l, k-l} rectangular * * Then, consider the product: -* -* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) -* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 -* +* +* (I - V_1'*T_{1,1}'*V_1)*(I - V_2'*T_{2,2}'*V_2) +* = I - V_1'*T_{1,1}'*V_1 - V_2'*T_{2,2}'*V_2 + V_1'*T_{1,1}'*V_1*V_2'*T_{2,2}'*V_2 +* * Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |---| * |V_1| * |V_2| * |---| -* +* * So, our product is equivalent to the matrix product -* I - V'*T*V +* I - V'*T'*V * This means, we can compute T_{1,1} and T_{2,2}, then use this information * to compute T_{1,2} * @@ -409,27 +498,26 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * * Compute T_{2,2} recursively * - CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V(L+1, L+1), LDV, - $ TAU(L+1), T(L+1, L+1), LDT) + CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V(L+1,L+1), LDV, + $ TAU(L+1), T(L+1,L+1), LDT) * * Compute T_{1,2} * T_{1,2} = V_{1,2} * - CALL ZLACPY('All', L, K-L, V(1, L+1), LDV, T(1, L+1), LDT) + CALL ZLACPY('All', L, K - L, V(1,L+1), LDV, T(1, L+1), LDT) * * T_{1,2} = T_{1,2}*V_{2,2}' * CALL ZTRMM('Right', 'Upper', 'Conjugate', 'Unit', L, K-L, - $ ONE, V(L+1, L+1), LDV, T(1, L+1), LDT) + $ ONE, V(L+1, L+1), LDV, T(1, L+1), LDT) * * T_{1,2} = V_{1,3}*V_{2,3}' + T_{1,2} * Note: We assume K <= N, and GEMM will do nothing if N=K * CALL ZGEMM('No transpose', 'Conjugate', L, K-L, N-K, ONE, - $ V(1, K+1), LDV, V(L+1, K+1), LDV, ONE, - $ T(1, L+1), LDT) + $ V(1, K+1), LDV, V(L+1, K+1), LDV, ONE, T(1, L+1), LDT) * * At this point, we have that T_{1,2} = V_1*V_2' * All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} @@ -438,13 +526,106 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{1,2} = -T_{1,1}*T_{1,2} * CALL ZTRMM('Left', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT) + $ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT) * * T_{1,2} = T_{1,2}*T_{2,2} * CALL ZTRMM('Right', 'Upper', 'No transpose', 'Non-unit', L, - $ K-L, ONE, T(L+1, L+1), LDT, T(1, L+1), LDT) + $ K-L, ONE, T(L+1,L+1), LDT, T(1, L+1), LDT) + ELSE IF(LQT) THEN +* +* Break V apart into 6 components +* +* V = |----------------------| +* |V_{1,1} V_{1,2} V{1,3}| +* |0 V_{2,2} V{2,3}| +* |----------------------| +* +* V_{1,1}\in\C^{l,l} unit upper triangular +* V_{1,2}\in\C^{l,k-l} rectangular +* V_{1,3}\in\C^{l,n-k} rectangular +* +* V_{2,2}\in\C^{k-l,k-l} unit upper triangular +* V_{2,3}\in\C^{k-l,n-k} rectangular +* +* Where l = floor(k/2) +* +* We will construct the T matrix +* T = |---------------| +* |T_{1,1} 0 | +* |T_{2,1} T_{2,2}| +* |---------------| +* +* T is the triangular factor obtained from block reflectors. +* To motivate the structure, assume we have already computed T_{1,1} +* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 +* +* T_{1,1}\in\C^{l, l} lower triangular +* T_{2,2}\in\C^{k-l, k-l} lower triangular +* T_{2,1}\in\C^{k-l, l} rectangular +* +* Then, consider the product: +* +* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2) +* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2 +* +* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} +* +* Then, we can define the matrix V as +* V = |---| +* |V_1| +* |V_2| +* |---| +* +* So, our product is equivalent to the matrix product +* I - V'*T*V +* This means, we can compute T_{1,1} and T_{2,2}, then use this information +* to compute T_{2,1} +* +* Compute T_{1,1} recursively +* + CALL ZLARFT(DIRECT, STOREV, N, L, V, LDV, TAU, T, LDT) +* +* Compute T_{2,2} recursively +* + CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V(L+1,L+1), LDV, + $ TAU(L+1), T(L+1,L+1), LDT) + +* +* Compute T_{2,1} +* T_{2,1} = V_{1,2}' +* + DO I = 1, K-L + DO J = 1, L + T(L+I,J) = CONJG(V(J,L+I)) + END DO + END DO +* +* T_{2,1} = V_{2,2}*T_{2,1} +* + CALL ZTRMM('Left', 'Upper', 'No Transpose', 'Unit', K-L, L, + $ ONE, V(L+1,L+1), LDV, T(L+1,1), LDT) +* +* T_{2,1} = V_{2,3}*V_{1,3}' + T_{2,1} +* Note: We assume K <= N, and GEMM will do nothing if N=K +* + CALL ZGEMM('No Transpose', 'Conjugate', K-L, L, N-K, ONE, + $ V(L+1,K+1), LDV, V(1, K+1), LDV, ONE, T(L+1,1), LDT) +* +* At this point, we have that T_{2,1} = V_2*V_1' +* All that is left is to pre and post multiply by -T_{2,2} and T_{1,1} +* respectively. +* +* T_{2,1} = -T_{2,2}*T_{2,1} +* + CALL ZTRMM('Left', 'Lower', 'No Transpose', 'Non-unit', + $ K-L, L, NEG_ONE, T(L+1,L+1), LDT, T(L+1,1), LDT) +* +* T_{2,1} = T_{2,1}*T_{1,1} +* + CALL ZTRMM('Right', 'Lower', 'No Transpose', 'Non-unit', + $ K-L, L, ONE, T, LDT, T(L+1,1), LDT) ELSE IF(QL) THEN * * Break V apart into 6 components @@ -457,18 +638,18 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * * V_{1,1}\in\C^{n-k,k-l} rectangular * V_{2,1}\in\C^{k-l,k-l} unit upper triangular -* +* * V_{1,2}\in\C^{n-k,l} rectangular * V_{2,2}\in\C^{k-l,l} rectangular * V_{3,2}\in\C^{l,l} unit upper triangular * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} 0 | * |T_{2,1} T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -479,17 +660,17 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * Where l = floor(k/2) * * Then, consider the product: -* +* * (I - V_2*T_{2,2}*V_2')*(I - V_1*T_{1,1}*V_1') * = I - V_2*T_{2,2}*V_2' - V_1*T_{1,1}*V_1' + V_2*T_{2,2}*V_2'*V_1*T_{1,1}*V_1' -* +* * Define T_{2,1} = -T_{2,2}*V_2'*V_1*T_{1,1} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |-------| * |V_1 V_2| * |-------| -* +* * So, our product is equivalent to the matrix product * I - V*T*V' * This means, we can compute T_{1,1} and T_{2,2}, then use this information @@ -497,34 +678,34 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * * Compute T_{1,1} recursively * - CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, LDT) + CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, + $ LDT) * * Compute T_{2,2} recursively * CALL ZLARFT(DIRECT, STOREV, N, L, V(1, K-L+1), LDV, - $ TAU(K-L+1), T(K-L+1, K-L+1), LDT) + $ TAU(K-L+1), T(K-L+1,K-L+1), LDT) * * Compute T_{2,1} * T_{2,1} = V_{2,2}' * DO J = 1, K-L DO I = 1, L - T(K-L+I, J) = CONJG(V(N-K+J, K-L+I)) + T(K-L+I,J) = CONJG(V(N-K+J, K-L+I)) END DO END DO * * T_{2,1} = T_{2,1}*V_{2,1} * CALL ZTRMM('Right', 'Upper', 'No transpose', 'Unit', L, - $ K-L, ONE, V(N-K+1, 1), LDV, T(K-L+1, 1), LDT) + $ K-L, ONE, V(N-K+1,1), LDV, T(K-L+1,1), LDT) * * T_{2,1} = V_{2,2}'*V_{2,1} + T_{2,1} * Note: We assume K <= N, and GEMM will do nothing if N=K * CALL ZGEMM('Conjugate', 'No transpose', L, K-L, N-K, ONE, - $ V(1, K-L+1), LDV, V, LDV, ONE, T(K-L+1, 1), - $ LDT) + $ V(1,K-L+1), LDV, V, LDV, ONE, T(K-L+1,1), LDT) * * At this point, we have that T_{2,1} = V_2'*V_1 * All that is left is to pre and post multiply by -T_{2,2} and T_{1,1} @@ -533,17 +714,13 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * T_{2,1} = -T_{2,2}*T_{2,1} * CALL ZTRMM('Left', 'Lower', 'No transpose', 'Non-unit', L, - $ K-L, NEG_ONE, T(K-L+1, K-L+1), LDT, - $ T(K-L+1, 1), LDT) + $ K-L, NEG_ONE, T(K-L+1,K-L+1), LDT, T(K-L+1,1), LDT) * * T_{2,1} = T_{2,1}*T_{1,1} * CALL ZTRMM('Right', 'Lower', 'No transpose', 'Non-unit', L, - $ K-L, ONE, T, LDT, T(K-L+1, 1), LDT) - ELSE -* -* Else means RQ case -* + $ K-L, ONE, T, LDT, T(K-L+1,1), LDT) + ELSE IF(RQ) THEN * Break V apart into 6 components * * V = |-----------------------| @@ -558,13 +735,13 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * V_{2,2}\in\C^{l,k-l} rectangular * V_{2,3}\in\C^{l,l} unit lower triangular * -* We will construct the T matrix +* We will construct the T matrix * T = |---------------| * |T_{1,1} 0 | * |T_{2,1} T_{2,2}| * |---------------| * -* T is the triangular factor obtained from block reflectors. +* T is the triangular factor obtained from block reflectors. * To motivate the structure, assume we have already computed T_{1,1} * and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 * @@ -575,51 +752,51 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * Where l = floor(k/2) * * Then, consider the product: -* -* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) -* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 -* +* +* (I - V_2'*T_{2,2}'*V_2)*(I - V_1'*T_{1,1}'*V_1) +* = I - V_2'*T_{2,2}'*V_2 - V_1'*T_{1,1}'*V_1 + V_2'*T_{2,2}'*V_2*V_1'*T_{1,1}'*V_1 +* * Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1} -* -* Then, we can define the matrix V as +* +* Then, we can define the matrix V as * V = |---| * |V_1| * |V_2| * |---| -* +* * So, our product is equivalent to the matrix product -* I - V'*T*V +* I - V'*T'*V * This means, we can compute T_{1,1} and T_{2,2}, then use this information * to compute T_{2,1} * * Compute T_{1,1} recursively * - CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, LDT) + CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, + $ LDT) * * Compute T_{2,2} recursively * - CALL ZLARFT(DIRECT, STOREV, N, L, V(K-L+1, 1), LDV, - $ TAU(K-L+1), T(K-L+1, K-L+1), LDT) + CALL ZLARFT(DIRECT, STOREV, N, L, V(K-L+1,1), LDV, + $ TAU(K-L+1), T(K-L+1,K-L+1), LDT) * * Compute T_{2,1} * T_{2,1} = V_{2,2} * - CALL ZLACPY('All', L, K-L, V(K-L+1, N-K+1), LDV, - $ T(K-L+1, 1), LDT) + CALL ZLACPY('All', L, K-L, V(K-L+1,N-K+1), LDV, T(K-L+1,1), + $ LDT) * * T_{2,1} = T_{2,1}*V_{1,2}' * CALL ZTRMM('Right', 'Lower', 'Conjugate', 'Unit', L, K-L, - $ ONE, V(1, N-K+1), LDV, T(K-L+1, 1), LDT) + $ ONE, V(1, N-K+1), LDV, T(K-L+1,1), LDT) * -* T_{2,1} = V_{2,1}*V_{1,1}' + T_{2,1} +* T_{2,1} = V_{2,1}*V_{1,1}' + T_{2,1} * Note: We assume K <= N, and GEMM will do nothing if N=K * - CALL ZGEMM('No transpose', 'Conjugate', L, K-L, N-K, ONE, - $ V(K-L+1, 1), LDV, V, LDV, ONE, T(K-L+1, 1), - $ LDT) + CALL ZGEMM('No transpose', 'Conjugate', L, K-L, N-K, ONE, + $ V(K-L+1,1), LDV, V, LDV, ONE, T(K-L+1,1), LDT) * * At this point, we have that T_{2,1} = V_2*V_1' @@ -628,14 +805,104 @@ RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, * * T_{2,1} = -T_{2,2}*T_{2,1} * - CALL ZTRMM('Left', 'Lower', 'No tranpose', 'Non-unit', L, - $ K-L, NEG_ONE, T(K-L+1, K-L+1), LDT, - $ T(K-L+1, 1), LDT) + CALL ZTRMM('Left', 'Lower', 'No transpose', 'Non-unit', L, + $ K-L, NEG_ONE, T(K-L+1,K-L+1), LDT, T(K-L+1,1), LDT) * * T_{2,1} = T_{2,1}*T_{1,1} * - CALL ZTRMM('Right', 'Lower', 'No tranpose', 'Non-unit', L, - $ K-L, ONE, T, LDT, T(K-L+1, 1), LDT) + CALL ZTRMM('Right', 'Lower', 'No transpose', 'Non-unit', L, + $ K-L, ONE, T, LDT, T(K-L+1,1), LDT) + ELSE IF(RQT) THEN +* Break V apart into 6 components +* +* V = |-----------------------| +* |V_{1,1} V_{1,2} 0 | +* |V_{2,1} V_{2,2} V_{2,3}| +* |-----------------------| +* +* V_{1,1}\in\C^{k-l,n-k} rectangular +* V_{1,2}\in\C^{k-l,k-l} unit lower triangular +* +* V_{2,1}\in\C^{l,n-k} rectangular +* V_{2,2}\in\C^{l,k-l} rectangular +* V_{2,3}\in\C^{l,l} unit lower triangular +* +* We will construct the T matrix +* T = |---------------| +* |T_{1,1} T_{1,2}| +* | 0 T_{2,2}| +* |---------------| +* +* T is the triangular factor obtained from block reflectors. +* To motivate the structure, assume we have already computed T_{1,1} +* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2 +* +* T_{1,1}\in\C^{k-l, k-l} non-unit upper triangular +* T_{2,2}\in\C^{l, l} non-unit upper triangular +* T_{1,2}\in\C^{k-l, l} rectangular +* +* Where l = floor(k/2) +* +* Then, consider the product: +* +* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1) +* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1 +* +* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2} +* +* Then, we can define the matrix V as +* V = |---| +* |V_1| +* |V_2| +* |---| +* +* So, our product is equivalent to the matrix product +* I - V'*T*V +* This means, we can compute T_{1,1} and T_{2,2}, then use this information +* to compute T_{1,2} +* +* Compute T_{1,1} recursively +* + CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, + $ LDT) +* +* Compute T_{2,2} recursively +* + CALL ZLARFT(DIRECT, STOREV, N, L, V(K-L+1,1), LDV, + $ TAU(K-L+1), T(K-L+1,K-L+1), LDT) +* +* Compute T_{1,2} +* T_{1,2} = V_{2,2}' +* + DO I = 1, K-L + DO J = 1, L + T(I,K-L+J) = CONJG(V(K-L+J, N-K+I)) + END DO + END DO +* +* T_{1,2} = V_{1,2}T_{1,2} +* + CALL ZTRMM('Left', 'Lower', 'No Transpose', 'Unit', K-L, L, + $ ONE, V(1,N-K+1), LDV, T(1,K-L+1), LDT) +* +* T_{1,2} = V_{1,1}V_{2,1}' + T_{1,2} +* + CALL ZGEMM('No Transpose', 'Conjugate', K-L, L, N-K, ONE, V, + $ LDV, V(K-L+1,1), LDV, ONE, T(1, K-L+1), LDT) +* +* At this point, we have that T_{1,2} = V_1*V_2' +* All that is left is to pre and post multiply by -T_{1,1} and T_{2,2} +* respectively. +* +* T_{1,2} = -T_{1,1}*T_{1,2} +* + CALL ZTRMM('Left', 'Upper', 'No Transpose', 'Non-Unit', + $ K-L, L, NEG_ONE, T, LDT, T(1, K-L+1), LDT) +* +* T_{1,2} = T_{1,2}*T_{2,2} +* + CALL ZTRMM('Right', 'Upper', 'No Transpose', 'Non-Unit', + $ K-L, L, ONE, T(K-L+1,K-L+1), LDT, T(1, K-L+1), LDT) END IF END SUBROUTINE diff --git a/lapack-netlib/SRC/zlarft_lvl2.c b/lapack-netlib/SRC/zlarft_lvl2.c index 9958be2af5..9d54998021 100644 --- a/lapack-netlib/SRC/zlarft_lvl2.c +++ b/lapack-netlib/SRC/zlarft_lvl2.c @@ -257,30 +257,18 @@ typedef struct Namelist Namelist; -lf2c -lm (in that order) */ - /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; static integer c__1 = 1; -/* > \brief \b ZLARFT_LVL2: Level 2 BLAS version for terminating case of ZLARFT. */ +/* > \brief \b ZLARFT_LVL2 forms the triangular factor T of a block reflector H = I - vtvH */ /* =========== DOCUMENTATION =========== */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > Download ZLARFT_LVL2 + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ - /* Definition: */ /* =========== */ @@ -313,6 +301,9 @@ f"> */ /* > H(i) is stored in the i-th row of the array V, and */ /* > */ /* > H = I - V**H * T * V */ +/* > */ +/* > If DIRECT or STOREV = 'T', see Further Details for the shape of T */ +/* > */ /* > \endverbatim */ /* Arguments: */ @@ -325,6 +316,8 @@ f"> */ /* > multiplied to form the block reflector: */ /* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ /* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) */ +/* > but we return the T matrix that is already (conjugate) transposed */ /* > \endverbatim */ /* > */ /* > \param[in] STOREV */ @@ -332,8 +325,10 @@ f"> */ /* > STOREV is CHARACTER*1 */ /* > Specifies how the vectors which define the elementary */ /* > reflectors are stored (see also Further Details): */ -/* > = 'C': columnwise */ -/* > = 'R': rowwise */ +/* > = 'C': column-wise */ +/* > = 'R': row-wise */ +/* > = 'T': (With DIRECT='F') Row-wise, but we return the T */ +/* > matrix that is already (conjugate) transposed. */ /* > \endverbatim */ /* > */ /* > \param[in] N */ @@ -419,6 +414,29 @@ f"> */ /* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ /* > ( 1 v3 ) */ /* > ( 1 ) */ +/* > */ +/* > In addition, the shape of T is determined by these same flags as */ +/* > in the below table. */ +/* > 'U' denotes upper triangular */ +/* > 'L' denotes lower triangular */ +/* > 'X' denotes no current implementation */ +/* > We also provide the logical variable that represents the case */ +/* > in the code if it is implemented */ +/* > */ +/* > |-----------------------------------------------------------| */ +/* > | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | */ +/* > |--------------+--------------+--------------+--------------| */ +/* > | STOREV = 'C' | U (QR) | L (QL) | X | */ +/* > | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | */ +/* > | STOREV = 'T' | L (LQT) | X | X | */ +/* > |-----------------------------------------------------------| */ +/* > */ +/* > Finally, the relationship between the (conjugate) transposed T matrices */ +/* > are as follows: (Note that T_{FC} denotes the T associated with calling */ +/* > this routine with DIRECT = 'F' and STOREV = 'C') */ +/* > */ +/* > T_{TR} = (T_{BR})**H */ +/* > T_{FT} = (T_{FR})**H */ /* > \endverbatim */ /* > */ /* ===================================================================== */ @@ -431,17 +449,23 @@ f"> */ doublecomplex z__1, z__2, z__3; /* Local variables */ - integer i__, j, prevlastv; + integer i__, j; + logical lq, ql, qr, rq; + integer kmi, nmi; + logical lqt, rqt, dirb, dirf; + integer info; + logical dirt; extern logical lsame_(char *, char *); extern /* Subroutine */ void zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, - integer *, doublecomplex *, doublecomplex *, integer *); - integer lastv; - extern /* Subroutine */ void ztrmv_(char *, char *, char *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *), mecago_(); + integer *, doublecomplex *, doublecomplex *, integer *), + ztrmv_(char *, char *, char *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *), + xerbla_(char *, integer *, ftnlen); + logical storec, storer, storet; /* -- LAPACK auxiliary routine -- */ @@ -449,10 +473,18 @@ f"> */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* ===================================================================== */ -/* Quick return if possible */ + + + + + + + + + +/* Convert our character flags to logical flags for later */ /* Parameter adjustments */ v_dim1 = *ldv; @@ -464,212 +496,635 @@ f"> */ t -= t_offset; /* Function Body */ - if (*n == 0) { + dirf = lsame_(direct, "F"); + dirb = lsame_(direct, "B"); + dirt = lsame_(direct, "T"); + storec = lsame_(storev, "C"); + storer = lsame_(storev, "R"); + storet = lsame_(storev, "T"); + +/* Error handling for our character flags */ + + info = 0; + if (! (dirf || dirb || dirt)) { + +/* DIRECT holds an illegal value */ + + info = 1; + } else if (! (storec || storer || storet)) { + +/* STOREV holds an illegal value */ + + info = 2; + } else if (dirb && storet) { + +/* This case is purposefully not implemented, but any other value for */ +/* STOREV is valid, so we report STOREV as the invalid input */ + + info = 2; + } else if (dirt && storec) { + +/* This case is purposefully not implemented, but any other value for */ +/* DIRECT is valid, so we report DIRECT as the invalid input */ + + info = 1; + } else if (dirt && storet) { + +/* This case is purposefully not implemented, and is ambiguous what */ +/* the user wants to do, so we arbitrarily say DIRECT is the incorrect */ +/* character flag. */ + + info = 1; + } + if (info != 0) { + xerbla_("ZLARFT_LVL2", &info, (ftnlen)11); + return; + } + +/* Quick return if possible */ + + if (*n == 0 || *k == 0) { return; } - if (lsame_(direct, "F")) { - prevlastv = *n; +/* Now we determine what factorization our flags are associated with */ + +/* QR happens when we have forward direction in column storage */ + + qr = dirf && storec; + +/* LQT happens when we have forward direction in row storage and want to compute the transpose of */ +/* the T we would normally compute */ + + lqt = dirf && storet; + +/* LQ happens when we have forward direction in row storage and want to compute the T we would */ +/* normally compute */ + + lq = dirf && storer; + +/* QL happens when we have backward direction in column storage */ + + ql = dirb && storec; + +/* RQT happens when we have backward direction in row storage and want to compute the transpose */ +/* of the T we would normally compute */ + + rqt = dirt && storer; + +/* RQ happens when we have backward direction in row storage and want to compute the T that we */ +/* would normally compute */ + + rq = dirb && storer; + if (*n == 1 || *k == 1) { + if (lqt || rqt) { + i__1 = t_dim1 + 1; + d_cnjg(&z__1, &tau[1]); + t[i__1].r = z__1.r, t[i__1].i = z__1.i; + } else { + i__1 = t_dim1 + 1; + t[i__1].r = tau[1].r, t[i__1].i = tau[1].i; + } + return; + } + if (qr) { + +/* Break V into 9 components */ + +/* V = |-----------------------| */ +/* |V_{1,1} 0 0 | i-1 */ +/* |V_{2,1} V_{2,2} 0 | 1 */ +/* |V_{3,1} V_{3,2} V_{3,3}| n-i */ +/* |-----------------------| */ +/* i-1 1 k-i */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{3,3} and repeat until we */ +/* reach the end. On each iteration V_{3,3} is not referenced */ + +/* We will construct T one column at a time from left to right */ +/* after initializing T(1,1) = TAU(1) */ + +/* T = |-------------------------| */ +/* | T_{1,1} T_{1,2} T_{1,3} | i-1 */ +/* | 0 T_{2,2} T_{2,3} | 1 */ +/* | 0 0 T_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 k-i */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{1,2} and T_{2,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On */ +/* each iteration, T_{1:3,3} are not referenced. See zlarft.f */ +/* for details on how these formulae were constructed. */ + +/* We now get */ + +/* T_{1,2} = -T_{1,1}[V_{1,1}\\V_{2,1}\\V_{3,1}]' */ +/* [0\\V_{2,2}\\V_{3,2}]T_{2,2} */ + +/* T_{1,2} = -T_{1,1}(V_{2,1}' + V_{3,1}'V_{3,2})T_{2,2} */ + +/* This means we will do the following */ + +/* T_{1,2} = -V_{2,1}'T_{2,2} = -\tau_{i}V_{2,1}' */ +/* T_{1,2} = -\tau_{i}V_{3,2}' V_{3,1} + T_{1,2} */ +/* T_{1,2} = T_{1,1}T_{1,2} */ +/* T_{2,2} = \tau{i} */ + + i__1 = t_dim1 + 1; + t[i__1].r = tau[1].r, t[i__1].i = tau[1].i; i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - prevlastv = f2cmax(prevlastv,i__); - i__2 = i__; - if (tau[i__2].r == 0. && tau[i__2].i == 0.) { - -/* H(i) = I */ - - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - i__3 = j + i__ * t_dim1; - t[i__3].r = 0., t[i__3].i = 0.; - } - } else { - -/* general case */ - - if (lsame_(storev, "C")) { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - i__3 = lastv + i__ * v_dim1; - if (v[i__3].r != 0. || v[i__3].i != 0.) { - myexit_(); - } - } - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - i__3 = j + i__ * t_dim1; - i__4 = i__; - z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; - d_cnjg(&z__3, &v[i__ + j * v_dim1]); - z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = - z__2.r * z__3.i + z__2.i * z__3.r; - t[i__3].r = z__1.r, t[i__3].i = z__1.i; - } - j = f2cmin(lastv,prevlastv); - -/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) */ - - i__2 = j - i__; - i__3 = i__ - 1; - i__4 = i__; - z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; - zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &v[i__ - + 1 + v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], & - c__1, &c_b1, &t[i__ * t_dim1 + 1], &c__1); - } else { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - i__3 = i__ + lastv * v_dim1; - if (v[i__3].r != 0. || v[i__3].i != 0.) { - myexit_(); - } - } - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - i__3 = j + i__ * t_dim1; - i__4 = i__; - z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; - i__5 = j + i__ * v_dim1; - z__1.r = z__2.r * v[i__5].r - z__2.i * v[i__5].i, - z__1.i = z__2.r * v[i__5].i + z__2.i * v[i__5] - .r; - t[i__3].r = z__1.r, t[i__3].i = z__1.i; - } - j = f2cmin(lastv,prevlastv); - -/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H */ - - i__2 = i__ - 1; - i__3 = j - i__; - i__4 = i__; - z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; - zgemm_("N", "C", &i__2, &c__1, &i__3, &z__1, &v[(i__ + 1) - * v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], - ldv, &c_b1, &t[i__ * t_dim1 + 1], ldt); - } - -/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ - - i__2 = i__ - 1; - ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ - t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); - i__2 = i__ + i__ * t_dim1; - i__3 = i__; - t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; - if (i__ > 1) { - prevlastv = f2cmax(prevlastv,lastv); - } else { - prevlastv = lastv; - } + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T_{1,2} = -V_{2,1}'V_{2,2}T_{2,2} = -\tau_i V_{2,1}' */ +/* We must do this at copy time as otherwise gemv will do nothing */ +/* on the last column when n=k, but we neet to make sure we are */ +/* scaled by this value */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + i__4 = i__; + z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; + d_cnjg(&z__3, &v[i__ + j * v_dim1]); + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * + z__3.i + z__2.i * z__3.r; + t[i__3].r = z__1.r, t[i__3].i = z__1.i; } + +/* T_{1,2} = -V_{3,1}'V_{3,2}T_{2,2} + T_{1,2} */ +/* = -\tau{i} V_{3,2}'V_{3,1} + T_{1,2} */ + + i__2 = *n - i__; + i__3 = i__ - 1; + i__4 = i__; + z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; + zgemv_("Conjugate Transpose", &i__2, &i__3, &z__1, &v[i__ + 1 + + v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, &c_b1, & + t[i__ * t_dim1 + 1], &c__1); + +/* T_{1,2} = T_{1,1}T_{1,2} */ + + i__2 = i__ - 1; + ztrmv_("Upper", "No Transpose", "Non-unit", &i__2, &t[t_offset], + ldt, &t[i__ * t_dim1 + 1], &c__1); + +/* T_{2,2} = \tau{i} */ + + i__2 = i__ + i__ * t_dim1; + i__3 = i__; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; } - } else { - prevlastv = 1; - for (i__ = *k; i__ >= 1; --i__) { - i__1 = i__; - if (tau[i__1].r == 0. && tau[i__1].i == 0.) { - -/* H(i) = I */ - - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - i__2 = j + i__ * t_dim1; - t[i__2].r = 0., t[i__2].i = 0.; - } - } else { - -/* general case */ - - if (i__ < *k) { - if (lsame_(storev, "C")) { -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - i__2 = lastv + i__ * v_dim1; - if (v[i__2].r != 0. || v[i__2].i != 0.) { - myexit_(); - } - } - i__1 = *k; - for (j = i__ + 1; j <= i__1; ++j) { - i__2 = j + i__ * t_dim1; - i__3 = i__; - z__2.r = -tau[i__3].r, z__2.i = -tau[i__3].i; - d_cnjg(&z__3, &v[*n - *k + i__ + j * v_dim1]); - z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, - z__1.i = z__2.r * z__3.i + z__2.i * - z__3.r; - t[i__2].r = z__1.r, t[i__2].i = z__1.i; - } - j = f2cmax(lastv,prevlastv); - -/* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) */ - - i__1 = *n - *k + i__ - j; - i__2 = *k - i__; - i__3 = i__; - z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; - zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &v[ - j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * - v_dim1], &c__1, &c_b1, &t[i__ + 1 + i__ * - t_dim1], &c__1); - } else { -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - i__2 = i__ + lastv * v_dim1; - if (v[i__2].r != 0. || v[i__2].i != 0.) { - myexit_(); - } - } - i__1 = *k; - for (j = i__ + 1; j <= i__1; ++j) { - i__2 = j + i__ * t_dim1; - i__3 = i__; - z__2.r = -tau[i__3].r, z__2.i = -tau[i__3].i; - i__4 = j + (*n - *k + i__) * v_dim1; - z__1.r = z__2.r * v[i__4].r - z__2.i * v[i__4].i, - z__1.i = z__2.r * v[i__4].i + z__2.i * v[ - i__4].r; - t[i__2].r = z__1.r, t[i__2].i = z__1.i; - } - j = f2cmax(lastv,prevlastv); - -/* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H */ - - i__1 = *k - i__; - i__2 = *n - *k + i__ - j; - i__3 = i__; - z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; - zgemm_("N", "C", &i__1, &c__1, &i__2, &z__1, &v[i__ + - 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], - ldv, &c_b1, &t[i__ + 1 + i__ * t_dim1], ldt); - } - -/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ - - i__1 = *k - i__; - ztrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ - + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * - t_dim1], &c__1) - ; - if (i__ > 1) { - prevlastv = f2cmin(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - i__1 = i__ + i__ * t_dim1; - i__2 = i__; - t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; + } else if (lq) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} V_{1,2} V_{1,3} | i-1 */ +/* | 0 V_{2,2} V_{2,3} | 1 */ +/* | 0 0 V_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 n-i */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{3,3} and repeat until we */ +/* reach the end. On each iteration V_{3,3} is not referenced */ + +/* We will construct T one column at a time from left to right */ +/* after initializing T(1,1) = TAU(1) */ + +/* T = |-------------------------| */ +/* | T_{1,1} T_{1,2} T_{1,3} | i-1 */ +/* | 0 T_{2,2} T_{2,3} | 1 */ +/* | 0 0 T_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 k-i */ + +/* Similarly as above, we will construct T_{1,2} and T_{2,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On */ +/* each iteration, T_{1:3,3} are not referenced. See zlarft.f */ +/* for details on how these formulae were constructed. */ + +/* We now get */ + +/* T_{1,2} = -T_{1,1}[V_{1,1} V_{1,2} V_{1,3}][ 0 V_{2,2} V_{2,3} ]'T_{2,2} */ + +/* T_{1,2} = -T_{1,1}(V_{1,2} + V_{1,3}V_{2,3}')T_{2,2} */ + +/* This means we will do the following */ + +/* T_{1,2} = -V_{1,2}T_{2,2} = -\tau_{i}V_{1,2} */ +/* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} */ +/* T_{1,2} = T_{1,1}T_{1,2} */ +/* T_{2,2} = \tau{i} */ + + i__1 = t_dim1 + 1; + t[i__1].r = tau[1].r, t[i__1].i = tau[1].i; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T_{1,2} = -\tau_{i}V_{1,2} */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + i__4 = i__; + z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; + i__5 = j + i__ * v_dim1; + z__1.r = z__2.r * v[i__5].r - z__2.i * v[i__5].i, z__1.i = + z__2.r * v[i__5].i + z__2.i * v[i__5].r; + t[i__3].r = z__1.r, t[i__3].i = z__1.i; } + +/* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + i__4 = i__; + z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; + zgemm_("No Transpose", "Conjugate Transpose", &i__2, &c__1, &i__3, + &z__1, &v[(i__ + 1) * v_dim1 + 1], ldv, &v[i__ + (i__ + + 1) * v_dim1], ldv, &c_b1, &t[i__ * t_dim1 + 1], ldt); + +/* T_{1,2} = T_{1,1}T_{1,2} */ + + i__2 = i__ - 1; + ztrmv_("Upper", "No Transpose", "Non-unit", &i__2, &t[t_offset], + ldt, &t[i__ * t_dim1 + 1], &c__1); + +/* T_{2,2} = \tau{i} */ + + i__2 = i__ + i__ * t_dim1; + i__3 = i__; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; } - } - return; + } else if (lqt) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} V_{1,2} V_{1,3} | i-1 */ +/* | 0 V_{2,2} V_{2,3} | 1 */ +/* | 0 0 V_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 n-i */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{3,3} and repeat until we */ +/* reach the end. On each iteration V_{3,3} is not referenced */ + +/* We will construct T one column at a time from left to right */ +/* after initializing T(1,1) = TAU(1) */ + +/* T = |-------------------------| */ +/* | T_{1,1} 0 0 | i-1 */ +/* | T_{2,1} T_{2,2} 0 | 1 */ +/* | T_{3,1} T_{3,2} T_{3,3} | k-i */ +/* |-------------------------| */ +/* i-1 1 k-i */ + +/* Similarly as above, we will construct T_{2,1} and T_{2,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{3,1:3}. On */ +/* each iteration, T_{3,1:3} are not referenced. See zlarft.f */ +/* for details on how these formulae were constructed. */ + +/* We now get */ + +/* T_{2,1} = -T_{2,2}[0 V_{2,2} V_{2,3}][V_{1,1} V_{1,2} V_{1,3}]'T_{1,1} */ + +/* T_{2,1} = -T_{2,2}(V_{1,2}' + V_{2,3}V_{1,3}')T_{1,1} */ + +/* This means we will do the following */ + +/* T_{2,1} = -T_{2,2}V_{1,2}' = -\tau_{i}V_{1,2}' */ +/* T_{2,1} = -\tau_{i}V_{1,3}V_{2,3}' + T_{2,1} */ +/* T_{2,1} = T_{1,1}'T_{2,1} */ +/* T_{2,2} = \tau{i} */ + + i__1 = t_dim1 + 1; + d_cnjg(&z__1, &tau[1]); + t[i__1].r = z__1.r, t[i__1].i = z__1.i; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T_{2,1} = -\tau_{i}V_{1,2}' */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * t_dim1; + i__4 = i__; + i__5 = j + i__ * v_dim1; + z__3.r = tau[i__4].r * v[i__5].r - tau[i__4].i * v[i__5].i, + z__3.i = tau[i__4].r * v[i__5].i + tau[i__4].i * v[ + i__5].r; + d_cnjg(&z__2, &z__3); + z__1.r = -z__2.r, z__1.i = -z__2.i; + t[i__3].r = z__1.r, t[i__3].i = z__1.i; + } + +/* T_{2,1} = -\tau_{i}V_{2,3}V_{1,3}' + T_{2,1} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + d_cnjg(&z__2, &tau[i__]); + z__1.r = -z__2.r, z__1.i = -z__2.i; + zgemm_("No Transpose", "Conjugate Transpose", &c__1, &i__2, &i__3, + &z__1, &v[i__ + (i__ + 1) * v_dim1], ldv, &v[(i__ + 1) * + v_dim1 + 1], ldv, &c_b1, &t[i__ + t_dim1], ldt); + +/* T_{2,1} = T_{1,1}'T_{2,1} */ + + i__2 = i__ - 1; + ztrmv_("Lower", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt, + &t[i__ + t_dim1], ldt); + i__2 = i__ + i__ * t_dim1; + d_cnjg(&z__1, &tau[i__]); + t[i__2].r = z__1.r, t[i__2].i = z__1.i; + } + } else if (ql) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} V_{1,2} V_{1,3} | n-i */ +/* | 0 V_{2,2} V_{2,3} | 1 */ +/* | 0 0 V_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{1,1} and repeat until we */ +/* reach the end. On each iteration V_{1,1} is not referenced */ + +/* We will construct T one column at a time from right to left */ +/* after initializing T(K,K) = TAU(K) */ + +/* T = |-------------------------| */ +/* | T_{1,1} 0 0 | k-i */ +/* | T_{2,1} T_{2,2} 0 | 1 */ +/* | T_{3,1} T_{3,2} T_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{2,2} and T_{3,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On */ +/* each iteration, T_{1:3,1} are not referenced. See zlarft.f */ +/* for details on how these formulae were constructed. */ + +/* We get that */ + +/* T_{3,2} = -T_{3,3}[V_{1,3}\\V_{2,3}\\V_{3,3}]' */ +/* [V_{1,2}\\V_{2,2}\\0]T_{2,2} */ + +/* T_{3,2} = -T_{3,3}(V_{1,3}'V_{1,2} + V_{2,3}')T_{2,2} */ + +/* Thus, we will compute */ + +/* T_{2,2} = \tau_{k-i+1} */ +/* T_{3,2} = -T_{3,3}V_{3,2}' = -\tau_{k-i+1}V_{3,2}' */ +/* T_{3,2} = -\tau_{k-i+1}V_{1,3}'V_{1,2} + T_{3,2} */ +/* T_{3,2} = T_{3,3}T_{3,2} */ + + i__1 = *k + *k * t_dim1; + i__2 = *k; + t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + kmi = *k - i__ + 1; + nmi = *n - i__ + 1; + +/* T_{2,2} = \tau(k-i+1) */ + + i__2 = kmi + kmi * t_dim1; + i__3 = kmi; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + +/* T_{3,2} = -\tau(k-i+1)V_{2,3}' */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = kmi + j + kmi * t_dim1; + i__4 = kmi; + z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; + d_cnjg(&z__3, &v[nmi + (kmi + j) * v_dim1]); + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * + z__3.i + z__2.i * z__3.r; + t[i__3].r = z__1.r, t[i__3].i = z__1.i; + } + +/* T_{3,2} = -\tau(k-i+1)V_{1,3}'V_{1,2} + T_{3,2} */ + + i__2 = *n - i__; + i__3 = i__ - 1; + i__4 = kmi; + z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; + zgemv_("Conjugate Transpose", &i__2, &i__3, &z__1, &v[(kmi + 1) * + v_dim1 + 1], ldv, &v[kmi * v_dim1 + 1], &c__1, &c_b1, &t[ + kmi + 1 + kmi * t_dim1], &c__1); + +/* T_{3,2} = T_{3,3}T_{3,2} */ -/* End of ZLARFT_LVL2 */ + i__2 = i__ - 1; + ztrmv_("Lower", "No Transpose", "Non-unit", &i__2, &t[kmi + 1 + ( + kmi + 1) * t_dim1], ldt, &t[kmi + 1 + kmi * t_dim1], & + c__1); + } + } else if (rq) { + +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} 0 0 | k-i */ +/* | V_{2,1} V_{2,2} 0 | 1 */ +/* | V_{3,1} V_{3,2} V_{3,3} | i-1 */ +/* |-------------------------| */ +/* n-i 1 i-1 */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{1,1} and repeat until we */ +/* reach the end. On each iteration V_{1,1} is not referenced */ + +/* We will construct T one column at a time from right to left */ +/* after initializing T(K,K) = TAU(K) */ + +/* T = |-------------------------| */ +/* | T_{1,1} 0 0 | k-i */ +/* | T_{2,1} T_{2,2} 0 | 1 */ +/* | T_{3,1} T_{3,2} T_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{2,2} and T_{3,2} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On */ +/* each iteration, T_{1:3,1} are not referenced. See zlarft.f */ +/* for details on how these formulae were constructed. */ + +/* We get that */ + +/* T_{3,2} = -T_{3,3}[V_{3,1} V_{3,2} V_{3,3}][V_{2,1} V_{2,2} 0]'T_{2,2} */ + +/* T_{3,2} = -T_{3,3}(V_{3,1}V_{2,1}' + V_{3,2})T_{2,2} */ + +/* Thus, we will compute */ + +/* T_{2,2} = \tau_{k-i+1} */ +/* T_{3,2} = -\tau_{k-i+1}V_{3,2} */ +/* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} */ +/* T_{3,2} = T_{3,3}T_{3,2} */ + + i__1 = *k + *k * t_dim1; + i__2 = *k; + t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + kmi = *k - i__ + 1; + nmi = *n - i__ + 1; + +/* T_{2,2} = \tau_{k-i+1} */ + + i__2 = kmi + kmi * t_dim1; + i__3 = kmi; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + +/* T_{3,2} = -\tau_{k-i+1}V_{3,2} */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = kmi + j + kmi * t_dim1; + i__4 = kmi; + z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; + i__5 = kmi + j + nmi * v_dim1; + z__1.r = z__2.r * v[i__5].r - z__2.i * v[i__5].i, z__1.i = + z__2.r * v[i__5].i + z__2.i * v[i__5].r; + t[i__3].r = z__1.r, t[i__3].i = z__1.i; + } + +/* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + i__4 = kmi; + z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; + zgemm_("No Transpose", "Conjugate Transpose", &i__2, &c__1, &i__3, + &z__1, &v[kmi + 1 + v_dim1], ldv, &v[kmi + v_dim1], ldv, + &c_b1, &t[kmi + 1 + kmi * t_dim1], ldt); + +/* T_{3,2} = T_{3,3}T_{3,2} */ + + i__2 = i__ - 1; + ztrmv_("Lower", "No Transpose", "Non-unit", &i__2, &t[kmi + 1 + ( + kmi + 1) * t_dim1], ldt, &t[kmi + 1 + kmi * t_dim1], & + c__1); + } + } else if (rqt) { +/* Break V into 9 components */ + +/* V = |-------------------------| */ +/* | V_{1,1} 0 0 | k-i */ +/* | V_{2,1} V_{2,2} 0 | 1 */ +/* | V_{3,1} V_{3,2} V_{3,3} | i-1 */ +/* |-------------------------| */ +/* n-i 1 i-1 */ + +/* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular */ + +/* This is how we are going to view the matrix V at each step */ +/* i=2,\dots,k, then we grow into V_{1,1} and repeat until we */ +/* reach the end. On each iteration V_{1,1} is not referenced */ + +/* We will construct T one column at a time from right to left */ +/* after initializing T(K,K) = TAU(K) */ + +/* T = |-------------------------| */ +/* | T_{1,1} T_{1,2} T_{1,3} | k-i */ +/* | 0 T_{2,2} T_{2,3} | 1 */ +/* | 0 0 T_{3,3} | i-1 */ +/* |-------------------------| */ +/* k-i 1 i-1 */ + +/* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular */ + +/* Similarly as above, we will construct T_{2,2} and T_{2,3} at */ +/* each iteration i = 2, \dots k, and then grow into T_{1,1:3}. On */ +/* each iteration, T_{1,1:3} are not referenced. See zlarft.f */ +/* for details on how these formulae were constructed. */ + +/* We get that */ + +/* T_{2,3} = -T_{2,2}[V_{2,1} V_{2,2} 0][V_{3,1} V_{3,2} V_{3,3}]'T_{3,3} */ + +/* T_{3,2} = -T_{2,2}(V_{2,1}V_{3,1}' + V_{3,2}')T_{3,3} */ + +/* Thus, we will compute */ + +/* T_{2,2} = \tau_{k-i+1} */ +/* T_{2,3} = -\tau_{k-i+1}V_{3,2}' */ +/* T_{2,3} = -\tau_{k-i+1}V_{2,1}V_{3,1}' + T_{2,3} */ +/* T_{2,3} = T_{3,3}'T_{2,3} */ + + i__1 = *k + *k * t_dim1; + d_cnjg(&z__1, &tau[*k]); + t[i__1].r = z__1.r, t[i__1].i = z__1.i; + i__1 = *k; + for (i__ = 2; i__ <= i__1; ++i__) { + kmi = *k - i__ + 1; + nmi = *n - i__ + 1; + +/* T_{2,2} = \tau_{k-i+1} */ + + i__2 = kmi + kmi * t_dim1; + d_cnjg(&z__1, &tau[kmi]); + t[i__2].r = z__1.r, t[i__2].i = z__1.i; + +/* T_{2,3} = -\tau_{k-i+1}V_{3,2}' */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = kmi + (kmi + j) * t_dim1; + i__4 = kmi; + i__5 = kmi + j + nmi * v_dim1; + z__3.r = tau[i__4].r * v[i__5].r - tau[i__4].i * v[i__5].i, + z__3.i = tau[i__4].r * v[i__5].i + tau[i__4].i * v[ + i__5].r; + d_cnjg(&z__2, &z__3); + z__1.r = -z__2.r, z__1.i = -z__2.i; + t[i__3].r = z__1.r, t[i__3].i = z__1.i; + } + +/* T_{2,3} = -\tau_{k-i+1}V_{2,1}V_{3,1}' + T_{2,3} */ + + i__2 = i__ - 1; + i__3 = *n - i__; + d_cnjg(&z__2, &tau[kmi]); + z__1.r = -z__2.r, z__1.i = -z__2.i; + zgemm_("No Transpose", "Conjugate Transpose", &c__1, &i__2, &i__3, + &z__1, &v[kmi + v_dim1], ldv, &v[kmi + 1 + v_dim1], ldv, + &c_b1, &t[kmi + (kmi + 1) * t_dim1], ldt); + +/* T_{2,3} = T_{3,3}'T_{2,3} */ + + i__2 = i__ - 1; + ztrmv_("Upper", "Transpose", "Non-unit", &i__2, &t[kmi + 1 + (kmi + + 1) * t_dim1], ldt, &t[kmi + (kmi + 1) * t_dim1], ldt); + } + } + return; } /* zlarft_lvl2__ */ diff --git a/lapack-netlib/SRC/zlarft_lvl2.f b/lapack-netlib/SRC/zlarft_lvl2.f index 808c7fdb25..b16350b61d 100644 --- a/lapack-netlib/SRC/zlarft_lvl2.f +++ b/lapack-netlib/SRC/zlarft_lvl2.f @@ -1,18 +1,10 @@ -*> \brief \b ZLARFT_LVL2: Level 2 BLAS version for terminating case of ZLARFT. +*> \brief \b ZLARFT_LVL2 forms the triangular factor T of a block reflector H = I - vtvH * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> Download ZLARFT_LVL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -* * Definition: * =========== * @@ -49,6 +41,9 @@ *> H(i) is stored in the i-th row of the array V, and *> *> H = I - V**H * T * V +*> +*> If DIRECT or STOREV = 'T', see Further Details for the shape of T +*> *> \endverbatim * * Arguments: @@ -61,6 +56,8 @@ *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) +*> = 'T' (with STOREV='R'): H = H(k) . . . H(2) H(1) (backward) +*> but we return the T matrix that is already (conjugate) transposed *> \endverbatim *> *> \param[in] STOREV @@ -68,8 +65,10 @@ *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise +*> = 'C': column-wise +*> = 'R': row-wise +*> = 'T': (With DIRECT='F') Row-wise, but we return the T +*> matrix that is already (conjugate) transposed. *> \endverbatim *> *> \param[in] N @@ -155,6 +154,29 @@ *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) +*> +*> In addition, the shape of T is determined by these same flags as +*> in the below table. +*> 'U' denotes upper triangular +*> 'L' denotes lower triangular +*> 'X' denotes no current implementation +*> We also provide the logical variable that represents the case +*> in the code if it is implemented +*> +*> |-----------------------------------------------------------| +*> | | DIRECT = 'F' | DIRECT = 'B' | DIRECT = 'T' | +*> |--------------+--------------+--------------+--------------| +*> | STOREV = 'C' | U (QR) | L (QL) | X | +*> | STOREV = 'R' | U (LQ) | L (RQ) | U (RQT) | +*> | STOREV = 'T' | L (LQT) | X | X | +*> |-----------------------------------------------------------| +*> +*> Finally, the relationship between the (conjugate) transposed T matrices +*> are as follows: (Note that T_{FC} denotes the T associated with calling +*> this routine with DIRECT = 'F' and STOREV = 'C') +*> +*> T_{TR} = (T_{BR})**H +*> T_{FT} = (T_{FR})**H *> \endverbatim *> * ===================================================================== @@ -170,158 +192,568 @@ SUBROUTINE ZLARFT_LVL2( DIRECT, STOREV, N, K, V, LDV, TAU, INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. +* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) * .. * -* ===================================================================== -* * .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. +* + COMPLEX*16 ONE + PARAMETER(ONE=(1.0D+0,0.0D+0)) +* * .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV -* .. +* + INTEGER I,J,KMI,NMI,INFO + LOGICAL QR, LQ, QL, RQ, LQT, RQT, + $ DIRF, DIRB, DIRT, + $ STOREC, STORER, STORET +* * .. External Subroutines .. - EXTERNAL ZGEMV, ZTRMV, ZGEMM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME +* + EXTERNAL ZTRMV,ZGEMV,ZGEMM,XERBLA +* +* .. External Functions.. +* + LOGICAL LSAME + EXTERNAL LSAME +* +* .. Intrinsic Functions.. +* + INTRINSIC CONJG * .. * .. Executable Statements .. * +* Convert our character flags to logical flags for later +* + DIRF = LSAME(DIRECT,'F') + DIRB = LSAME(DIRECT,'B') + DIRT = LSAME(DIRECT,'T') + STOREC = LSAME(STOREV,'C') + STORER = LSAME(STOREV,'R') + STORET = LSAME(STOREV,'T') +* +* Error handling for our character flags +* + INFO = 0 + IF( .NOT.(DIRF.OR.DIRB.OR.DIRT) ) THEN +* +* DIRECT holds an illegal value +* + INFO = 1 + ELSE IF( .NOT.(STOREC.OR.STORER.OR.STORET) ) THEN +* +* STOREV holds an illegal value +* + INFO = 2 + ELSE IF( DIRB.AND.STORET ) THEN +* +* This case is purposefully not implemented, but any other value for +* STOREV is valid, so we report STOREV as the invalid input +* + INFO = 2 + ELSE IF( DIRT.AND.STOREC ) THEN +* +* This case is purposefully not implemented, but any other value for +* DIRECT is valid, so we report DIRECT as the invalid input +* + INFO = 1 + ELSE IF( DIRT.AND.STORET ) THEN +* +* This case is purposefully not implemented, and is ambiguous what +* the user wants to do, so we arbitrarily say DIRECT is the incorrect +* character flag. +* + INFO = 1 + END IF + + IF( INFO.NE.0 ) THEN + CALL XERBLA('ZLARFT_LVL2', INFO) + RETURN + END IF +* * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO I = 1, K - PREVLASTV = MAX( PREVLASTV, I ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = 1, I - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * CONJG( V( I , J ) ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) -* - CALL ZGEMV( 'Conjugate transpose', J-I, I-1, - $ -TAU( I ), V( I+1, 1 ), LDV, - $ V( I+1, I ), 1, ONE, T( 1, I ), 1 ) - ELSE -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( J , I ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H -* - CALL ZGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, - $ ONE, T( 1, I ), LDT ) - END IF -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF + IF(N.EQ.0.OR.K.EQ.0) THEN + RETURN + END IF +* +* Now we determine what factorization our flags are associated with +* +* QR happens when we have forward direction in column storage +* + QR = DIRF.AND.STOREC +* +* LQT happens when we have forward direction in row storage and want to compute the transpose of +* the T we would normally compute +* + LQT = DIRF.AND.STORET +* +* LQ happens when we have forward direction in row storage and want to compute the T we would +* normally compute +* + LQ = DIRF.AND.STORER +* +* QL happens when we have backward direction in column storage +* + QL = DIRB.AND.STOREC +* +* RQT happens when we have backward direction in row storage and want to compute the transpose +* of the T we would normally compute +* + RQT = DIRT.AND.STORER +* +* RQ happens when we have backward direction in row storage and want to compute the T that we +* would normally compute +* + RQ = DIRB.AND.STORER + IF( N.EQ.1.OR.K.EQ.1) THEN + IF( LQT.OR.RQT ) THEN + T(1,1) = CONJG(TAU(1)) + ELSE + T(1,1) = TAU(1) + END IF + RETURN + END IF + IF (QR) THEN +* +* Break V into 9 components +* +* V = |-----------------------| +* |V_{1,1} 0 0 | i-1 +* |V_{2,1} V_{2,2} 0 | 1 +* |V_{3,1} V_{3,2} V_{3,3}| n-i +* |-----------------------| +* i-1 1 k-i +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{3,3} and repeat until we +* reach the end. On each iteration V_{3,3} is not referenced +* +* We will construct T one column at a time from left to right +* after initializing T(1,1) = TAU(1) +* +* T = |-------------------------| +* | T_{1,1} T_{1,2} T_{1,3} | i-1 +* | 0 T_{2,2} T_{2,3} | 1 +* | 0 0 T_{3,3} | k-i +* |-------------------------| +* i-1 1 k-i +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{1,2} and T_{2,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On +* each iteration, T_{1:3,3} are not referenced. See zlarft.f +* for details on how these formulae were constructed. +* +* We now get +* +* T_{1,2} = -T_{1,1}[V_{1,1}\\V_{2,1}\\V_{3,1}]' +* [0\\V_{2,2}\\V_{3,2}]T_{2,2} +* +* T_{1,2} = -T_{1,1}(V_{2,1}' + V_{3,1}'V_{3,2})T_{2,2} +* +* This means we will do the following +* +* T_{1,2} = -V_{2,1}'T_{2,2} = -\tau_{i}V_{2,1}' +* T_{1,2} = -\tau_{i}V_{3,2}' V_{3,1} + T_{1,2} +* T_{1,2} = T_{1,1}T_{1,2} +* T_{2,2} = \tau{i} +* + T(1,1) = TAU(1) + + DO I = 2, K +* +* T_{1,2} = -V_{2,1}'V_{2,2}T_{2,2} = -\tau_i V_{2,1}' +* We must do this at copy time as otherwise gemv will do nothing +* on the last column when n=k, but we neet to make sure we are +* scaled by this value +* + DO J = 1, I-1 + T(J,I) = -TAU(I)*CONJG(V(I,J)) + END DO + +* +* T_{1,2} = -V_{3,1}'V_{3,2}T_{2,2} + T_{1,2} +* = -\tau{i} V_{3,2}'V_{3,1} + T_{1,2} +* + CALL ZGEMV('Conjugate Transpose', N-I, I-1, -TAU(I), + $ V(I+1,1), LDV, V(I+1,I), 1, ONE, T(1, I), 1) + + +* +* T_{1,2} = T_{1,1}T_{1,2} +* + CALL ZTRMV('Upper', 'No Transpose', 'Non-unit', I-1, + $ T, LDT, T(1,I), 1) + +* +* T_{2,2} = \tau{i} +* + T(I,I) = TAU(I) END DO - ELSE - PREVLASTV = 1 - DO I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = I, K - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) -* - CALL ZGEMV( 'Conjugate transpose', N-K+I-J, K-I, - $ -TAU( I ), V( J, I+1 ), LDV, V( J, I ), - $ 1, ONE, T( I+1, I ), 1 ) - ELSE -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H -* - CALL ZGEMM( 'N', 'C', K-I, 1, N-K+I-J, - $ -TAU( I ), - $ V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), LDT ) - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', - $ K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF + ELSE IF (LQ) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} V_{1,2} V_{1,3} | i-1 +* | 0 V_{2,2} V_{2,3} | 1 +* | 0 0 V_{3,3} | k-i +* |-------------------------| +* i-1 1 n-i +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{3,3} and repeat until we +* reach the end. On each iteration V_{3,3} is not referenced +* +* We will construct T one column at a time from left to right +* after initializing T(1,1) = TAU(1) +* +* T = |-------------------------| +* | T_{1,1} T_{1,2} T_{1,3} | i-1 +* | 0 T_{2,2} T_{2,3} | 1 +* | 0 0 T_{3,3} | k-i +* |-------------------------| +* i-1 1 k-i +* +* Similarly as above, we will construct T_{1,2} and T_{2,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,3}. On +* each iteration, T_{1:3,3} are not referenced. See zlarft.f +* for details on how these formulae were constructed. +* +* We now get +* +* T_{1,2} = -T_{1,1}[V_{1,1} V_{1,2} V_{1,3}][ 0 V_{2,2} V_{2,3} ]'T_{2,2} +* +* T_{1,2} = -T_{1,1}(V_{1,2} + V_{1,3}V_{2,3}')T_{2,2} +* +* This means we will do the following +* +* T_{1,2} = -V_{1,2}T_{2,2} = -\tau_{i}V_{1,2} +* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} +* T_{1,2} = T_{1,1}T_{1,2} +* T_{2,2} = \tau{i} +* + T(1,1) = TAU(1) + + DO I = 2, K +* +* T_{1,2} = -\tau_{i}V_{1,2} +* + DO J = 1, I-1 + T(J, I) = -TAU(I)*V(J, I) + END DO + +* +* T_{1,2} = -\tau_{i}V_{1,3}V_{2,3}' + T_{1,2} +* + CALL ZGEMM('No Transpose', 'Conjugate Transpose', I-1, + $ 1, N-I, -TAU(I), V(1,I+1), LDV, V(I, I+1), LDV, ONE, + $ T(1, I), LDT) +* +* T_{1,2} = T_{1,1}T_{1,2} +* + CALL ZTRMV('Upper', 'No Transpose', 'Non-unit', I-1, + $ T, LDT, T(1,I), 1) + +* +* T_{2,2} = \tau{i} +* + T(I,I) = TAU(I) END DO - END IF - RETURN + ELSE IF (LQT) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} V_{1,2} V_{1,3} | i-1 +* | 0 V_{2,2} V_{2,3} | 1 +* | 0 0 V_{3,3} | k-i +* |-------------------------| +* i-1 1 n-i +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{3,3} and repeat until we +* reach the end. On each iteration V_{3,3} is not referenced +* +* We will construct T one column at a time from left to right +* after initializing T(1,1) = TAU(1) +* +* T = |-------------------------| +* | T_{1,1} 0 0 | i-1 +* | T_{2,1} T_{2,2} 0 | 1 +* | T_{3,1} T_{3,2} T_{3,3} | k-i +* |-------------------------| +* i-1 1 k-i +* +* Similarly as above, we will construct T_{2,1} and T_{2,2} at +* each iteration i = 2, \dots k, and then grow into T_{3,1:3}. On +* each iteration, T_{3,1:3} are not referenced. See zlarft.f +* for details on how these formulae were constructed. +* +* We now get +* +* T_{2,1} = -T_{2,2}[0 V_{2,2} V_{2,3}][V_{1,1} V_{1,2} V_{1,3}]'T_{1,1} +* +* T_{2,1} = -T_{2,2}(V_{1,2}' + V_{2,3}V_{1,3}')T_{1,1} +* +* This means we will do the following +* +* T_{2,1} = -T_{2,2}V_{1,2}' = -\tau_{i}V_{1,2}' +* T_{2,1} = -\tau_{i}V_{1,3}V_{2,3}' + T_{2,1} +* T_{2,1} = T_{1,1}'T_{2,1} +* T_{2,2} = \tau{i} +* + T(1,1) = CONJG(TAU(1)) + + DO I = 2, K +* +* T_{2,1} = -\tau_{i}V_{1,2}' +* + DO J = 1, I-1 + T(I,J) = -CONJG(TAU(I)*V(J,I)) + END DO +* +* T_{2,1} = -\tau_{i}V_{2,3}V_{1,3}' + T_{2,1} +* + CALL ZGEMM('No Transpose', 'Conjugate Transpose', 1, + $ I-1, N-I, -CONJG(TAU(I)), V(I,I+1), LDV, V(1, I+1), + $ LDV, ONE, T(I, 1), LDT) +* +* T_{2,1} = T_{1,1}'T_{2,1} +* + CALL ZTRMV('Lower', 'Transpose', 'Non-unit', + $ I-1, T, LDT, T(I,1), LDT) + + T(I,I) = CONJG(TAU(I)) + END DO + ELSE IF (QL) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} V_{1,2} V_{1,3} | n-i +* | 0 V_{2,2} V_{2,3} | 1 +* | 0 0 V_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit upper triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{1,1} and repeat until we +* reach the end. On each iteration V_{1,1} is not referenced +* +* We will construct T one column at a time from right to left +* after initializing T(K,K) = TAU(K) +* +* T = |-------------------------| +* | T_{1,1} 0 0 | k-i +* | T_{2,1} T_{2,2} 0 | 1 +* | T_{3,1} T_{3,2} T_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{2,2} and T_{3,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On +* each iteration, T_{1:3,1} are not referenced. See zlarft.f +* for details on how these formulae were constructed. +* +* We get that +* +* T_{3,2} = -T_{3,3}[V_{1,3}\\V_{2,3}\\V_{3,3}]' +* [V_{1,2}\\V_{2,2}\\0]T_{2,2} +* +* T_{3,2} = -T_{3,3}(V_{1,3}'V_{1,2} + V_{2,3}')T_{2,2} +* +* Thus, we will compute +* +* T_{2,2} = \tau_{k-i+1} +* T_{3,2} = -T_{3,3}V_{3,2}' = -\tau_{k-i+1}V_{3,2}' +* T_{3,2} = -\tau_{k-i+1}V_{1,3}'V_{1,2} + T_{3,2} +* T_{3,2} = T_{3,3}T_{3,2} +* + T(K,K) = TAU(K) + DO I = 2, K + KMI = K-I+1 + NMI = N-I+1 +* +* T_{2,2} = \tau(k-i+1) +* + T(KMI,KMI) = TAU(KMI) +* +* T_{3,2} = -\tau(k-i+1)V_{2,3}' +* + DO J = 1, I-1 + T(KMI + J, KMI) = -TAU(KMI)*CONJG(V(NMI, KMI + J)) + END DO +* +* T_{3,2} = -\tau(k-i+1)V_{1,3}'V_{1,2} + T_{3,2} +* + CALL ZGEMV('Conjugate Transpose', N-I, I-1, -TAU(KMI), + $ V(1, KMI + 1), LDV, V(1, KMI), 1, ONE, + $ T(KMI+1, KMI), 1) +* +* T_{3,2} = T_{3,3}T_{3,2} +* + CALL ZTRMV('Lower', 'No Transpose', 'Non-unit', I-1, + $ T(KMI + 1, KMI + 1), LDT, T(KMI + 1, KMI), 1) + + END DO + ELSE IF (RQ) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} 0 0 | k-i +* | V_{2,1} V_{2,2} 0 | 1 +* | V_{3,1} V_{3,2} V_{3,3} | i-1 +* |-------------------------| +* n-i 1 i-1 +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{1,1} and repeat until we +* reach the end. On each iteration V_{1,1} is not referenced +* +* We will construct T one column at a time from right to left +* after initializing T(K,K) = TAU(K) +* +* T = |-------------------------| +* | T_{1,1} 0 0 | k-i +* | T_{2,1} T_{2,2} 0 | 1 +* | T_{3,1} T_{3,2} T_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{2,2} and T_{3,2} at +* each iteration i = 2, \dots k, and then grow into T_{1:3,1}. On +* each iteration, T_{1:3,1} are not referenced. See zlarft.f +* for details on how these formulae were constructed. +* +* We get that +* +* T_{3,2} = -T_{3,3}[V_{3,1} V_{3,2} V_{3,3}][V_{2,1} V_{2,2} 0]'T_{2,2} +* +* T_{3,2} = -T_{3,3}(V_{3,1}V_{2,1}' + V_{3,2})T_{2,2} +* +* Thus, we will compute +* +* T_{2,2} = \tau_{k-i+1} +* T_{3,2} = -\tau_{k-i+1}V_{3,2} +* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} +* T_{3,2} = T_{3,3}T_{3,2} +* + T(K,K) = TAU(K) + DO I = 2, K + KMI = K-I+1 + NMI = N-I+1 +* +* T_{2,2} = \tau_{k-i+1} +* + T(KMI,KMI) = TAU(KMI) +* +* T_{3,2} = -\tau_{k-i+1}V_{3,2} +* + DO J = 1, I-1 + T(KMI + J, KMI) = -TAU(KMI)*V(KMI + J, NMI) + END DO +* +* T_{3,2} = -\tau_{k-i+1}V_{3,1}V_{2,1}' + T_{3,2} +* + CALL ZGEMM('No Transpose', 'Conjugate Transpose', I-1, + $ 1, N-I, -TAU(KMI), V(KMI+1, 1), LDV, V(KMI, 1), LDV, + $ ONE, T(KMI+1, KMI), LDT) +* +* T_{3,2} = T_{3,3}T_{3,2} +* + CALL ZTRMV('Lower', 'No Transpose', 'Non-unit', I-1, + $ T(KMI+1, KMI+1), LDT, T(KMI+1, KMI), 1) + END DO + ELSE IF (RQT) THEN +* +* Break V into 9 components +* +* V = |-------------------------| +* | V_{1,1} 0 0 | k-i +* | V_{2,1} V_{2,2} 0 | 1 +* | V_{3,1} V_{3,2} V_{3,3} | i-1 +* |-------------------------| +* n-i 1 i-1 +* +* V_{1,1}, V_{2,2} and V_{3,3} are unit lower triangular +* +* This is how we are going to view the matrix V at each step +* i=2,\dots,k, then we grow into V_{1,1} and repeat until we +* reach the end. On each iteration V_{1,1} is not referenced +* +* We will construct T one column at a time from right to left +* after initializing T(K,K) = TAU(K) +* +* T = |-------------------------| +* | T_{1,1} T_{1,2} T_{1,3} | k-i +* | 0 T_{2,2} T_{2,3} | 1 +* | 0 0 T_{3,3} | i-1 +* |-------------------------| +* k-i 1 i-1 +* +* T_{1,1}, T_{2,2}, and T_{3,3} are non-unit lower triangular +* +* Similarly as above, we will construct T_{2,2} and T_{2,3} at +* each iteration i = 2, \dots k, and then grow into T_{1,1:3}. On +* each iteration, T_{1,1:3} are not referenced. See zlarft.f +* for details on how these formulae were constructed. +* +* We get that +* +* T_{2,3} = -T_{2,2}[V_{2,1} V_{2,2} 0][V_{3,1} V_{3,2} V_{3,3}]'T_{3,3} +* +* T_{3,2} = -T_{2,2}(V_{2,1}V_{3,1}' + V_{3,2}')T_{3,3} * -* End of ZLARFT_LVL2 +* Thus, we will compute * - END +* T_{2,2} = \tau_{k-i+1} +* T_{2,3} = -\tau_{k-i+1}V_{3,2}' +* T_{2,3} = -\tau_{k-i+1}V_{2,1}V_{3,1}' + T_{2,3} +* T_{2,3} = T_{3,3}'T_{2,3} +* + T(K,K) = CONJG(TAU(K)) + DO I = 2, K + KMI = K-I+1 + NMI = N-I+1 +* +* T_{2,2} = \tau_{k-i+1} +* + T(KMI,KMI) = CONJG(TAU(KMI)) +* +* T_{2,3} = -\tau_{k-i+1}V_{3,2}' +* + DO J = 1, I-1 + T(KMI, KMI + J) = -CONJG(TAU(KMI)*V(KMI + J, NMI)) + END DO +* +* T_{2,3} = -\tau_{k-i+1}V_{2,1}V_{3,1}' + T_{2,3} +* + CALL ZGEMM('No Transpose', 'Conjugate Transpose', 1, + $ I-1, N-I, -CONJG(TAU(KMI)), V(KMI, 1), LDV, + $ V(KMI+1,1), LDV, ONE, T(KMI, KMI+1), LDT) +* +* T_{2,3} = T_{3,3}'T_{2,3} +* + CALL ZTRMV('Upper', 'Transpose', 'Non-unit', I-1, + $ T(KMI+1, KMI+1), LDT, T(KMI, KMI+1), LDT) + END DO + END IF + END SUBROUTINE