inline std::ptrdiff_t getrs( Order, const Trans, const int n, const int nrhs,
const double* a, const int lda, const int* ipiv, double* b,
const int ldb ) {
return clapack_dgetrs
( clapack_option< Order >::value, clapack_option< Trans >::value, n, nrhs,
a, lda, ipiv, b, ldb );
}
int test_lapack(int n)
{
int* ipiv;
int info;
int i, j;
double * m, *x, *y;
int LDB,LDA, N, NRHS;
char transp = 'N';
m=(double*)malloc(sizeof(double)*n*n);
x=(double*)malloc(sizeof(double)*n);
y=(double*)malloc(sizeof(double)*n);
ipiv=(int*)malloc(sizeof(int)*n);
for (i=0; i<n; ++i) {
x[i]=1.0;
for (j=0; j<n; ++j) {
m[i*n+j]=(rand()%100+1)/10.0;
// printf("m[%d,%d]=%lf\n",i,j, m[i*n+j]);
}
}
/* test cblas.h */
//cblas_dgemv(CblasColMajor, CblasNoTrans, n, n, 1.0, m, n,
// x, 1, 0.0, y, 1);
// for (i=0; i<n; ++i) printf("x[%d]=%lf\n",i, x[i]);
//for (i=0; i<n; ++i) printf("y[%d]=%lf\n",i, y[i]);
LDB=n;
LDA=n;
N=n;
NRHS=1;
info=clapack_dgetrf ( CblasColMajor,n,n,m,n,ipiv );
if (info != 0) fprintf(stderr, "dgetrf failure with error %d\n", info);
clapack_dgetrs ( CblasColMajor,CblasNoTrans,n,1,m,n,ipiv,y,n);
if (info != 0) fprintf(stderr, "failure with error %d\n", info);
// for (i=0; i<n; ++i) printf("%lf\n", y[i]);
free(m);
free(x);
free(y);
free(ipiv);
return 0;
}
int utpm_solve(int P, int D, int N, int NRHS, int *ipiv, double *A, int *Astrides,
double *B, int *Bstrides){
/*
Solves the linear system op(A) X = B in Taylor arithmetic,
where op(A) = A or op(A) = A**T
A (N,N) matrix.
B (N,NRHS) matrix
This is a modification of the API of dgesv.f: added possiblity enum CBLAS_TRANSPOSE TransA
to the function argument list.Compare to http://www.netlib.org/lapack/double/dgesv.f.
The solution is computed by:
1) clapack_dgetrf (see http://www.netlib.org/lapack/double/dgetrf.f)
2) clapack_dgetrs (see http://www.netlib.org/lapack/double/dgetrs.f)
*/
int d,p,k;
int dstrideA, dstrideB, pstrideA, pstrideB;
double *Ad, *Bd;
double *Ap, *Bp;
int lda, ldb, TransA, TransB;
int Order;
/* prepare stuff for the lapack call */
Order = CblasColMajor;
get_leadim_and_cblas_transpose(N, N, Astrides, &lda, &TransA);
get_leadim_and_cblas_transpose(N, NRHS, Bstrides, &ldb, &TransB);
/* compute d = 0 */
/* first A = P L U, i.e. LU with partial pivoting */
clapack_dgetrf(Order, N, N, A, lda, ipiv);
clapack_dgetrs(Order, TransA, N, NRHS, A, lda, ipiv, B, ldb);
/* clapack_dgesv(Order, N, NRHS, A, lda, ipiv, B, ldb); */
/* compute higher order coefficients d > 0 */
dstrideA = lda*N; dstrideB = ldb*NRHS;
pstrideA = dstrideA*(D-1); pstrideB = dstrideB*(D-1);
for( p = 0; p < P; ++p){
Ap = A + p*pstrideA;
Bp = B + p*pstrideB;
for( d = 1; d < D; ++d){
/* compute B_d - \sum_{k=1}^d A_k B_{d-k} */
for(k=1; k < d; ++k){
Ad = Ap + k * dstrideA;
Bd = Bp + (d-k) * dstrideB;
/* FIXME: why the hell is now ldb = NRHS??? */
cblas_dgemm(Order, TransA, CblasNoTrans, N, NRHS,
N, -1., Ad, lda, Bd, ldb, 1., Bp + d*dstrideB, ldb);
}
/* compute the last loop element, i.e. k = d */
Ad = Ap + d*dstrideA; Bd = Bp + d*dstrideB;
cblas_dgemm(Order, TransA, CblasNoTrans, N, NRHS,
N, -1., Ad, lda, B, ldb, 1., Bd, ldb);
/* compute solve(A_0, B_d - \sum_{k=1}^d A_k B_{d-k}
where A_0 is LU factorized already */
clapack_dgetrs(Order, TransA, N, NRHS, A, lda, ipiv, Bd, ldb);
}
}
return 0;
}
