void F77_strsm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
int *m, int *n, float *alpha, float *a, int *lda, float *b,
int *ldb) {
int i,j,LDA,LDB;
float *A, *B;
enum CBLAS_SIDE side;
enum CBLAS_DIAG diag;
enum CBLAS_UPLO uplo;
enum CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
get_diag_type(diagn,&diag);
get_side_type(rtlf,&side);
if (*order == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
A = ( float* )malloc( (*m)*LDA*sizeof( float ) );
for( i=0; i<*m; i++ )
for( j=0; j<*m; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
else{
LDA = *n+1;
A = ( float* )malloc( (*n)*LDA*sizeof( float ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
LDB = *n+1;
B = ( float* )malloc( (*m)*LDB*sizeof( float ) );
for( i=0; i<*m; i++ )
for( j=0; j<*n; j++ )
B[i*LDB+j]=b[j*(*ldb)+i];
cblas_strsm(CblasRowMajor, side, uplo, trans, diag, *m, *n, *alpha,
A, LDA, B, LDB );
for( j=0; j<*n; j++ )
for( i=0; i<*m; i++ )
b[j*(*ldb)+i]=B[i*LDB+j];
free(A);
free(B);
}
else if (*order == TEST_COL_MJR)
cblas_strsm(CblasColMajor, side, uplo, trans, diag, *m, *n, *alpha,
a, *lda, b, *ldb);
else
cblas_strsm(UNDEFINED, side, uplo, trans, diag, *m, *n, *alpha,
a, *lda, b, *ldb);
}
inline void trsm(
CBLAS_ORDER order, CBLAS_UPLO uplo,CBLAS_TRANSPOSE transA,
CBLAS_SIDE side, CBLAS_DIAG unit,
int n, int nRHS,
float const *A, int lda, float *B, int ldb
) {
cblas_strsm(order, side, uplo, transA, unit,n, nRHS, 1.0, A, lda, B, ldb);
}
void STARPU_STRSM (const char *side, const char *uplo, const char *transa,
const char *diag, const int m, const int n,
const float alpha, const float *A, const int lda,
float *B, const int ldb)
{
enum CBLAS_SIDE side_ = (toupper(side[0]) == 'L')?CblasLeft:CblasRight;
enum CBLAS_UPLO uplo_ = (toupper(uplo[0]) == 'U')?CblasUpper:CblasLower;
enum CBLAS_TRANSPOSE transa_ = (toupper(transa[0]) == 'N')?CblasNoTrans:CblasTrans;
enum CBLAS_DIAG diag_ = (toupper(diag[0]) == 'N')?CblasNonUnit:CblasUnit;
cblas_strsm(CblasColMajor, side_, uplo_, transa_, diag_, m, n, alpha, A, lda, B, ldb);
}
JNIEXPORT void JNICALL Java_uncomplicate_neanderthal_CBLAS_strsm
(JNIEnv *env, jclass clazz,
jint Order, jint Side,
jint Uplo, jint TransA, jint Diag,
jint M, jint N,
jfloat alpha,
jobject A, jint lda,
jobject B, jint ldb) {
float *cA = (float *) (*env)->GetDirectBufferAddress(env, A);
float *cB = (float *) (*env)->GetDirectBufferAddress(env, B);
cblas_strsm(Order, Side, Uplo, TransA, Diag, M, N, alpha, cA, lda, cB, ldb);
};
DLLEXPORT MKL_INT s_qr_solve_factored(MKL_INT m, MKL_INT n, MKL_INT bn, float r[], float b[], float tau[], float x[], float work[], MKL_INT len)
{
char side ='L';
char tran = 'T';
MKL_INT info = 0;
float* clone_b = new float[m*bn];
std::memcpy(clone_b, b, m*bn*sizeof(float));
sormqr_(&side, &tran, &m, &bn, &n, r, &m, tau, clone_b, &m, work, &len, &info);
cblas_strsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit, n, bn, 1.0, r, m, clone_b, m);
for (MKL_INT i = 0; i < n; ++i)
{
for (MKL_INT j = 0; j < bn; ++j)
{
x[j * n + i] = clone_b[j * m + i];
}
}
delete[] clone_b;
return info;
}
DLLEXPORT int s_qr_solve(int m, int n, int bn, float r[], float b[], float x[], float work[], int len)
{
int info = 0;
float* clone_r = new float[m*n];
memcpy(clone_r, r, m*n*sizeof(float));
float* tau = new float[max(1, min(m,n))];
sgeqrf_(&m, &n, clone_r, &m, tau, work, &len, &info);
if (info != 0)
{
delete[] clone_r;
delete[] tau;
return info;
}
float* clone_b = new float[m*bn];
memcpy(clone_b, b, m*bn*sizeof(float));
char side ='L';
char tran = 'T';
sormqr_(&side, &tran, &m, &bn, &n, clone_r, &m, tau, clone_b, &m, work, &len, &info);
cblas_strsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit, n, bn, 1.0, clone_r, m, clone_b, m);
for (int i = 0; i < n; ++i)
{
for (int j = 0; j < bn; ++j)
{
x[j * n + i] = clone_b[j * m + i];
}
}
delete[] clone_r;
delete[] tau;
delete[] clone_b;
return info;
}
int CORE_sgessm(int M, int N, int K, int IB,
int *IPIV,
float *L, int LDL,
float *A, int LDA)
{
static float zone = 1.0;
static float mzone = -1.0;
static int ione = 1;
int i, sb;
int tmp, tmp2;
/* 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 (K < 0) {
coreblas_error(3, "Illegal value of K");
return -3;
}
if (IB < 0) {
coreblas_error(4, "Illegal value of IB");
return -4;
}
if ((LDL < max(1,M)) && (M > 0)) {
coreblas_error(7, "Illegal value of LDL");
return -7;
}
if ((LDA < max(1,M)) && (M > 0)) {
coreblas_error(9, "Illegal value of LDA");
return -9;
}
/* Quick return */
if ((M == 0) || (N == 0) || (K == 0) || (IB == 0))
return PLASMA_SUCCESS;
for(i = 0; i < K; i += IB) {
sb = min(IB, K-i);
/*
* Apply interchanges to columns I*IB+1:IB*( I+1 )+1.
*/
tmp = i+1;
tmp2 = i+sb;
LAPACKE_slaswp_work(LAPACK_COL_MAJOR, N, A, LDA, tmp, tmp2, IPIV, ione);
/*
* Compute block row of U.
*/
cblas_strsm(
CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, CblasUnit,
sb, N, (zone),
&L[LDL*i+i], LDL,
&A[i], LDA );
if (i+sb < M) {
/*
* Update trailing submatrix.
*/
cblas_sgemm(
CblasColMajor, CblasNoTrans, CblasNoTrans,
M-(i+sb), N, sb,
(mzone), &L[LDL*i+(i+sb)], LDL,
&A[i], LDA,
(zone), &A[i+sb], LDA );
}
}
return PLASMA_SUCCESS;
}
int testing_strsm(int argc, char **argv)
{
/* Check for number of arguments*/
if ( argc != 5 ) {
USAGE("TRSM", "alpha M N LDA LDB",
" - alpha : alpha coefficient\n"
" - M : number of rows of matrices B\n"
" - N : number of columns of matrices B\n"
" - LDA : leading dimension of matrix A\n"
" - LDB : leading dimension of matrix B\n");
return -1;
}
float alpha = (float) atol(argv[0]);
int M = atoi(argv[1]);
int N = atoi(argv[2]);
int LDA = atoi(argv[3]);
int LDB = atoi(argv[4]);
float eps;
int info_solution;
int s, u, t, d, i;
int LDAxM = LDA*max(M,N);
int LDBxN = LDB*max(M,N);
float *A = (float *)malloc(LDAxM*sizeof(float));
float *B = (float *)malloc(LDBxN*sizeof(float));
float *Binit = (float *)malloc(LDBxN*sizeof(float));
float *Bfinal = (float *)malloc(LDBxN*sizeof(float));
/* Check if unable to allocate memory */
if ( (!A) || (!B) || (!Binit) || (!Bfinal)){
printf("Out of Memory \n ");
return -2;
}
eps = LAPACKE_slamch_work('e');
printf("\n");
printf("------ TESTS FOR PLASMA STRSM ROUTINE ------- \n");
printf(" Size of the Matrix B : %d by %d\n", M, N);
printf("\n");
printf(" The matrix A is randomly generated for each test.\n");
printf("============\n");
printf(" The relative machine precision (eps) is to be %e \n",eps);
printf(" Computational tests pass if scaled residuals are less than 10.\n");
/*----------------------------------------------------------
* TESTING STRSM
*/
/* Initialize A, B, C */
LAPACKE_slarnv_work(IONE, ISEED, LDAxM, A);
LAPACKE_slarnv_work(IONE, ISEED, LDBxN, B);
for(i=0;i<max(M,N);i++)
A[LDA*i+i] = A[LDA*i+i] + 2.0;
for (s=0; s<2; s++) {
for (u=0; u<2; u++) {
#ifdef COMPLEX
for (t=0; t<3; t++) {
#else
for (t=0; t<2; t++) {
#endif
for (d=0; d<2; d++) {
memcpy(Binit, B, LDBxN*sizeof(float));
memcpy(Bfinal, B, LDBxN*sizeof(float));
/* PLASMA STRSM */
PLASMA_strsm(side[s], uplo[u], trans[t], diag[d],
M, N, alpha, A, LDA, Bfinal, LDB);
/* Check the solution */
info_solution = check_solution(side[s], uplo[u], trans[t], diag[d],
M, N, alpha, A, LDA, Binit, Bfinal, LDB);
printf("***************************************************\n");
if (info_solution == 0) {
printf(" ---- TESTING STRSM (%s, %s, %s, %s) ...... PASSED !\n",
sidestr[s], uplostr[u], transstr[t], diagstr[d]);
}
else {
printf(" ---- TESTING STRSM (%s, %s, %s, %s) ... FAILED !\n",
sidestr[s], uplostr[u], transstr[t], diagstr[d]);
}
printf("***************************************************\n");
}
}
}
}
free(A); free(B);
free(Binit); free(Bfinal);
return 0;
}
/*--------------------------------------------------------------
* Check the solution
*/
static int check_solution(PLASMA_enum side, PLASMA_enum uplo, PLASMA_enum trans, PLASMA_enum diag,
int M, int N, float alpha,
float *A, int LDA,
float *Bref, float *Bplasma, int LDB)
{
int info_solution;
float Anorm, Binitnorm, Bplasmanorm, Blapacknorm, Rnorm, result;
float eps;
float mzone = (float)-1.0;
float *work = (float *)malloc(max(M, N)* sizeof(float));
int Am, An;
if (side == PlasmaLeft) {
Am = M; An = M;
} else {
Am = N; An = N;
}
Anorm = LAPACKE_slantr_work(LAPACK_COL_MAJOR, lapack_const(PlasmaInfNorm), lapack_const(uplo), lapack_const(diag),
Am, An, A, LDA, work);
Binitnorm = LAPACKE_slange_work(LAPACK_COL_MAJOR, lapack_const(PlasmaInfNorm), M, N, Bref, LDB, work);
Bplasmanorm = LAPACKE_slange_work(LAPACK_COL_MAJOR, lapack_const(PlasmaInfNorm), M, N, Bplasma, LDB, work);
cblas_strsm(CblasColMajor, (CBLAS_SIDE)side, (CBLAS_UPLO)uplo, (CBLAS_TRANSPOSE)trans,
(CBLAS_DIAG)diag, M, N, (alpha), A, LDA, Bref, LDB);
Blapacknorm = LAPACKE_slange_work(LAPACK_COL_MAJOR, lapack_const(PlasmaInfNorm), M, N, Bref, LDB, work);
cblas_saxpy(LDB * N, (mzone), Bplasma, 1, Bref, 1);
Rnorm = LAPACKE_slange_work(LAPACK_COL_MAJOR, lapack_const(PlasmaInfNorm), M, N, Bref, LDB, work);
eps = LAPACKE_slamch_work('e');
printf("Rnorm %e, Anorm %e, Binitnorm %e, Bplasmanorm %e, Blapacknorm %e\n",
Rnorm, Anorm, Binitnorm, Bplasmanorm, Blapacknorm);
result = Rnorm / ((Anorm + Blapacknorm) * max(M,N) * eps);
printf("============\n");
printf("Checking the norm of the difference against reference STRSM \n");
printf("-- ||Cplasma - Clapack||_oo/((||A||_oo+||B||_oo).N.eps) = %e \n", result);
if ( isinf(Blapacknorm) || isinf(Bplasmanorm) || isnan(result) || isinf(result) || (result > 10.0) ) {
printf("-- The solution is suspicious ! \n");
info_solution = 1;
}
else {
printf("-- The solution is CORRECT ! \n");
info_solution= 0 ;
}
free(work);
return info_solution;
}
static int check_transformation(int itype, int uplo, int N, float *A1, float *A2, int LDA, float *B2, int LDB, float eps)
{
float alpha = 1.0;
float Anorm, Rnorm, result;
int info_transformation;
int i, j;
char *str;
float *Residual = (float *)malloc(N*N*sizeof(float));
float *Aorig = (float *)malloc(N*N*sizeof(float));
float *work = (float *)malloc(N*sizeof(float));
LAPACKE_slacpy_work(LAPACK_COL_MAJOR, 'a', N, N, A1, LDA, Residual, N);
LAPACKE_slacpy_work(LAPACK_COL_MAJOR, lapack_const(uplo), N, N, A2, LDA, Aorig, N);
/* Rebuild the symmetry of A2 */
if (uplo == PlasmaLower) {
for (j = 0; j < N; j++)
for (i = j+1; i < N; i++)
Aorig[j+i*N] = (Aorig[i+j*N]);
} else {
for (i = 0; i < N; i++)
for (j = i+1; j < N; j++)
Aorig[j+i*N] = (Aorig[i+j*N]);
}
if (itype == 1) {
if (uplo == PlasmaLower) {
str = "L*A2*L'";
cblas_strmm(CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, N, N, (alpha), B2, LDB, Aorig, N);
cblas_strmm(CblasColMajor, CblasRight, CblasLower, CblasTrans, CblasNonUnit, N, N, (alpha), B2, LDB, Aorig, N);
}
else{
str = "U'*A2*U";
cblas_strmm(CblasColMajor, CblasLeft, CblasUpper, CblasTrans, CblasNonUnit, N, N, (alpha), B2, LDB, Aorig, N);
cblas_strmm(CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, CblasNonUnit, N, N, (alpha), B2, LDB, Aorig, N);
}
}
else {
if (uplo == PlasmaLower) {
str = "inv(L')*A2*inv(L)";
cblas_strsm(CblasColMajor, CblasLeft, CblasLower, CblasTrans, CblasNonUnit, N, N, (alpha), B2, LDB, Aorig, N);
cblas_strsm(CblasColMajor, CblasRight, CblasLower, CblasNoTrans, CblasNonUnit, N, N, (alpha), B2, LDB, Aorig, N);
}
else{
str = "inv(U)*A2*inv(U')";
cblas_strsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit, N, N, (alpha), B2, LDB, Aorig, N);
cblas_strsm(CblasColMajor, CblasRight, CblasUpper, CblasTrans, CblasNonUnit, N, N, (alpha), B2, LDB, Aorig, N);
}
}
/* Compute the Residual ( A1 - W ) */
for (i = 0; i < N; i++)
for (j = 0; j < N; j++)
Residual[j*N+i] = Aorig[j*N+i] - Residual[j*N+i];
Rnorm = LAPACKE_slange_work(LAPACK_COL_MAJOR, lapack_const(PlasmaInfNorm), N, N, Residual, N, work);
Anorm = LAPACKE_slange_work(LAPACK_COL_MAJOR, lapack_const(PlasmaInfNorm), N, N, A1, LDA, work);
result = Rnorm / (Anorm * N *eps);
printf("============\n");
printf("Checking the global transformation \n");
printf("-- ||A1-%s||_oo/(||A1||_oo.N.eps) = %e \n", str, result );
if (isnan(result) || isinf(result) || (result > 60.0) ) {
printf("-- Transformation is suspicious ! \n");
info_transformation = 1;
}
else {
printf("-- Transformation is CORRECT ! \n");
info_transformation = 0;
}
free(Residual); free(Aorig); free(work);
return info_transformation;
}
