int CORE_zttlqt(int M, int N, int IB,
PLASMA_Complex64_t *A1, int LDA1,
PLASMA_Complex64_t *A2, int LDA2,
PLASMA_Complex64_t *T, int LDT,
PLASMA_Complex64_t *TAU, PLASMA_Complex64_t *WORK)
{
static PLASMA_Complex64_t zone = 1.0;
static PLASMA_Complex64_t zzero = 0.0;
#ifdef COMPLEX
static int ione = 1;
#endif
PLASMA_Complex64_t alpha;
int i, j, l, ii, sb, mi, ni;
/* Check input arguments */
if (M < 0) {
coreblas_error(1, "Illegal value of M");
return -1;
}
if (N < 0) {
coreblas_error(2, "Illegal value of N");
return -2;
}
if (IB < 0) {
coreblas_error(3, "Illegal value of IB");
return -3;
}
if ((LDA2 < max(1,M)) && (M > 0)) {
coreblas_error(7, "Illegal value of LDA2");
return -7;
}
/* Quick return */
if ((M == 0) || (N == 0) || (IB == 0))
return PLASMA_SUCCESS;
/* TODO: Need to check why some cases require
* this to not have uninitialized values */
CORE_zlaset( PlasmaUpperLower, IB, N,
0., 0., T, LDT);
for(ii = 0; ii < M; ii += IB) {
sb = min(M-ii, IB);
for(i = 0; i < sb; i++) {
j = ii + i;
mi = sb-i-1;
ni = min( j + 1, N);
/*
* Generate elementary reflector H( II*IB+I ) to annihilate A( II*IB+I, II*IB+I:M ).
*/
#ifdef COMPLEX
LAPACKE_zlacgv_work(ni, &A2[j], LDA2);
LAPACKE_zlacgv_work(ione, &A1[LDA1*j+j], LDA1);
#endif
LAPACKE_zlarfg_work(ni+1, &A1[LDA1*j+j], &A2[j], LDA2, &TAU[j]);
if (mi > 0) {
/*
* Apply H( j-1 ) to A( j:II+IB-1, j-1:M ) from the right.
*/
cblas_zcopy(
mi,
&A1[LDA1*j+(j+1)], 1,
WORK, 1);
cblas_zgemv(
CblasColMajor, (CBLAS_TRANSPOSE)PlasmaNoTrans,
mi, ni,
CBLAS_SADDR(zone), &A2[j+1], LDA2,
&A2[j], LDA2,
CBLAS_SADDR(zone), WORK, 1);
alpha = -(TAU[j]);
cblas_zaxpy(
mi, CBLAS_SADDR(alpha),
WORK, 1,
&A1[LDA1*j+j+1], 1);
cblas_zgerc(
CblasColMajor, mi, ni,
CBLAS_SADDR(alpha), WORK, 1,
&A2[j], LDA2,
&A2[j+1], LDA2);
}
/*
* Calculate T.
*/
if (i > 0 ) {
l = min(i, max(0, N-ii));
alpha = -(TAU[j]);
CORE_zpemv(
PlasmaNoTrans, PlasmaRowwise,
i , min(j, N), l,
alpha, &A2[ii], LDA2,
&A2[j], LDA2,
zzero, &T[LDT*j], 1,
WORK);
/* T(0:i-1, j) = T(0:i-1, ii:j-1) * T(0:i-1, j) */
cblas_ztrmv(
CblasColMajor, (CBLAS_UPLO)PlasmaUpper,
(CBLAS_TRANSPOSE)PlasmaNoTrans,
(CBLAS_DIAG)PlasmaNonUnit,
i, &T[LDT*ii], LDT,
&T[LDT*j], 1);
}
#ifdef COMPLEX
LAPACKE_zlacgv_work(ni, &A2[j], LDA2 );
LAPACKE_zlacgv_work(ione, &A1[LDA1*j+j], LDA1 );
#endif
T[LDT*j+i] = TAU[j];
}
/* Apply Q to the rest of the matrix to the right */
if (M > ii+sb) {
mi = M-(ii+sb);
ni = min(ii+sb, N);
l = min(sb, max(0, ni-ii));
CORE_zparfb(
PlasmaRight, PlasmaNoTrans,
PlasmaForward, PlasmaRowwise,
mi, IB, mi, ni, sb, l,
&A1[LDA1*ii+ii+sb], LDA1,
&A2[ii+sb], LDA2,
&A2[ii], LDA2,
&T[LDT*ii], LDT,
WORK, M);
}
}
return PLASMA_SUCCESS;
}
int CORE_ztsqrt(int M, int N, int IB,
PLASMA_Complex64_t *A1, int LDA1,
PLASMA_Complex64_t *A2, int LDA2,
PLASMA_Complex64_t *T, int LDT,
PLASMA_Complex64_t *TAU, PLASMA_Complex64_t *WORK)
{
static PLASMA_Complex64_t zone = 1.0;
static PLASMA_Complex64_t zzero = 0.0;
PLASMA_Complex64_t alpha;
int i, ii, sb;
/* Check input arguments */
if (M < 0) {
coreblas_error(1, "Illegal value of M");
return -1;
}
if (N < 0) {
coreblas_error(2, "Illegal value of N");
return -2;
}
if (IB < 0) {
coreblas_error(3, "Illegal value of IB");
return -3;
}
if ((LDA2 < max(1,M)) && (M > 0)) {
coreblas_error(8, "Illegal value of LDA2");
return -8;
}
/* Quick return */
if ((M == 0) || (N == 0) || (IB == 0))
return PLASMA_SUCCESS;
for(ii = 0; ii < N; ii += IB) {
sb = min(N-ii, IB);
for(i = 0; i < sb; i++) {
/*
* Generate elementary reflector H( II*IB+I ) to annihilate
* A( II*IB+I:M, II*IB+I )
*/
LAPACKE_zlarfg_work(M+1, &A1[LDA1*(ii+i)+ii+i], &A2[LDA2*(ii+i)], 1, &TAU[ii+i]);
if (ii+i+1 < N) {
/*
* Apply H( II*IB+I ) to A( II*IB+I:M, II*IB+I+1:II*IB+IB ) from the left
*/
alpha = -conj(TAU[ii+i]);
cblas_zcopy(
sb-i-1,
&A1[LDA1*(ii+i+1)+(ii+i)], LDA1,
WORK, 1);
#ifdef COMPLEX
LAPACKE_zlacgv_work(sb-i-1, WORK, 1);
#endif
cblas_zgemv(
CblasColMajor, (CBLAS_TRANSPOSE)PlasmaConjTrans,
M, sb-i-1,
CBLAS_SADDR(zone), &A2[LDA2*(ii+i+1)], LDA2,
&A2[LDA2*(ii+i)], 1,
CBLAS_SADDR(zone), WORK, 1);
#ifdef COMPLEX
LAPACKE_zlacgv_work(sb-i-1, WORK, 1 );
#endif
cblas_zaxpy(
sb-i-1, CBLAS_SADDR(alpha),
WORK, 1,
&A1[LDA1*(ii+i+1)+ii+i], LDA1);
#ifdef COMPLEX
LAPACKE_zlacgv_work(sb-i-1, WORK, 1 );
#endif
cblas_zgerc(
CblasColMajor, M, sb-i-1, CBLAS_SADDR(alpha),
&A2[LDA2*(ii+i)], 1,
WORK, 1,
&A2[LDA2*(ii+i+1)], LDA2);
}
/*
* Calculate T
*/
alpha = -TAU[ii+i];
cblas_zgemv(
CblasColMajor, (CBLAS_TRANSPOSE)PlasmaConjTrans, M, i,
CBLAS_SADDR(alpha), &A2[LDA2*ii], LDA2,
&A2[LDA2*(ii+i)], 1,
CBLAS_SADDR(zzero), &T[LDT*(ii+i)], 1);
cblas_ztrmv(
CblasColMajor, (CBLAS_UPLO)PlasmaUpper,
(CBLAS_TRANSPOSE)PlasmaNoTrans, (CBLAS_DIAG)PlasmaNonUnit, i,
&T[LDT*ii], LDT,
&T[LDT*(ii+i)], 1);
T[LDT*(ii+i)+i] = TAU[ii+i];
}
if (N > ii+sb) {
CORE_ztsmqr(
PlasmaLeft, PlasmaConjTrans,
sb, N-(ii+sb), M, N-(ii+sb), IB, IB,
&A1[LDA1*(ii+sb)+ii], LDA1,
&A2[LDA2*(ii+sb)], LDA2,
&A2[LDA2*ii], LDA2,
&T[LDT*ii], LDT,
WORK, sb);
}
}
return PLASMA_SUCCESS;
}
int CORE_zttqrt(int M, int N, int IB,
PLASMA_Complex64_t *A1, int LDA1,
PLASMA_Complex64_t *A2, int LDA2,
PLASMA_Complex64_t *T, int LDT,
PLASMA_Complex64_t *TAU, PLASMA_Complex64_t *WORK)
{
static PLASMA_Complex64_t zone = 1.0;
static PLASMA_Complex64_t zzero = 0.0;
static int ione = 1;
PLASMA_Complex64_t alpha;
int i, j, ii, sb, mi, ni;
/* Check input arguments */
if (M < 0) {
coreblas_error(1, "Illegal value of M");
return -1;
}
if (N < 0) {
coreblas_error(2, "Illegal value of N");
return -2;
}
if (IB < 0) {
coreblas_error(3, "Illegal value of IB");
return -3;
}
if ((LDA2 < max(1,M)) && (M > 0)) {
coreblas_error(7, "Illegal value of LDA2");
return -7;
}
/* Quick return */
if ((M == 0) || (N == 0) || (IB == 0))
return PLASMA_SUCCESS;
for(ii = 0; ii < N; ii += IB) {
sb = min(N-ii, IB);
for(i = 0; i < sb; i++) {
/*
* Generate elementary reflector H( II*IB+I ) to annihilate
* A( II*IB+I:mi, II*IB+I ).
*/
mi = ii + i + 1;
LAPACKE_zlarfg_work(mi+1, &A1[LDA1*(ii+i)+ii+i], &A2[LDA2*(ii+i)], ione, &TAU[ii+i]);
if (sb-i-1>0) {
/*
* Apply H( II*IB+I ) to A( II*IB+I:M, II*IB+I+1:II*IB+IB ) from the left.
*/
ni = sb-i-1;
cblas_zcopy(
ni,
&A1[LDA1*(ii+i+1)+(ii+i)], LDA1,
WORK, 1);
#ifdef COMPLEX
LAPACKE_zlacgv_work(ni, WORK, ione);
#endif
cblas_zgemv(
CblasColMajor, (CBLAS_TRANSPOSE)PlasmaConjTrans,
mi, ni,
CBLAS_SADDR(zone), &A2[LDA2*(ii+i+1)], LDA2,
&A2[LDA2*(ii+i)], 1,
CBLAS_SADDR(zone), WORK, 1);
#ifdef COMPLEX
LAPACKE_zlacgv_work(ni, WORK, ione);
#endif
alpha = -conj(TAU[ii+i]);
cblas_zaxpy(
ni, CBLAS_SADDR(alpha),
WORK, 1,
&A1[LDA1*(ii+i+1)+ii+i], LDA1);
#ifdef COMPLEX
LAPACKE_zlacgv_work(ni, WORK, ione);
#endif
cblas_zgerc(
CblasColMajor, mi, ni,
CBLAS_SADDR(alpha), &A2[LDA2*(ii+i)], 1,
WORK, 1,
&A2[LDA2*(ii+i+1)], LDA2);
}
/*
* Calculate T.
*/
if (i > 0 ) {
cblas_zcopy(i, &A2[LDA2*(ii+i)+ii], 1, &WORK[ii], 1);
cblas_ztrmv(
CblasColMajor, (CBLAS_UPLO)PlasmaUpper,
(CBLAS_TRANSPOSE)PlasmaConjTrans, (CBLAS_DIAG)PlasmaNonUnit,
i, &A2[LDA2*ii+ii], LDA2,
&WORK[ii], 1);
alpha = -(TAU[ii+i]);
for(j = 0; j < i; j++) {
WORK[ii+j] = alpha * WORK[ii+j];
}
if (ii > 0) {
cblas_zgemv(
CblasColMajor, (CBLAS_TRANSPOSE)PlasmaConjTrans, ii, i,
CBLAS_SADDR(alpha), &A2[LDA2*ii], LDA2,
&A2[LDA2*(ii+i)], 1,
CBLAS_SADDR(zzero), WORK, 1);
cblas_zaxpy(i, CBLAS_SADDR(zone), &WORK[ii], 1, WORK, 1);
}
cblas_zcopy(i, WORK, 1, &T[LDT*(ii+i)], 1);
cblas_ztrmv(
CblasColMajor, (CBLAS_UPLO)PlasmaUpper,
(CBLAS_TRANSPOSE)PlasmaNoTrans, (CBLAS_DIAG)PlasmaNonUnit,
i, &T[LDT*ii], LDT,
&T[LDT*(ii+i)], 1);
}
T[LDT*(ii+i)+i] = TAU[ii+i];
}
/* Apply Q' to the rest of the matrix to the left */
if (N > ii+sb) {
CORE_zttrfb(
PlasmaLeft, PlasmaConjTrans,
PlasmaForward, PlasmaColumnwise,
sb, N-(ii+sb), ii+sb, N-(ii+sb), sb,
&A1[LDA1*(ii+sb)+ii], LDA1,
&A2[LDA2*(ii+sb)], LDA2,
&A2[LDA2*ii], LDA2,
&T[LDT*ii], LDT,
WORK, sb);
}
}
return PLASMA_SUCCESS;
}
int CORE_zherfb( PLASMA_enum uplo, int n,
int k, int ib, int nb,
PLASMA_Complex64_t *A, int lda,
PLASMA_Complex64_t *T, int ldt,
PLASMA_Complex64_t *C, int ldc,
PLASMA_Complex64_t *WORK, int ldwork )
{
int i, j;
if (uplo == PlasmaLower) {
/* Rebuild the symmetric block: WORK <- C */
for (j = 0; j < n; j++)
for (i = j; i < n; i++){
*(WORK + i + j * ldwork) = *(C + i + j*ldc);
if (i > j){
*(WORK + j + i * ldwork) = *(WORK + i + j * ldwork);
#ifdef COMPLEX
LAPACKE_zlacgv_work(1, WORK + j + i * ldwork, ldwork);
#endif
}
}
/* Left */
CORE_zunmqr(PlasmaLeft, PlasmaConjTrans, n, n, k, ib,
A, lda, T, ldt, WORK, ldwork, WORK+nb*ldwork, ldwork);
/* Right */
CORE_zunmqr(PlasmaRight, PlasmaNoTrans, n, n, k, ib,
A, lda, T, ldt, WORK, ldwork, WORK+nb*ldwork, ldwork);
/*
* Copy back the final result to the lower part of C
*/
/* C = WORK */
for (j = 0; j < n; j++)
for (i = j; i < n; i++)
*(C + i + j*ldc) = *(WORK + i + j * ldwork);
}
else {
/* Rebuild the symmetric block: WORK <- C */
for (i = 0; i < n; i++)
for (j = i; j < n; j++){
*(WORK + i + j * ldwork) = *(C + i + j*ldc);
if (j > i){
*(WORK + j + i * ldwork) = *(WORK + i + j * ldwork);
#ifdef COMPLEX
LAPACKE_zlacgv_work(1, WORK + j + i * ldwork, ldwork);
#endif
}
}
/* Right */
CORE_zunmlq(PlasmaRight, PlasmaConjTrans, n, n, k, ib,
A, lda, T, ldt, WORK, ldwork, WORK+nb*ldwork, ldwork);
/* Left */
CORE_zunmlq(PlasmaLeft, PlasmaNoTrans, n, n, k, ib,
A, lda, T, ldt, WORK, ldwork, WORK+nb*ldwork, ldwork);
/*
* Copy back the final result to the upper part of C
*/
/* C = WORK */
for (i = 0; i < n; i++)
for (j = i; j < n; j++)
*(C + i + j*ldc) = *(WORK + i + j * ldwork);
}
return 0;
}
