//--- Calculation of determinamt ---
double det(const dmatrix &_a)
{
assert( _a.cols() == _a.rows() );
typedef dmatrix mlapack;
mlapack a = _a; // <-
int info;
int n = (int)a.cols();
int lda = n;
std::vector<int> ipiv(n);
#ifdef USE_CLAPACK_INTERFACE
info = clapack_dgetrf(CblasColMajor,
n, n, &(a(0,0)), lda, &(ipiv[0]));
#else
dgetrf_(&n, &n, &a(0,0), &lda, &(ipiv[0]), &info);
#endif
double det=1.0;
for(int i=0; i < n-1; i++)
if(ipiv[i] != i+1) det = -det;
for(int i=0; i < n; i++) det *= a(i,i);
assert(info == 0);
return det;
}
void SGMatrix<T>::inverse(SGMatrix<float64_t> matrix)
{
ASSERT(matrix.num_cols==matrix.num_rows);
int32_t* ipiv = SG_MALLOC(int32_t, matrix.num_cols);
clapack_dgetrf(CblasColMajor,matrix.num_cols,matrix.num_cols,matrix.matrix,matrix.num_cols,ipiv);
clapack_dgetri(CblasColMajor,matrix.num_cols,matrix.matrix,matrix.num_cols,ipiv);
SG_FREE(ipiv);
}
int utpm_lu(int P, int D, int N, int *ipiv, double *A, int *Astrides, double *work){
/* compute A = P * L * U decomposition in Taylor arithmetic.
FIXME:
this algorithm is not fully implemented. Reason: Missing functionality of BLAS/LAPACK to treat
permuted matrices and triangular matrix operations.
In particular, it is required to have an efficient implementation of:
1) \Delta F = LU - P^T A
2) U_1 * U_2 resp. L_1 * L_2 where U_1,U_2 upper triangular and L_1,L_2 unit lower triangular
*/
int d,p,k;
int m,n,j;
int dstrideA, pstrideA;
double *Ad, *Ld, *Ud;
double *Ap;
int lda, TransA;
int Order;
int itmp;
double dtmp;
/* prepare stuff for the lapack call */
Order = CblasColMajor;
get_leadim_and_cblas_transpose(N, N, Astrides, &lda, &TransA);
dstrideA = Astrides[0]/sizeof(double);
pstrideA = (D-1)*dstrideA;
/* compute d = 0 */
/* first A = P L U, i.e. LU with partial pivoting */
clapack_dgetrf(Order, N, N, A, lda, ipiv);
/* compute higher order coefficients d > 0 */
for( p = 0; p < P; ++p){
Ap = A + p*pstrideA;
for( d = 1; d < D; ++d){
/* compute Delta F = A_d - \sum_{k=1}^d A_k B_{d-k} */
Ad = Ap + d * dstrideA;
for(k=1; k < d; ++k){
Ld = Ap + k * dstrideA;
Ud = Ap + (d-k) * dstrideA;
l_times_u(N, -1., Ad, lda, Ld, lda, Ud, lda);
}
// lapack_dtrtrs(lapack_lower, lapack_no_trans, lapack_unit_diag, N, N, const double * a, const int lda, double * b, const int ldb, int * info );
}
}
return 0;
}
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;
}
/*============================================================================*/
int ighmm_invert_det(double *sigmainv, double *det, int length, double *cov)
{
#define CUR_PROC "invert_det"
#ifdef DO_WITH_GSL
int i, j, s;
gsl_matrix *tmp;
gsl_matrix *inv;
tmp = gsl_matrix_alloc(length, length);
inv = gsl_matrix_alloc(length, length);
gsl_permutation *permutation = gsl_permutation_calloc(length);
for (i=0; i<length; ++i) {
for (j=0; j<length; ++j) {
#ifdef DO_WITH_GSL_DIAGONAL_HACK
if (i == j){
gsl_matrix_set(tmp, i, j, cov[i*length+j]);
}else{
gsl_matrix_set(tmp, i, j, 0.0);
}
#else
gsl_matrix_set(tmp, i, j, cov[i*length+j]);
#endif
}
}
gsl_linalg_LU_decomp(tmp, permutation, &s);
gsl_linalg_LU_invert(tmp, permutation, inv);
*det = gsl_linalg_LU_det(tmp, s);
gsl_matrix_free(tmp);
gsl_permutation_free(permutation);
for (i=0; i<length; ++i) {
for (j=0; j<length; ++j) {
sigmainv[i*length+j] = gsl_matrix_get(inv, i, j);
}
}
gsl_matrix_free(inv);
#elif defined HAVE_CLAPACK_DGETRF && HAVE_CLAPACK_DGETRI
char sign;
int info, i;
int *ipiv;
double det_tmp;
ipiv = malloc(length * sizeof *ipiv);
/* copy cov. matrix entries to result matrix, the rest is done in-place */
memcpy(sigmainv, cov, length * length * sizeof *cov);
/* perform in-place LU factorization of covariance matrix */
info = clapack_dgetrf(CblasRowMajor, length, length, sigmainv, length, ipiv);
/* determinant */
sign = 1;
for( i=0; i<length; ++i)
if( ipiv[i]!=i )
sign *= -1;
det_tmp = sigmainv[0];
for( i=length+1; i<(length*length); i+=length+1 )
det_tmp *= sigmainv[i];
*det = det_tmp * sign;
/* use the LU factorization to get inverse */
info = clapack_dgetri(CblasRowMajor, length, sigmainv, length, ipiv);
free(ipiv);
#else
*det = ighmm_determinant(cov, length);
ighmm_inverse(cov, length, *det, sigmainv);
#endif
return 0;
#undef CUR_PROC
}
inline std::ptrdiff_t getrf( Order, const int m, const int n, double* a,
const int lda, int* ipiv ) {
return clapack_dgetrf( clapack_option< Order >::value, m, n, a, lda,
ipiv );
}
int wrapper_clapack_dgetrf(const enum CBLAS_ORDER Order, const int M, const int N, double *A, const int lda, int *ipiv)
{
return clapack_dgetrf(Order, M, N, A, lda, ipiv);
}
void arpack_dsaupd(double* matrix, int n, int nev, const char* which,
int mode, bool pos, double shift, double* eigenvalues,
double* eigenvectors, int& status)
{
// check if nev is greater than n
if (nev>n)
SG_SERROR("Number of required eigenpairs is greater than order of the matrix");
// check specified mode
if (mode!=1 && mode!=3)
SG_SERROR("Unknown mode specified");
// init ARPACK's reverse communication parameter
// (should be zero initially)
int ido = 0;
// specify that non-general eigenproblem will be solved
// (Ax=lGx, where G=I)
char bmat[2] = "I";
// init tolerance (zero means machine precision)
double tol = 0.0;
// allocate array to hold residuals
double* resid = new double[n];
// set number of Lanczos basis vectors to be used
// (with max(4*nev,n) sufficient for most tasks)
int ncv = nev*4>n ? n : nev*4;
// allocate array 'v' for dsaupd routine usage
int ldv = n;
double* v = new double[ldv*ncv];
// init array for i/o params for routine
int* iparam = new int[11];
// specify method for selecting implicit shifts (1 - exact shifts)
iparam[0] = 1;
// specify max number of iterations
iparam[2] = 2*2*n;
// set the computation mode (1 for regular or 3 for shift-inverse)
iparam[6] = mode;
// init array indicating locations of vectors for routine callback
int* ipntr = new int[11];
// allocate workaround arrays
double* workd = new double[3*n];
int lworkl = ncv*(ncv+8);
double* workl = new double[lworkl];
// init info holding status (should be zero at first call)
int info = 0;
// which eigenpairs to find
char* which_ = strdup(which);
// All
char* all_ = strdup("A");
// shift-invert mode
if (mode==3)
{
for (int i=0; i<n; i++)
matrix[i*n+i] -= shift;
if (pos)
{
clapack_dpotrf(CblasColMajor,CblasUpper,n,matrix,n);
clapack_dpotri(CblasColMajor,CblasUpper,n,matrix,n);
}
else
{
int* ipiv = new int[n];
clapack_dgetrf(CblasColMajor,n,n,matrix,n,ipiv);
clapack_dgetri(CblasColMajor,n,matrix,n,ipiv);
delete[] ipiv;
}
}
// main computation loop
do
{
dsaupd_(&ido, bmat, &n, which_, &nev, &tol, resid,
&ncv, v, &ldv, iparam, ipntr, workd, workl,
&lworkl, &info);
if ((ido==1)||(ido==-1))
{
cblas_dsymv(CblasColMajor,CblasUpper,
n,1.0,matrix,n,
(workd+ipntr[0]-1),1,
0.0,(workd+ipntr[1]-1),1);
}
} while ((ido==1)||(ido==-1));
// check if DSAUPD failed
if (info<0)
{
if ((info<=-1)&&(info>=-6))
SG_SWARNING("DSAUPD failed. Wrong parameter passed.");
else if (info==-7)
SG_SWARNING("DSAUPD failed. Workaround array size is not sufficient.");
else
SG_SWARNING("DSAUPD failed. Error code: %d.", info);
status = -1;
}
else
{
if (info==1)
SG_SWARNING("Maximum number of iterations reached.\n");
// allocate select for dseupd
int* select = new int[ncv];
// allocate d to hold eigenvalues
double* d = new double[2*ncv];
// sigma for dseupd
double sigma = shift;
// init ierr indicating dseupd possible errors
int ierr = 0;
// specify that eigenvectors to be computed too
int rvec = 1;
dseupd_(&rvec, all_, select, d, v, &ldv, &sigma, bmat,
&n, which_, &nev, &tol, resid, &ncv, v, &ldv,
iparam, ipntr, workd, workl, &lworkl, &ierr);
if (ierr!=0)
{
SG_SWARNING("DSEUPD failed with status=%d", ierr);
status = -1;
}
else
{
for (int i=0; i<nev; i++)
{
eigenvalues[i] = d[i];
for (int j=0; j<n; j++)
eigenvectors[j*nev+i] = v[i*n+j];
}
}
// cleanup
delete[] select;
delete[] d;
}
// cleanup
delete[] all_;
delete[] which_;
delete[] resid;
delete[] v;
delete[] iparam;
delete[] ipntr;
delete[] workd;
delete[] workl;
};
