void magmaf_sormqr(
magma_side_t *side, magma_trans_t *trans, magma_int_t *m, magma_int_t *n, magma_int_t *k,
float *a, magma_int_t *lda,
float *tau,
float *c, magma_int_t *ldc,
float *work, magma_int_t *lwork,
magma_int_t *info, magma_queue_t *queue )
{
magma_sormqr(
*side, *trans, *m, *n, *k,
a, *lda,
tau,
c, *ldc,
work, *lwork,
info, *queue );
}
extern "C" magma_int_t
magma_sormtr(char side, char uplo, char trans,
magma_int_t m, magma_int_t n,
float *a, magma_int_t lda,
float *tau,
float *c, magma_int_t ldc,
float *work, magma_int_t lwork,
magma_int_t *info)
{
/* -- MAGMA (version 1.4.0) --
Univ. of Tennessee, Knoxville
Univ. of California, Berkeley
Univ. of Colorado, Denver
August 2013
Purpose
=======
SORMTR overwrites the general real M-by-N matrix C with
SIDE = 'L' SIDE = 'R'
TRANS = 'N': Q * C C * Q
TRANS = 'T': Q**T * C C * Q**T
where Q is a real orthogonal matrix of order nq, with nq = m if
SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
nq-1 elementary reflectors, as returned by SSYTRD:
if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': apply Q or Q**T from the Left;
= 'R': apply Q or Q**T from the Right.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A contains elementary reflectors
from SSYTRD;
= 'L': Lower triangle of A contains elementary reflectors
from SSYTRD.
TRANS (input) CHARACTER*1
= 'N': No transpose, apply Q;
= 'T': Transpose, apply Q**T.
M (input) INTEGER
The number of rows of the matrix C. M >= 0.
N (input) INTEGER
The number of columns of the matrix C. N >= 0.
A (input) REAL array, dimension
(LDA,M) if SIDE = 'L'
(LDA,N) if SIDE = 'R'
The vectors which define the elementary reflectors, as
returned by SSYTRD.
LDA (input) INTEGER
The leading dimension of the array A.
LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
TAU (input) REAL array, dimension
(M-1) if SIDE = 'L'
(N-1) if SIDE = 'R'
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by SSYTRD.
C (input/output) REAL array, dimension (LDC,N)
On entry, the M-by-N matrix C.
On exit, C is overwritten by Q*C or Q**T * C or C * Q**T or C*Q.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
If SIDE = 'L', LWORK >= max(1,N);
if SIDE = 'R', LWORK >= max(1,M).
For optimum performance LWORK >= N*NB if SIDE = 'L', and
LWORK >= M*NB if SIDE = 'R', where NB is the optimal
blocksize.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
===================================================================== */
float c_one = MAGMA_S_ONE;
char side_[2] = {side, 0};
char uplo_[2] = {uplo, 0};
char trans_[2] = {trans, 0};
magma_int_t i__2;
magma_int_t i1, i2, nb, mi, ni, nq, nw;
int left, upper, lquery;
magma_int_t iinfo;
magma_int_t lwkopt;
*info = 0;
left = lapackf77_lsame(side_, "L");
upper = lapackf77_lsame(uplo_, "U");
lquery = lwork == -1;
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = m;
nw = n;
} else {
nq = n;
nw = m;
}
if (! left && ! lapackf77_lsame(side_, "R")) {
*info = -1;
} else if (! upper && ! lapackf77_lsame(uplo_, "L")) {
*info = -2;
} else if (! lapackf77_lsame(trans_, "N") &&
! lapackf77_lsame(trans_, "C")) {
*info = -3;
} else if (m < 0) {
*info = -4;
} else if (n < 0) {
*info = -5;
} else if (lda < max(1,nq)) {
*info = -7;
} else if (ldc < max(1,m)) {
*info = -10;
} else if (lwork < max(1,nw) && ! lquery) {
*info = -12;
}
nb = 32;
lwkopt = max(1,nw) * nb;
if (*info == 0) {
MAGMA_S_SET2REAL( work[0], lwkopt );
}
if (*info != 0) {
magma_xerbla( __func__, -(*info) );
return *info;
}
else if (lquery) {
return *info;
}
/* Quick return if possible */
if (m == 0 || n == 0 || nq == 1) {
work[0] = c_one;
return *info;
}
if (left) {
mi = m - 1;
ni = n;
} else {
mi = m;
ni = n - 1;
}
if (upper)
{
/* Q was determined by a call to SSYTRD with UPLO = 'U' */
i__2 = nq - 1;
//lapackf77_sormql(side_, trans_, &mi, &ni, &i__2, &a[lda], &lda,
// tau, c, &ldc, work, &lwork, &iinfo);
magma_sormql(side, trans, mi, ni, i__2, &a[lda], lda, tau,
c, ldc, work, lwork, &iinfo);
}
else
{
/* Q was determined by a call to SSYTRD with UPLO = 'L' */
if (left) {
i1 = 1;
i2 = 0;
} else {
i1 = 0;
i2 = 1;
}
i__2 = nq - 1;
magma_sormqr(side, trans, mi, ni, i__2, &a[1], lda, tau,
&c[i1 + i2 * ldc], ldc, work, lwork, &iinfo);
}
MAGMA_S_SET2REAL( work[0], lwkopt );
return *info;
} /* magma_sormtr */
/* ////////////////////////////////////////////////////////////////////////////
-- Testing sormqr
*/
int main( int argc, char** argv )
{
TESTING_INIT();
real_Double_t gflops, gpu_perf, gpu_time, cpu_perf, cpu_time;
float error, work[1];
float c_neg_one = MAGMA_S_NEG_ONE;
magma_int_t ione = 1;
magma_int_t mm, m, n, k, size, info;
magma_int_t ISEED[4] = {0,0,0,1};
magma_int_t nb, ldc, lda, lwork, lwork_max;
float *C, *R, *A, *W, *tau;
magma_int_t status = 0;
magma_opts opts;
parse_opts( argc, argv, &opts );
// need slightly looser bound (60*eps instead of 30*eps) for some tests
opts.tolerance = max( 60., opts.tolerance );
float tol = opts.tolerance * lapackf77_slamch("E");
// test all combinations of input parameters
magma_side_t side [] = { MagmaLeft, MagmaRight };
magma_trans_t trans[] = { MagmaTrans, MagmaNoTrans };
printf(" M N K side trans CPU GFlop/s (sec) GPU GFlop/s (sec) ||R||_F / ||QC||_F\n");
printf("===============================================================================================\n");
for( int itest = 0; itest < opts.ntest; ++itest ) {
for( int iside = 0; iside < 2; ++iside ) {
for( int itran = 0; itran < 2; ++itran ) {
for( int iter = 0; iter < opts.niter; ++iter ) {
m = opts.msize[itest];
n = opts.nsize[itest];
k = opts.ksize[itest];
nb = magma_get_sgeqrf_nb( m );
ldc = m;
// A is m x k (left) or n x k (right)
mm = (side[iside] == MagmaLeft ? m : n);
lda = mm;
gflops = FLOPS_SORMQR( m, n, k, side[iside] ) / 1e9;
if ( side[iside] == MagmaLeft && m < k ) {
printf( "%5d %5d %5d %4c %5c skipping because side=left and m < k\n",
(int) m, (int) n, (int) k,
lapacke_side_const( side[iside] ),
lapacke_trans_const( trans[itran] ) );
continue;
}
if ( side[iside] == MagmaRight && n < k ) {
printf( "%5d %5d %5d %4c %5c skipping because side=right and n < k\n",
(int) m, (int) n, (int) k,
lapacke_side_const( side[iside] ),
lapacke_trans_const( trans[itran] ) );
continue;
}
// need at least 2*nb*nb for geqrf
lwork_max = max( max( m*nb, n*nb ), 2*nb*nb );
TESTING_MALLOC_CPU( C, float, ldc*n );
TESTING_MALLOC_CPU( R, float, ldc*n );
TESTING_MALLOC_CPU( A, float, lda*k );
TESTING_MALLOC_CPU( W, float, lwork_max );
TESTING_MALLOC_CPU( tau, float, k );
// C is full, m x n
size = ldc*n;
lapackf77_slarnv( &ione, ISEED, &size, C );
lapackf77_slacpy( "Full", &m, &n, C, &ldc, R, &ldc );
size = lda*k;
lapackf77_slarnv( &ione, ISEED, &size, A );
// compute QR factorization to get Householder vectors in A, tau
magma_sgeqrf( mm, k, A, lda, tau, W, lwork_max, &info );
if (info != 0)
printf("magma_sgeqrf returned error %d: %s.\n",
(int) info, magma_strerror( info ));
/* =====================================================================
Performs operation using LAPACK
=================================================================== */
cpu_time = magma_wtime();
lapackf77_sormqr( lapack_side_const( side[iside] ), lapack_trans_const( trans[itran] ),
&m, &n, &k,
A, &lda, tau, C, &ldc, W, &lwork_max, &info );
cpu_time = magma_wtime() - cpu_time;
cpu_perf = gflops / cpu_time;
if (info != 0)
printf("lapackf77_sormqr returned error %d: %s.\n",
(int) info, magma_strerror( info ));
/* ====================================================================
Performs operation using MAGMA
=================================================================== */
// query for workspace size
lwork = -1;
magma_sormqr( side[iside], trans[itran],
m, n, k,
A, lda, tau, R, ldc, W, lwork, &info );
if (info != 0)
printf("magma_sormqr (lwork query) returned error %d: %s.\n",
(int) info, magma_strerror( info ));
lwork = (magma_int_t) MAGMA_S_REAL( W[0] );
if ( lwork < 0 || lwork > lwork_max ) {
printf("optimal lwork %d > lwork_max %d\n", (int) lwork, (int) lwork_max );
lwork = lwork_max;
}
gpu_time = magma_wtime();
magma_sormqr( side[iside], trans[itran],
m, n, k,
A, lda, tau, R, ldc, W, lwork, &info );
gpu_time = magma_wtime() - gpu_time;
gpu_perf = gflops / gpu_time;
if (info != 0)
printf("magma_sormqr returned error %d: %s.\n",
(int) info, magma_strerror( info ));
/* =====================================================================
compute relative error |QC_magma - QC_lapack| / |QC_lapack|
=================================================================== */
error = lapackf77_slange( "Fro", &m, &n, C, &ldc, work );
size = ldc*n;
blasf77_saxpy( &size, &c_neg_one, C, &ione, R, &ione );
error = lapackf77_slange( "Fro", &m, &n, R, &ldc, work ) / error;
printf( "%5d %5d %5d %4c %5c %7.2f (%7.2f) %7.2f (%7.2f) %8.2e %s\n",
(int) m, (int) n, (int) k,
lapacke_side_const( side[iside] ),
lapacke_trans_const( trans[itran] ),
cpu_perf, cpu_time, gpu_perf, gpu_time,
error, (error < tol ? "ok" : "failed") );
status += ! (error < tol);
TESTING_FREE_CPU( C );
TESTING_FREE_CPU( R );
TESTING_FREE_CPU( A );
TESTING_FREE_CPU( W );
TESTING_FREE_CPU( tau );
fflush( stdout );
}
if ( opts.niter > 1 ) {
printf( "\n" );
}
}} // end iside, itran
printf( "\n" );
}
TESTING_FINALIZE();
return status;
}
/***************************************************************************//**
Purpose
-------
SORMBR multiplies by Q or P as part of the SVD decomposition.
If VECT = MagmaQ, SORMBR overwrites the general real M-by-N matrix C with
SIDE = MagmaLeft SIDE = MagmaRight
TRANS = MagmaNoTrans: Q*C C*Q
TRANS = MagmaTrans: Q**H*C C*Q**H
If VECT = MagmaP, SORMBR overwrites the general real M-by-N matrix C with
SIDE = MagmaLeft SIDE = MagmaRight
TRANS = MagmaNoTrans: P*C C*P
TRANS = MagmaTrans: P**H*C C*P**H
Here Q and P**H are the orthogonal matrices determined by SGEBRD when
reducing A real matrix A to bidiagonal form: A = Q*B * P**H. Q
and P**H are defined as products of elementary reflectors H(i) and
G(i) respectively.
Let nq = m if SIDE = MagmaLeft and nq = n if SIDE = MagmaRight. Thus nq is the
order of the orthogonal matrix Q or P**H that is applied.
If VECT = MagmaQ, A is assumed to have been an NQ-by-K matrix:
if nq >= k, Q = H(1) H(2) . . . H(k);
if nq < k, Q = H(1) H(2) . . . H(nq-1).
If VECT = MagmaP, A is assumed to have been A K-by-NQ matrix:
if k < nq, P = G(1) G(2) . . . G(k);
if k >= nq, P = G(1) G(2) . . . G(nq-1).
Arguments
---------
@param[in]
vect magma_vect_t
- = MagmaQ: apply Q or Q**H;
- = MagmaP: apply P or P**H.
@param[in]
side magma_side_t
- = MagmaLeft: apply Q, Q**H, P or P**H from the Left;
- = MagmaRight: apply Q, Q**H, P or P**H from the Right.
@param[in]
trans magma_trans_t
- = MagmaNoTrans: No transpose, apply Q or P;
- = MagmaTrans: Conjugate transpose, apply Q**H or P**H.
@param[in]
m INTEGER
The number of rows of the matrix C. M >= 0.
@param[in]
n INTEGER
The number of columns of the matrix C. N >= 0.
@param[in]
k INTEGER
If VECT = MagmaQ, the number of columns in the original
matrix reduced by SGEBRD.
If VECT = MagmaP, the number of rows in the original
matrix reduced by SGEBRD.
K >= 0.
@param[in]
A REAL array, dimension
(LDA,min(nq,K)) if VECT = MagmaQ
(LDA,nq) if VECT = MagmaP
The vectors which define the elementary reflectors H(i) and
G(i), whose products determine the matrices Q and P, as
returned by SGEBRD.
@param[in]
lda INTEGER
The leading dimension of the array A.
If VECT = MagmaQ, LDA >= max(1,nq);
if VECT = MagmaP, LDA >= max(1,min(nq,K)).
@param[in]
tau REAL array, dimension (min(nq,K))
TAU(i) must contain the scalar factor of the elementary
reflector H(i) or G(i) which determines Q or P, as returned
by SGEBRD in the array argument TAUQ or TAUP.
@param[in,out]
C REAL array, dimension (LDC,N)
On entry, the M-by-N matrix C.
On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q
or P*C or P**H*C or C*P or C*P**H.
@param[in]
ldc INTEGER
The leading dimension of the array C. LDC >= max(1,M).
@param[out]
work (workspace) REAL array, dimension (MAX(1,LWORK))
On exit, if INFO = 0, WORK[0] returns the optimal LWORK.
@param[in]
lwork INTEGER
The dimension of the array WORK.
If SIDE = MagmaLeft, LWORK >= max(1,N);
if SIDE = MagmaRight, LWORK >= max(1,M);
if N = 0 or M = 0, LWORK >= 1.
For optimum performance
if SIDE = MagmaLeft, LWORK >= max(1,N*NB);
if SIDE = MagmaRight, LWORK >= max(1,M*NB),
where NB is the optimal blocksize. (NB = 0 if M = 0 or N = 0.)
\n
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
@param[out]
info INTEGER
- = 0: successful exit
- < 0: if INFO = -i, the i-th argument had an illegal value
@ingroup magma_unmbr
*******************************************************************************/
extern "C" magma_int_t
magma_sormbr(
magma_vect_t vect, magma_side_t side, magma_trans_t trans,
magma_int_t m, magma_int_t n, magma_int_t k,
float *A, magma_int_t lda,
float *tau,
float *C, magma_int_t ldc,
float *work, magma_int_t lwork,
magma_int_t *info)
{
#define A(i,j) (A + (i) + (j)*lda)
#define C(i,j) (C + (i) + (j)*ldc)
magma_int_t i1, i2, nb, mi, ni, nq, nq_1, minwrk, iinfo, lwkopt;
magma_int_t left, notran, applyq, lquery;
magma_trans_t transt;
MAGMA_UNUSED( nq_1 ); // used only in version 1
*info = 0;
applyq = (vect == MagmaQ);
left = (side == MagmaLeft);
notran = (trans == MagmaNoTrans);
lquery = (lwork == -1);
/* NQ is the order of Q or P and MINWRK (previously "nw") is the minimum dimension of WORK */
if (left) {
nq = m;
minwrk = n;
}
else {
nq = n;
minwrk = m;
}
if (m == 0 || n == 0) {
minwrk = 0;
}
/* check arguments */
if (! applyq && vect != MagmaP) {
*info = -1;
}
else if (! left && side != MagmaRight) {
*info = -2;
}
else if (! notran && trans != MagmaTrans) {
*info = -3;
}
else if (m < 0) {
*info = -4;
}
else if (n < 0) {
*info = -5;
}
else if (k < 0) {
*info = -6;
}
else if ( ( applyq && lda < max(1,nq) ) ||
( ! applyq && lda < max(1,min(nq,k)) ) ) {
*info = -8;
}
else if (ldc < max(1,m)) {
*info = -11;
}
else if (lwork < max(1,minwrk) && ! lquery) {
*info = -13;
}
if (*info == 0) {
if (minwrk > 0) {
// TODO have get_sormqr_nb and get_sormlq_nb routines? see original LAPACK sormbr.
// TODO make them dependent on m, n, and k?
nb = magma_get_sgebrd_nb( m, n );
lwkopt = max(1, minwrk*nb);
}
else {
lwkopt = 1;
}
work[0] = magma_smake_lwork( lwkopt );
}
if (*info != 0) {
magma_xerbla( __func__, -(*info) );
return *info;
}
else if (lquery) {
return *info;
}
/* Quick return if possible */
if (m == 0 || n == 0) {
return *info;
}
if (applyq) {
/* Apply Q */
if (nq >= k) {
/* Q was determined by a call to SGEBRD with nq >= k */
#if VERSION == 1
lapackf77_sormqr( lapack_side_const(side), lapack_trans_const(trans),
&m, &n, &k, A, &lda, tau, C, &ldc, work, &lwork, &iinfo);
#else
magma_sormqr( side, trans,
m, n, k, A, lda, tau, C, ldc, work, lwork, &iinfo);
#endif
}
else if (nq > 1) {
/* Q was determined by a call to SGEBRD with nq < k */
if (left) {
mi = m - 1;
ni = n;
i1 = 1;
i2 = 0;
}
else {
mi = m;
ni = n - 1;
i1 = 0;
i2 = 1;
}
#if VERSION == 1
nq_1 = nq - 1;
lapackf77_sormqr( lapack_side_const(side), lapack_trans_const(trans),
&mi, &ni, &nq_1, A(1,0), &lda, tau, C(i1,i2), &ldc, work, &lwork, &iinfo);
#else
magma_sormqr( side, trans,
mi, ni, nq-1, A(1,0), lda, tau, C(i1,i2), ldc, work, lwork, &iinfo);
#endif
}
}
else {
/* Apply P */
if (notran) {
transt = MagmaTrans;
}
else {
transt = MagmaNoTrans;
}
if (nq > k) {
/* P was determined by a call to SGEBRD with nq > k */
#if VERSION == 1
lapackf77_sormlq( lapack_side_const(side), lapack_trans_const(transt),
&m, &n, &k, A, &lda, tau, C, &ldc, work, &lwork, &iinfo);
#else
magma_sormlq( side, transt,
m, n, k, A, lda, tau, C, ldc, work, lwork, &iinfo);
#endif
}
else if (nq > 1) {
/* P was determined by a call to SGEBRD with nq <= k */
if (left) {
mi = m - 1;
ni = n;
i1 = 1;
i2 = 0;
}
else {
mi = m;
ni = n - 1;
i1 = 0;
i2 = 1;
}
#if VERSION == 1
nq_1 = nq - 1;
lapackf77_sormlq( lapack_side_const(side), lapack_trans_const(transt),
&mi, &ni, &nq_1, A(0,1), &lda, tau, C(i1,i2), &ldc, work, &lwork, &iinfo);
#else
magma_sormlq( side, transt,
mi, ni, nq-1, A(0,1), lda, tau, C(i1,i2), ldc, work, lwork, &iinfo);
#endif
}
}
work[0] = magma_smake_lwork( lwkopt );
return *info;
} /* magma_sormbr */