DLLEXPORT MKL_INT d_svd_factor(bool compute_vectors, MKL_INT m, MKL_INT n, double a[], double s[], double u[], double v[], double work[], MKL_INT len)
{
MKL_INT info = 0;
char job = compute_vectors ? 'A' : 'N';
dgesvd_(&job, &job, &m, &n, a, &m, s, u, &m, v, &n, work, &len, &info);
return info;
}
DLLEXPORT int d_svd_factor(bool compute_vectors, int m, int n, double a[], double s[], double u[], double v[], double work[], int len)
{
int info = 0;
char job = compute_vectors ? 'A' : 'N';
dgesvd_(&job, &job, &m, &n, a, &m, s, u, &m, v, &n, work, &len, &info);
return info;
}
void quantfin::interfaceCLAPACK::SingularValueDecomposition(const Array<double,2>& A,Array<double,2>& U,Array<double,1>& sigma,Array<double,2>& V)
{
int i,j;
long int m = A.rows();
long int n = A.columns();
long int lwork = 5 * std::max(m,n);
double* ap = new double[n*m];
double* s = new double[std::min(n,m)];
double* u = new double[m*m];
double* vt = new double[n*n];
double* w = new double[lwork];
double* pos = ap;
for (i=0;i<n;i++) {
for (j=0;j<m;j++) *pos++ = A(j,i); }
long int info = 0;
char jobu = 'S';
char jobvt = 'A';
dgesvd_(&jobu,&jobvt,&m,&n,ap,&m,s,u,&m,vt,&n,w,&lwork,&info);
sigma = 0.0;
for (i=0;i<std::min(n,m);i++) sigma(i) = s[i];
pos = u;
for (i=0;i<n;i++) {
for (j=0;j<m;j++) U(j,i) = *pos++; }
pos = vt;
for (i=0;i<n;i++) {
for (j=0;j<n;j++) V(i,j) = *pos++; }
delete[] ap;
delete[] s;
delete[] u;
delete[] vt;
delete[] w;
if (info) throw(std::logic_error("Singular value decomposition failed"));
}
/*! compute the singular value decomposition (SVD)\n
The arguments are dcocector S, dgematrix U and VT.
All of them need not to be initialized.
S, U and VT are overwitten and become singular values,
left singular vectors,
and right singular vectors respectively.
This matrix also overwritten.
*/
inline long dgematrix::dgesvd(dcovector& S, dgematrix& U, dgematrix& VT)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] dgematrix::dgesvd(dcovector&, dgematrix&, dgematrix&)"
<< std::endl;
#endif//CPPL_VERBOSE
char JOBU('A'), JOBVT('A');
long LDA(M), LDU(M), LDVT(N),
LWORK(max(3*min(M,N)+max(M,N),5*min(M,N))), INFO(1);
double *WORK(new double[LWORK]);
S.resize(min(M,N)); U.resize(LDU,M); VT.resize(LDVT,N);
dgesvd_(JOBU, JOBVT, M, N, Array, LDA, S.Array, U.Array,
LDU, VT.Array, LDVT, WORK, LWORK, INFO);
delete [] WORK;
if(INFO!=0){
std::cerr << "[WARNING] dgematrix::dgesvd"
<< "(dceovector&, dgematrix&, dcovector&) "
<< "Serious trouble happend. INFO = " << INFO << "."
<< std::endl;
}
return INFO;
}
int dgesvd2_(char *jobu, char *jobvt, long int *m, long int *n,
double *a, long int *lda, double *s, double *u, long int *
ldu, double *vt, long int *ldvt, double *work, long int *lwork,
long int *info) {
return dgesvd_(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, info);
}
void VarproFunction::computeDefaultRTheta( gsl_matrix *RTheta ) {
size_t c_size1 = getN(), c_size2 = getNrow();
size_t status = 0;
size_t minus1 = -1;
double tmp;
gsl_matrix * tempc = gsl_matrix_alloc(c_size1, c_size2);
if (myPhi == NULL) {
gsl_matrix_memcpy(tempc, myMatr);
} else {
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1, myMatr, myPhi, 0, tempc);
}
gsl_matrix * tempu = gsl_matrix_alloc(c_size2, c_size2);
double *s = new double[mymin(c_size1, c_size2)];
/* Determine optimal work */
size_t lwork;
dgesvd_("A", "N", &tempc->size2, &tempc->size1, tempc->data, &tempc->tda, s,
tempu->data, &tempu->size2, NULL, &tempc->size1, &tmp, &minus1, &status);
double *work = new double[(lwork = tmp)];
/* Compute low-rank approximation */
dgesvd_("A", "N", &tempc->size2, &tempc->size1, tempc->data, &tempc->tda, s,
tempu->data, &tempu->size2, NULL, &tempc->size1, work, &lwork, &status);
if (status) {
delete [] s;
delete [] work;
gsl_matrix_free(tempc);
gsl_matrix_free(tempu);
throw new Exception("Error computing initial approximation: "
"DGESVD didn't converge\n");
}
gsl_matrix_transpose(tempu);
gsl_matrix_view RlraT;
RlraT = gsl_matrix_submatrix(tempu, 0, tempu->size2 - RTheta->size2,
tempu->size1, RTheta->size2);
gsl_matrix_memcpy(RTheta, &(RlraT.matrix));
delete [] s;
delete [] work;
gsl_matrix_free(tempc);
gsl_matrix_free(tempu);
}
bool CMatrixFactorization<double>::SVD(const CDenseArray<double>& A, CDenseArray<double>& U, CDenseArray<double>& S, CDenseArray<double>& Vt) {
// check dimensions
if(U.NCols()!=A.NRows() || U.NRows()!=A.NRows() || Vt.NCols()!=A.NCols() || Vt.NRows()!=A.NCols() || S.NElems()!=min(A.NRows(),A.NCols())) {
cout << "ERROR: Dimension mismatch." << endl;
return 1;
}
// init
int m, n, lda, ldu, ldvt, info, lwork;
m = A.NRows();
n = A.NCols();
lda = m;
ldu = m;
ldvt = n;
lwork = -1;
double wkopt;
double* work;
double* a = A.Data().get();
double* s = S.Data().get();
double* u = U.Data().get();
double* vt = Vt.Data().get();
dgesvd_("A","A",&m,&n,a,&lda,s,u,&ldu,vt,&ldvt,&wkopt,&lwork,&info);
lwork = (int)wkopt;
work = (double*)malloc(lwork*sizeof(double));
dgesvd_("All","All",&m,&n,a,&lda,s,u,&ldu,vt,&ldvt,work,&lwork,&info);
if(info>0) {
cout << "ERROR: The algorithm computing SVD failed to converge." << endl;
return 1;
}
return 0;
}
int Cov_SVD_withV(double* Pts, unsigned long nPts, unsigned long nDim,double *S, double *V) {
// double *S;
__CLPK_integer info = 0;
if( MIN(nDim,nPts)==0 )
return info;
double* MeanPt = new double[nDim];
// Compute the mean of the points
unsigned long int k, j;
for (j = 0; j < (unsigned long) nDim; j++) {
MeanPt[j] = 0;
for (k = 0; k < (unsigned long) nPts; k++)
MeanPt[j] += Pts[k * nDim + j];
MeanPt[j] /= nPts;
}
// Center the points and normalize by 1/\sqrt{n}
double sqrtnPts = sqrt((double) nPts);
for (k = 0; k < (unsigned long) nPts; k++)
for (j = 0; j < (unsigned long) nDim; j++)
Pts[k * nDim + j] = (Pts[k * nDim + j] - MeanPt[j]) / sqrtnPts;
// Calculate SVD
__CLPK_integer m = (__CLPK_integer)nDim; // rows
__CLPK_integer n = (__CLPK_integer)nPts; // coloumns
__CLPK_integer lapack_workl = 20*MIN(m,n);
uint64_t clock_start = mach_absolute_time();
__CLPK_doublereal *lapack_work = (__CLPK_doublereal*)malloc(lapack_workl*sizeof(__CLPK_doublereal));
// double MemoryAllocation_t = subtractTimes( mach_absolute_time(), clock_start );
char lapack_param[1] = {'A'}; //the first min(m,n) rows of V**T (the right singular vectors) are returned in the array VT;
char lapack_param1[1] = {'n'};
clock_start = mach_absolute_time();
dgesvd_(lapack_param1, lapack_param, &m, &n, Pts, &m, S, NULL, &m, V, &n, lapack_work, &lapack_workl, &info);
// double dgesvd_t = subtractTimes( mach_absolute_time(), clock_start );
// Handle error conditions
if (info)
printf("Could not compute SVD with error %d\n", info);
else {
/* printf("\n Solution is:\n");
for( unsigned int k = 0; k<NUM_VARIABLES; k++ )
printf("%f,", S[k]);
printf("\n");*/
}
free( lapack_work );
return info;
}
svd::svd(int m, int n, int lda, double* a,double *u,double *s,double *vt)
{
/* Description: Singular Value Decomposition
find the least squares coefficients by using generic singular value decomposition
Author - Arpan Kusari
Version - 1.0
Input:
m - number of rows of matrix M
n - number of columns of matrix M
lda - leading dimension of the matrix
a - Matrix pointer
Output:
del - least square coefficients of the matrix by finding SVD of the matrix
Functions:
dgesvd_ - function using CLAPACK library to send the singular values of the matrix along with the left and right singular vectors
Usage:
A = U*S*Vt
For the smallest corresponding singular value, the right singular vector (the row of Vt) should provide the coefficients of the matrix.
*/
//Setup a buffer to hold singular values
double wkopt;
double* work;
int lwork = -1;
int info = 0;
dgesvd_("S", "All", &m, &n, a, &lda, s, u, &m, vt, &n, &wkopt, &lwork, &info);
if(info)
exit(1);
lwork = (int)wkopt;
work = (double*)malloc(lwork*sizeof(double));
dgesvd_("S", "All", &m, &n, a, &lda, s, u, &m, vt, &n, work, &lwork, &info);
if(info)
exit(1);
free(work);
}
void THLapack_(gesvd)(char jobu, char jobvt, int m, int n, real *a, int lda, real *s, real *u, int ldu, real *vt, int ldvt, real *work, int lwork, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
dgesvd_( &jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, info);
#else
sgesvd_( &jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, info);
#endif
#else
THError("gesvd : Lapack library not found in compile time\n");
#endif
}
static void singular_vectors(Agraph_t* g, mat x, int power, mat u, double* s)
{
int i, j, loc, n = x->c, k = x->r;
int lda = n, ldu = n, ldvt = k, info, lwork = -1;
mat c = sample_cols(g,x,power);
double* c_lapack = (double*) malloc(sizeof(double)*n*k);
double* s_lapack = (double*) malloc(sizeof(double)*k);
double* u_lapack = (double*) malloc(sizeof(double)*n*k);
double* vt_lapack = (double*) malloc(sizeof(double)*k*k);
double* work;
double wkopt;
loc = 0;
for(j = 0; j < c->c; j++) {//Write c into array in column major order
for(i = 0; i < c->r; i++) {
c_lapack[loc++] = c->m[mindex(i,j,c)];
}
}
//Query for optimal size of work array
dgesvd_("S","S", &n, &k, c_lapack, &lda, s_lapack, u_lapack, &ldu, vt_lapack, &ldvt, &wkopt, &lwork, &info);
lwork = (int)wkopt;
work = (double*) malloc(sizeof(double)*lwork);
//Compute svd
dgesvd_("S","S", &n, &k, c_lapack, &lda, s_lapack, u_lapack, &ldu, vt_lapack, &ldvt, work, &lwork, &info);
for(i = 0; i < n; i++) {
for(j = 0; j < k; j++) {
u->m[mindex(i,j,u)] = u_lapack[i+j*ldu];
}
}
for(i = 0; i < k; i++) {
s[i] = s_lapack[i];
}
mat_free(c);
free(c_lapack);
free(s_lapack);
free(u_lapack);
free(vt_lapack);
free(work);
}
void dgesvd(char jobu, char jobvt, int m, int n, double *da,
int lda, double *s, double *du, int ldu, double
*dvt, int ldvt, int *info)
{
double *work;
int lwork ;
lwork = MAX(3*MIN(m,n)+MAX(m,n),5*MIN(m,n)-4) * 2 ;
allot ( double *, work, lwork ) ;
dgesvd_ ( &jobu, &jobvt, &m, &n, da, &lda, s, du, &ldu, dvt, &ldvt,
work, &lwork, info );
free(work) ;
}
//matrices are column major
void Normal::svd(int M,int N,double* A,double *U, double* S, double* VT) {
int info, lwork=5*(M>N?N:M);
double* work = new double[lwork];
char jobu = 'A', jobvt = 'A';
dgesvd_(&jobu, &jobvt, &M, &N, A, &M,
S, U, &M, VT, &N, work, &lwork, &info);
// printf("info: %d\n",info);
// printf("optimal: %f\n",work[0]);
if (info!=0) {
printf("Error in subroutine dgesvd_ (info=%d)\n",info);
}
delete[] work;
}
void THLapack_(gesvd)(char jobu, char jobvt, int m, int n, real *a, int lda, real *s, real *u, int ldu, real *vt, int ldvt, real *work, int lwork, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
extern void dgesvd_(char *jobu, char *jobvt, int *m, int *n, double *a, int *lda, double *s, double *u, int *ldu, double *vt, int *ldvt, double *work, int *lwork, int *info);
dgesvd_( &jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, info);
#else
extern void sgesvd_(char *jobu, char *jobvt, int *m, int *n, float *a, int *lda, float *s, float *u, int *ldu, float *vt, int *ldvt, float *work, int *lwork, int *info);
sgesvd_( &jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, info);
#endif
#else
THError("gesvd : Lapack library not found in compile time\n");
#endif
}
/** Calculates inverse _and_ inverse square root of a square matrix via SVD.
* @param m - matrix size
* @param S - input: matrix; output: S^-1
* @param D - output: S^-1/2
* @return lapack_info from dgesvd_() (0 = success)
*/
static int invsqrtm2(int m, double alpha, double** S, double** D)
{
double** U = alloc2d(m, m, sizeof(double));
double** Us1 = alloc2d(m, m, sizeof(double));
double** Us2 = alloc2d(m, m, sizeof(double));
double* sigmas = malloc(m * sizeof(double));
int lwork = 10 * m;
double* work = malloc(lwork * sizeof(double));
char specU = 'A'; /* "all M columns of U are returned in array
* * U" */
char specV = 'N'; /* "no rows of V**T are computed" */
int lapack_info;
double a = 1.0;
double b = 0.0;
int i, j;
dgesvd_(&specU, &specV, &m, &m, S[0], &m, sigmas, U[0], &m, NULL, &m, work, &lwork, &lapack_info);
if (lapack_info != 0) {
free(U);
free(Us1);
free(Us2);
free(sigmas);
free(work);
return lapack_info;
}
for (i = 0; i < m; ++i) {
double* Ui = U[i];
double* Us1i = Us1[i];
double* Us2i = Us2[i];
double si = sigmas[i];
double si_sqrt = sqrt(1.0 - alpha + alpha * sigmas[i]);
for (j = 0; j < m; ++j) {
Us1i[j] = Ui[j] / si;
Us2i[j] = Ui[j] / si_sqrt;
}
}
dgemm_(&noT, &doT, &m, &m, &m, &a, Us1[0], &m, U[0], &m, &b, S[0], &m);
dgemm_(&noT, &doT, &m, &m, &m, &a, Us2[0], &m, U[0], &m, &b, D[0], &m);
free(U);
free(Us1);
free(Us2);
free(sigmas);
free(work);
return 0;
}
void compute_svd_vals(full_matrix *mat, svd_scratch *svd, double *svals)
{
char jobu = 'N';
char jobvt = 'N';
int ldu = 1;
int ldvt = 1;
int info;
double u;
double vt;
dgesvd_(&jobu, &jobvt, &(mat->m), &(mat->n), mat->val, &(mat->m),
svals, &u, &ldu, &vt, &ldvt, svd->work, &(svd->lwork),
&info);
}
double SVD(double *G, double *Factors, double *Lambda, int K, int nSNP, int nIND){
double *U = calloc(nSNP*nSNP, sizeof(double));
double *Vt = calloc(nIND*nIND, sizeof(double));
double *A = calloc(nIND*nSNP, sizeof(double));
double *FLambda = calloc(nIND*nSNP, sizeof(double));
long int i, j, m = nSNP, n = nIND;
long int min_mn = (m < n) ? m : n;
long int lda= m, ldu=m, ldv=n, lwork=m*n;
long int *iwork = calloc(8*min_mn, sizeof(long int));
double *singValues = calloc(min_mn, sizeof(double));
double *work = calloc(lwork, sizeof(double));
double sqerr = 0;
double *err = calloc(n, sizeof(double));
long int info, job = 21;
for (i=0; i<nSNP; i++){
for (j=0; j<nIND; j++){
A[j*nSNP + i] = G[i*nIND + j];
}
}
int res = dgesvd_("a", "a", (integer *) &m, (integer *) &n, (doublereal *) A, (integer *) &lda, (doublereal *) singValues, (doublereal *) U, (integer *) &ldu, (doublereal *) Vt, (integer *) &ldv, (doublereal *) work, (integer *) &lwork, (integer *) &info);
for (i=0; i<nSNP; i++){
for (j=0; j<K; j++){
Factors[i*K + j] = U[j*ldu + i]*singValues[j];
}
}
for (i=0; i<K; i++){
for (j=0; j<nIND; j++){
Lambda[i*nIND + j] = Vt[j*ldv + i];
}
}
prodMatrix(Factors, Lambda, FLambda, nSNP, K, K, nIND);
for (i=0; i<nSNP*nIND; i++) sqerr += (FLambda[i] - G[i])*(FLambda[i] - G[i])/(nSNP*nIND);
free(U);
free(err);
free(Vt);
free(work);
free(iwork);
free(singValues);
free(FLambda);
free(A);
return sqerr;
}
/* Compute singular value decomposition of an m x n matrix A */
int dgesvd_driver(int m, int n, double *A, double *U, double *S, double *VT) {
double *AT, *UT, *V;
char jobu = 'a';
char jobvt = 'a';
int lda = m;
int ldu = m;
int ldvt = n;
int lwork = 10 * MAX(3 * MIN(m, n) + MAX(m, n), 5 * MIN(m, n));
double *work;
int info;
/* Transpose A */
AT = (double *)malloc(sizeof(double) * m * n);
matrix_transpose(m, n, A, AT);
/* Create temporary matrices for output of dgesvd */
UT = (double *)malloc(sizeof(double) * m * m);
V = (double *)malloc(sizeof(double) * n * n);
work = malloc(sizeof(double) * lwork);
dgesvd_(&jobu, &jobvt, &m, &n, AT, &lda, S, UT, &ldu, V, &ldvt, work, &lwork, &info);
if (info != 0) {
printf("[dgesvd_driver] An error occurred\n");
}
matrix_transpose(m, m, UT, U);
matrix_transpose(n, n, V, VT);
free(AT);
free(UT);
free(V);
free(work);
if (info == 0)
return 1;
else
return 0;
}
// lapack_svd computes the singular value decomposition: A = U_mxm * D_mxn * Vt_nxn
// Note: the output arrays must have the following sizes:
// U [m * m]
// S [min(m,n)]
// Vt [n * n]
// Note: M matrix will be modified in this method
// Return codes:
// 0 : no problems
// 1 : make_int failed
// 2 : svd failed
int lapack_svd(double *U, double *S, double *Vt, long m_long, long n_long, double *A) {
// matrix size
int m, n;
int info = make_int(&m, m_long);
if (info != 0) return 1;
info = make_int(&n, n_long);
if (info != 0) return 1;
// auxiliary variables
char job = 'A';
int min_mn = min(m, n);
int max_mn = max(m, n);
int lwork = 2.0 * max(3 * min_mn + max_mn, 5 * min_mn);
// auxiliary arrays
double * work = (double*)malloc(lwork * sizeof(double));
// decomposition
dgesvd_(&job, // JOBU
&job, // JOBVT
&m, // M
&n, // N
A, // A
&m, // LDA
S, // S
U, // U
&m, // LDU
Vt, // VT
&n, // LDVT
work, // WORK
&lwork, // LWORK
&info); // INFO
// clean-up
free(work);
// check
if (info != 0) {
return 2;
}
return 0;
}
void Matrix3x3::SVD(double* U, double* s, double* VT, const double* A)
{
#ifndef OPEN3DMOTION_LINEAR_ALGEBRA_EIGEN
long three(3);
Matrix3x3 Acpy(A);
long lwork(256);
double work[256];
long info(0);
// use lapack routine
// - note U and VT are swapped
// - this is because of the fortran column-major
// ordering for matrices - it turns out that
// using a row major matrix here corresponds to
// swapping U and VT
dgesvd_(
"A", // all of U
"A", // all of VT
&three, // rows
&three, // cols
Acpy, // input/output matrix
&three, // leading dimension of Acpy
s, // singular values
VT, // left orthonormal matrix
&three, // leading dimension of left
U, // right orthonormal matrix
&three, // leading dimension of right
work, // workspace
&lwork, // size of workspace
&info); // returned error codes
#else
Eigen::Map< const Eigen::Matrix<double, 3, 3, Eigen::RowMajor> > _A(A, 3, 3);
Eigen::Map< Eigen::Matrix<double, 3, 3, Eigen::RowMajor> > _U(U, 3, 3);
Eigen::Map< Eigen::Matrix<double, 3, 3, Eigen::RowMajor> > _VT(VT, 3, 3);
Eigen::Map< Eigen::Matrix<double, 3, 1> > _s(s, 3, 1);
Eigen::JacobiSVD< Eigen::Matrix<double, 3, 3, Eigen::RowMajor> > svd(_A, Eigen::ComputeFullU | Eigen::ComputeFullV);
_U = svd.matrixU();
_VT = svd.matrixV().transpose();
_s = svd.singularValues();
#endif
}
inline void
svd_call( svd_params< double >& p )
{
//std::cout << "calling lapack svd (double precision) " << std::endl;
dgesvd_(
&p.jobu,
&p.jobvt,
&p.m,
&p.n,
p.a,
&p.lda,
p.s,
p.u,
&p.ldu,
p.vt,
&p.ldvt,
p.work,
&p.lwork,
&p.info
);
}
int compute_svd_scratch(full_matrix *mat)
{
char jobu;
char jobvt;
double s;
double work;
int lwork;
int info;
double vt;
double u;
int ldu = 1;
int ldvt = 1;
jobu = 'N';
jobvt = 'N';
lwork = -1;
dgesvd_(&jobu, &jobvt, &(mat->m), &(mat->n), mat->val, &(mat->m),
&s, &u, &ldu, &vt, &ldvt, &work, &lwork, &info);
return (int) work;
}
/*
shrink(double** A, double t, int M) applies the shrink operator on A with thresholding parameter t.
The idea is to compute the SVD of A, A=U*S*V, then create the matrix B
B = U * S2 * V,
where S2_{i,i} = S_{i,i} if ((S_{i,i}-)*t>0) and
S2_{i,i} = 0 otherwise.
Then it returns B.
*/
double* shrink(double* A, double tau, int nrows, int ncols, char method){
int i;
int info = 0;
char JOBU = 'A';
char JOBVT = 'A';
int LWORK = fmax(fmax(1,3*fmin(nrows,ncols)+fmax(nrows,ncols)),5*fmin(nrows,ncols));
double* WORK = alloc_array(1, LWORK);
double* U = alloc_array(nrows, nrows);
double* VT = alloc_array(ncols, ncols);
double* S = alloc_array(fmin(nrows,ncols), fmin(nrows, ncols));
int min_dim = fmin(nrows,ncols);
dgesvd_(&JOBU, &JOBVT, &nrows, &ncols, A, &nrows, S, U, &nrows, VT, &ncols, WORK, &LWORK, &info);
if( method == 'S' ){
for( i = 0; i < min_dim; i++){
S[i] = fmax(0.0, S[i] - tau);
}
}
else if( method == 'P' ){
#pragma omp parallel for
for(i=0; i < min_dim;i++){
S[i] = fmax(0.0, S[i] - tau);
}
}
double* C = alloc_array_z(nrows,ncols);
//C = mm(mm(U, nrows, nrows, 't', diag(S,nrows, ncols), nrows, ncols, 'n'), nrows, ncols, 'n', VT, ncols, ncols, 't');
C = mm(mm(VT, ncols, ncols, 'n', diag(S,ncols, nrows), ncols, nrows, 'n'), ncols, nrows, 'n', U, nrows, nrows, 'n');
//free_array(A);
free_array(WORK);
free_array(U);
free_array(VT);
free_array(S);
return C;
}
//svd: m = u*s*vt (vt is the transposed matrix of v)
static PyObject* mh_dgesvd(PyObject *self, PyObject *args)
{
int dim;
PyObject *_m, *_u, *_s, *_vt;
double *m, *s, *u, *vt, *work; //s = singular values of m sorted by s(i)>s(i+1)
int i,j;
long lwork = -1;
long info = 0;
char a[] = "A"; //returns all the rows of U and V (full svd)
char b[] = "A"; //be careful when using lapack and blas methods even if the parameters have the same value they should be sent with different pointers
if (!PyArg_ParseTuple(args, "Oii", &_m, &i, &j))
return NULL;
// need to be freed in the end
m = PyObj2DoublePtr(_m, i*j);
if (m==NULL)
return NULL;
// do something with m
//free in the end
dim = min(i,j);
u = (double*)malloc(i*i*sizeof(double));
s = (double*)malloc(dim*sizeof(double));
vt = (double*)malloc(j*j*sizeof(double));
lwork = 5*(i+j);
work = (double*)malloc(lwork*sizeof(double));
dgesvd_(a, b, (long*)&i, (long*)&j, m, (long*)&i, s, u, (long*)&i, vt, (long*)&j, work, &lwork, &info);
_u = double2PyObj(u, i, i);
_vt = double2PyObj(vt, j, j);
_s = double2PyObj(s, i, j);
free(work); free(vt); free(s); free(u); free(m);
return Py_BuildValue("[O,O,O]", _u, _s, _vt);
}
void RigidBodyShape::EvaluateNonsingularity3D(std::vector<double>& s, std::vector<double>& coords)
{
long num_points(coords.size() / 3);
s.resize(3);
#ifndef OPEN3DMOTION_LINEAR_ALGEBRA_EIGEN
long three(3);
long lwork(256);
double work[256];
long info(0);
std::vector<double> U(9);
std::vector<double> VT(num_points*num_points);
// use lapack routine
// note coords must be column-major so first 3 elements correspond to first coord
dgesvd_(
"N", // don't actually need U
"N", // don't actually need VT
&three, // rows
&num_points, // cols
&coords[0], // input/output matrix
&three, // leading dimension of Acpy
&s[0], // singular values
&U[0], // left orthonormal matrix
&three, // leading dimension of left
&VT[0], // right orthonormal matrix
&num_points, // leading dimension of right
work, // workspace
&lwork, // size of workspace
&info); // returned error codes
#else
Eigen::Map< Eigen::Matrix<double, Eigen::Dynamic, 3, Eigen::RowMajor> >
_coords(&coords[0], (int)num_points, 3);
Eigen::Map< Eigen::Matrix<double, 3, 1> > _s(&s[0], 3, 1);
Eigen::JacobiSVD< Eigen::Matrix<double, Eigen::Dynamic, 3, Eigen::RowMajor> > svd(_coords);
_s = svd.singularValues();
#endif // OPEN3DMOTION_LINEAR_ALGEBRA_EIGEN
}
GURLS_EXPORT int gesvd_(char *jobu, char *jobvt, int *m, int *n, double *a, int *lda, double *s, double *u, int *ldu, double *vt, int *ldvt, double *work, int *lwork, int *info)
{
return dgesvd_(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, info);
}
/* Subroutine */ int dlatm6_(integer *type__, integer *n, doublereal *a,
integer *lda, doublereal *b, doublereal *x, integer *ldx, doublereal *
y, integer *ldy, doublereal *alpha, doublereal *beta, doublereal *wx,
doublereal *wy, doublereal *s, doublereal *dif)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1,
y_offset, i__1, i__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal z__[144] /* was [12][12] */;
integer info;
doublereal work[100];
extern /* Subroutine */ int dlakf2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *), dgesvd_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLATM6 generates test matrices for the generalized eigenvalue */
/* problem, their corresponding right and left eigenvector matrices, */
/* and also reciprocal condition numbers for all eigenvalues and */
/* the reciprocal condition numbers of eigenvectors corresponding to */
/* the 1th and 5th eigenvalues. */
/* Test Matrices */
/* ============= */
/* Two kinds of test matrix pairs */
/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
/* are used in the tests: */
/* Type 1: */
/* Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
/* 0 2+a 0 0 0 0 1 0 0 0 */
/* 0 0 3+a 0 0 0 0 1 0 0 */
/* 0 0 0 4+a 0 0 0 0 1 0 */
/* 0 0 0 0 5+a , 0 0 0 0 1 , and */
/* Type 2: */
/* Da = 1 -1 0 0 0 Db = 1 0 0 0 0 */
/* 1 1 0 0 0 0 1 0 0 0 */
/* 0 0 1 0 0 0 0 1 0 0 */
/* 0 0 0 1+a 1+b 0 0 0 1 0 */
/* 0 0 0 -1-b 1+a , 0 0 0 0 1 . */
/* In both cases the same inverse(YH) and inverse(X) are used to compute */
/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
/* 0 1 -y y -y 0 1 x -x -x */
/* 0 0 1 0 0 0 0 1 0 0 */
/* 0 0 0 1 0 0 0 0 1 0 */
/* 0 0 0 0 1, 0 0 0 0 1 , */
/* where a, b, x and y will have all values independently of each other. */
/* Arguments */
/* ========= */
/* TYPE (input) INTEGER */
/* Specifies the problem type (see futher details). */
/* N (input) INTEGER */
/* Size of the matrices A and B. */
/* A (output) DOUBLE PRECISION array, dimension (LDA, N). */
/* On exit A N-by-N is initialized according to TYPE. */
/* LDA (input) INTEGER */
/* The leading dimension of A and of B. */
/* B (output) DOUBLE PRECISION array, dimension (LDA, N). */
/* On exit B N-by-N is initialized according to TYPE. */
/* X (output) DOUBLE PRECISION array, dimension (LDX, N). */
/* On exit X is the N-by-N matrix of right eigenvectors. */
/* LDX (input) INTEGER */
/* The leading dimension of X. */
/* Y (output) DOUBLE PRECISION array, dimension (LDY, N). */
/* On exit Y is the N-by-N matrix of left eigenvectors. */
/* LDY (input) INTEGER */
/* The leading dimension of Y. */
/* ALPHA (input) DOUBLE PRECISION */
/* BETA (input) DOUBLE PRECISION */
/* Weighting constants for matrix A. */
/* WX (input) DOUBLE PRECISION */
/* Constant for right eigenvector matrix. */
/* WY (input) DOUBLE PRECISION */
/* Constant for left eigenvector matrix. */
/* S (output) DOUBLE PRECISION array, dimension (N) */
/* S(i) is the reciprocal condition number for eigenvalue i. */
/* DIF (output) DOUBLE PRECISION array, dimension (N) */
/* DIF(i) is the reciprocal condition number for eigenvector i. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Generate test problem ... */
/* (Da, Db) ... */
/* Parameter adjustments */
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
--s;
--dif;
/* Function Body */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (i__ == j) {
a[i__ + i__ * a_dim1] = (doublereal) i__ + *alpha;
b[i__ + i__ * b_dim1] = 1.;
} else {
a[i__ + j * a_dim1] = 0.;
b[i__ + j * b_dim1] = 0.;
}
/* L10: */
}
/* L20: */
}
/* Form X and Y */
dlacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy);
y[y_dim1 + 3] = -(*wy);
y[y_dim1 + 4] = *wy;
y[y_dim1 + 5] = -(*wy);
y[(y_dim1 << 1) + 3] = -(*wy);
y[(y_dim1 << 1) + 4] = *wy;
y[(y_dim1 << 1) + 5] = -(*wy);
dlacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx);
x[x_dim1 * 3 + 1] = -(*wx);
x[(x_dim1 << 2) + 1] = -(*wx);
x[x_dim1 * 5 + 1] = *wx;
x[x_dim1 * 3 + 2] = *wx;
x[(x_dim1 << 2) + 2] = -(*wx);
x[x_dim1 * 5 + 2] = -(*wx);
/* Form (A, B) */
b[b_dim1 * 3 + 1] = *wx + *wy;
b[b_dim1 * 3 + 2] = -(*wx) + *wy;
b[(b_dim1 << 2) + 1] = *wx - *wy;
b[(b_dim1 << 2) + 2] = *wx - *wy;
b[b_dim1 * 5 + 1] = -(*wx) + *wy;
b[b_dim1 * 5 + 2] = *wx + *wy;
if (*type__ == 1) {
a[a_dim1 * 3 + 1] = *wx * a[a_dim1 + 1] + *wy * a[a_dim1 * 3 + 3];
a[a_dim1 * 3 + 2] = -(*wx) * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 *
3 + 3];
a[(a_dim1 << 2) + 1] = *wx * a[a_dim1 + 1] - *wy * a[(a_dim1 << 2) +
4];
a[(a_dim1 << 2) + 2] = *wx * a[(a_dim1 << 1) + 2] - *wy * a[(a_dim1 <<
2) + 4];
a[a_dim1 * 5 + 1] = -(*wx) * a[a_dim1 + 1] + *wy * a[a_dim1 * 5 + 5];
a[a_dim1 * 5 + 2] = *wx * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 * 5 +
5];
} else if (*type__ == 2) {
a[a_dim1 * 3 + 1] = *wx * 2. + *wy;
a[a_dim1 * 3 + 2] = *wy;
a[(a_dim1 << 2) + 1] = -(*wy) * (*alpha + 2. + *beta);
a[(a_dim1 << 2) + 2] = *wx * 2. - *wy * (*alpha + 2. + *beta);
a[a_dim1 * 5 + 1] = *wx * -2. + *wy * (*alpha - *beta);
a[a_dim1 * 5 + 2] = *wy * (*alpha - *beta);
a[a_dim1 + 1] = 1.;
a[(a_dim1 << 1) + 1] = -1.;
a[a_dim1 + 2] = 1.;
a[(a_dim1 << 1) + 2] = a[a_dim1 + 1];
a[a_dim1 * 3 + 3] = 1.;
a[(a_dim1 << 2) + 4] = *alpha + 1.;
a[a_dim1 * 5 + 4] = *beta + 1.;
a[(a_dim1 << 2) + 5] = -a[a_dim1 * 5 + 4];
a[a_dim1 * 5 + 5] = a[(a_dim1 << 2) + 4];
}
/* Compute condition numbers */
if (*type__ == 1) {
s[1] = 1. / sqrt((*wy * 3. * *wy + 1.) / (a[a_dim1 + 1] * a[a_dim1 +
1] + 1.));
s[2] = 1. / sqrt((*wy * 3. * *wy + 1.) / (a[(a_dim1 << 1) + 2] * a[(
a_dim1 << 1) + 2] + 1.));
s[3] = 1. / sqrt((*wx * 2. * *wx + 1.) / (a[a_dim1 * 3 + 3] * a[
a_dim1 * 3 + 3] + 1.));
s[4] = 1. / sqrt((*wx * 2. * *wx + 1.) / (a[(a_dim1 << 2) + 4] * a[(
a_dim1 << 2) + 4] + 1.));
s[5] = 1. / sqrt((*wx * 2. * *wx + 1.) / (a[a_dim1 * 5 + 5] * a[
a_dim1 * 5 + 5] + 1.));
dlakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[
b_offset], &b[(b_dim1 << 1) + 2], z__, &c__12);
dgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, &
work[9], &c__1, &work[10], &c__40, &info);
dif[1] = work[7];
dlakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[
b_offset], &b[b_dim1 * 5 + 5], z__, &c__12);
dgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, &
work[9], &c__1, &work[10], &c__40, &info);
dif[5] = work[7];
} else if (*type__ == 2) {
s[1] = 1. / sqrt(*wy * *wy + .33333333333333331);
s[2] = s[1];
s[3] = 1. / sqrt(*wx * *wx + .5);
s[4] = 1. / sqrt((*wx * 2. * *wx + 1.) / ((*alpha + 1.) * (*alpha +
1.) + 1. + (*beta + 1.) * (*beta + 1.)));
s[5] = s[4];
dlakf2_(&c__2, &c__3, &a[a_offset], lda, &a[a_dim1 * 3 + 3], &b[
b_offset], &b[b_dim1 * 3 + 3], z__, &c__12);
dgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1,
&work[13], &c__1, &work[14], &c__60, &info);
dif[1] = work[11];
dlakf2_(&c__3, &c__2, &a[a_offset], lda, &a[(a_dim1 << 2) + 4], &b[
b_offset], &b[(b_dim1 << 2) + 4], z__, &c__12);
dgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1,
&work[13], &c__1, &work[14], &c__60, &info);
dif[5] = work[11];
}
return 0;
/* End of DLATM6 */
} /* dlatm6_ */
bool CFitProblem::calculateStatistics(const C_FLOAT64 & factor,
const C_FLOAT64 & resolution)
{
// Set the current values to the solution values.
unsigned C_INT32 i, imax = mSolutionVariables.size();
unsigned C_INT32 j, jmax = mExperimentDependentValues.size();
unsigned C_INT32 l;
mRMS = std::numeric_limits<C_FLOAT64>::quiet_NaN();
mSD = std::numeric_limits<C_FLOAT64>::quiet_NaN();
mParameterSD.resize(imax);
mParameterSD = std::numeric_limits<C_FLOAT64>::quiet_NaN();
mFisher = std::numeric_limits<C_FLOAT64>::quiet_NaN();
mGradient.resize(imax);
mGradient = std::numeric_limits<C_FLOAT64>::quiet_NaN();
// Recalcuate the best solution.
for (i = 0; i < imax; i++)
(*mUpdateMethods[i])(mSolutionVariables[i]);
mStoreResults = true;
calculate();
// Keep the results
CVector< C_FLOAT64 > DependentValues = mExperimentDependentValues;
if (mSolutionValue == mInfinity)
return false;
// The statistics need to be calculated for the result, i.e., now.
mpExperimentSet->calculateStatistics();
if (jmax)
mRMS = sqrt(mSolutionValue / jmax);
if (jmax > imax)
mSD = sqrt(mSolutionValue / (jmax - imax));
mHaveStatistics = true;
CMatrix< C_FLOAT64 > dyp;
bool CalculateFIM = true;
try
{
dyp.resize(imax, jmax);
}
catch (CCopasiException Exception)
{
CalculateFIM = false;
}
C_FLOAT64 Current;
C_FLOAT64 Delta;
// Calculate the gradient
for (i = 0; i < imax; i++)
{
Current = mSolutionVariables[i];
if (fabs(Current) > resolution)
{
(*mUpdateMethods[i])(Current *(1.0 + factor));
Delta = 1.0 / (Current * factor);
}
else
{
(*mUpdateMethods[i])(resolution);
Delta = 1.0 / resolution;
}
calculate();
mGradient[i] = (mCalculateValue - mSolutionValue) * Delta;
if (CalculateFIM)
for (j = 0; j < jmax; j++)
dyp(i, j) = (mExperimentDependentValues[j] - DependentValues[j]) * Delta;
// Restore the value
(*mUpdateMethods[i])(Current);
}
// This is necessary so that CExperiment::printResult shows the correct data.
calculate();
mStoreResults = false;
if (!CalculateFIM)
{
// Make sure the timer is acurate.
(*mCPUTime.getRefresh())();
CCopasiMessage(CCopasiMessage::WARNING, MCFitting + 13);
return false;
}
// Construct the fisher information matrix
for (i = 0; i < imax; i++)
for (l = 0; l <= i; l++)
{
C_FLOAT64 & tmp = mFisher(i, l);
tmp = 0.0;
for (j = 0; j < jmax; j++)
tmp += dyp(i, j) * dyp(l, j);
tmp *= 2.0;
if (l != i)
mFisher(l, i) = tmp;
}
mCorrelation = mFisher;
#ifdef XXXX
/* int dgetrf_(integer *m,
* integer *n,
* doublereal *a,
* integer * lda,
* integer *ipiv,
* integer *info)
*
* Purpose
* =======
*
* DGETRF computes an LU factorization of a general M-by-N matrix A
* using partial pivoting with row interchanges.
*
* The factorization has the form
* A = P * L * U
* where P is a permutation matrix, L is lower triangular with unit
* diagonal elements (lower trapezoidal if m > n), and U is upper
* triangular (upper trapezoidal if m < n).
*
* This is the right-looking Level 3 BLAS version of the algorithm.
*
* Arguments
* =========
*
* m (input) INTEGER
* The number of rows of the matrix A. m >= 0.
*
* n (input) INTEGER
* The number of columns of the matrix A. n >= 0.
*
* a (input/output) DOUBLE PRECISION array, dimension (lda,n)
* On entry, the m by n matrix to be factored.
* On exit, the factors L and U from the factorization
* A = P*L*U; the unit diagonal elements of L are not stored.
*
* lda (input) INTEGER
* The leading dimension of the array A. lda >= max(1,m).
*
* ipiv (output) INTEGER array, dimension (min(m,n))
* The pivot indices; for 1 <= i <= min(m,n), row i of the
* matrix was interchanged with row ipiv(i).
*
* info (output) INTEGER
* = 0: successful exit
* < 0: if info = -k, the k-th argument had an illegal value
* > 0: if info = k, U(k,k) is exactly zero. The factorization
* has been completed, but the factor U is exactly
* singular, and division by zero will occur if it is used
* to solve a system of equations.
*/
C_INT info = 0;
C_INT N = imax;
CVector< C_INT > ipiv(imax);
dgetrf_(&N, &N, mCorrelation.array(), &N, ipiv.array(), &info);
if (info)
{
mCorrelation = std::numeric_limits<C_FLOAT64>::quiet_NaN();
mParameterSD = std::numeric_limits<C_FLOAT64>::quiet_NaN();
CCopasiMessage(CCopasiMessage::WARNING, MCFitting + 1, info);
return false;
}
/* dgetri_(integer *n, doublereal *a, integer *lda, integer *ipiv,
* doublereal *work, integer *lwork, integer *info);
*
*
* Purpose
* =======
*
* DGETRI computes the inverse of a matrix using the LU factorization
* computed by DGETRF.
*
* This method inverts U and then computes inv(A) by solving the system
* inv(A)*L = inv(U) for inv(A).
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the factors L and U from the factorization
* A = P*L*U as computed by DGETRF.
* On exit, if INFO = 0, the inverse of the original matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from DGETRF; for 1<=i<=N, row i of the
* matrix was interchanged with row IPIV(i).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,N).
* For optimal performance LWORK >= N*NB, where NB is
* the optimal blocksize returned by ILAENV.
*
* 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.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
* singular and its inverse could not be computed.
*
*/
C_INT lwork = -1; // Instruct dgesvd_ to determine work array size.
CVector< C_FLOAT64 > work;
work.resize(1);
dgetri_(&N, mCorrelation.array(), &N, ipiv.array(), work.array(), &lwork, &info);
if (info)
{
mCorrelation = std::numeric_limits<C_FLOAT64>::quiet_NaN();
mParameterSD = std::numeric_limits<C_FLOAT64>::quiet_NaN();
CCopasiMessage(CCopasiMessage::WARNING, MCFitting + 1, info);
return false;
}
lwork = (C_INT) work[0];
work.resize(lwork);
dgetri_(&N, mCorrelation.array(), &N, ipiv.array(), work.array(), &lwork, &info);
if (info)
{
mCorrelation = std::numeric_limits<C_FLOAT64>::quiet_NaN();
mParameterSD = std::numeric_limits<C_FLOAT64>::quiet_NaN();
CCopasiMessage(CCopasiMessage::WARNING, MCFitting + 1, info);
return false;
}
#endif // XXXX
// The Fisher Information matrix is a symmetric positive semidefinit matrix.
/* int dpotrf_(char *uplo, integer *n, doublereal *a,
* integer *lda, integer *info);
*
*
* Purpose
* =======
*
* DPOTRF computes the Cholesky factorization of a real symmetric
* positive definite matrix A.
*
* The factorization has the form
* A = U**T * U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is lower triangular.
*
* This is the block version of the algorithm, calling Level 3 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the leading minor of order i is not
* positive definite, and the factorization could not be
* completed.
*
*/
char U = 'U';
C_INT info = 0;
C_INT N = imax;
dpotrf_(&U, &N, mCorrelation.array(), &N, &info);
if (info)
{
mCorrelation = std::numeric_limits<C_FLOAT64>::quiet_NaN();
mParameterSD = std::numeric_limits<C_FLOAT64>::quiet_NaN();
CCopasiMessage(CCopasiMessage::WARNING, MCFitting + 12);
return false;
}
/* int dpotri_(char *uplo, integer *n, doublereal *a,
* integer *lda, integer *info);
*
*
* Purpose
* =======
*
* DPOTRI computes the inverse of a real symmetric positive definite
* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
* computed by DPOTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T, as computed by
* DPOTRF.
* On exit, the upper or lower triangle of the (symmetric)
* inverse of A, overwriting the input factor U or L.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the (i,i) element of the factor U or L is
* zero, and the inverse could not be computed.
*
*/
dpotri_(&U, &N, mCorrelation.array(), &N, &info);
if (info)
{
mCorrelation = std::numeric_limits<C_FLOAT64>::quiet_NaN();
mParameterSD = std::numeric_limits<C_FLOAT64>::quiet_NaN();
CCopasiMessage(CCopasiMessage::WARNING, MCFitting + 1, info);
return false;
}
// Assure that the inverse is completed.
for (i = 0; i < imax; i++)
for (l = 0; l < i; l++)
mCorrelation(l, i) = mCorrelation(i, l);
CVector< C_FLOAT64 > S(imax);
#ifdef XXXX
// We invert the Fisher information matrix with the help of singular
// value decomposition.
/* int dgesvd_(char *jobu, char *jobvt, integer *m, integer *n,
* doublereal *a, integer *lda, doublereal *s, doublereal *u,
* integer *ldu, doublereal *vt, integer *ldvt,
* doublereal *work, integer *lwork, integer *info);
*
*
* Purpose
* =======
*
* DGESVD computes the singular value decomposition (SVD) of a real
* M-by-N matrix A, optionally computing the left and/or right singular
* vectors. The SVD is written
*
* A = U * SIGMA * transpose(V)
*
* where SIGMA is an M-by-N matrix which is zero except for its
* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
* are the singular values of A; they are real and non-negative, and
* are returned in descending order. The first min(m,n) columns of
* U and V are the left and right singular vectors of A.
*
* Note that the routine returns V**T, not V.
*
* Arguments
* =========
*
* JOBU (input) CHARACTER*1
* Specifies options for computing all or part of the matrix U:
* = 'A': all M columns of U are returned in array U:
* = 'S': the first min(m,n) columns of U (the left singular
* vectors) are returned in the array U;
* = 'O': the first min(m,n) columns of U (the left singular
* vectors) are overwritten on the array A;
* = 'N': no columns of U (no left singular vectors) are
* computed.
*
* JOBVT (input) CHARACTER*1
* Specifies options for computing all or part of the matrix
* V**T:
* = 'A': all N rows of V**T are returned in the array VT;
* = 'S': the first min(m,n) rows of V**T (the right singular
* vectors) are returned in the array VT;
* = 'O': the first min(m,n) rows of V**T (the right singular
* vectors) are overwritten on the array A;
* = 'N': no rows of V**T (no right singular vectors) are
* computed.
*
* JOBVT and JOBU cannot both be 'O'.
*
* M (input) INTEGER
* The number of rows of the input matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the input matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if JOBU = 'O', A is overwritten with the first min(m,n)
* columns of U (the left singular vectors,
* stored columnwise);
* if JOBVT = 'O', A is overwritten with the first min(m,n)
* rows of V**T (the right singular vectors,
* stored rowwise);
* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
* are destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* S (output) DOUBLE PRECISION array, dimension (min(M,N))
* The singular values of A, sorted so that S(i) >= S(i+1).
*
* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
* If JOBU = 'A', U contains the M-by-M orthogonal matrix U;
* if JOBU = 'S', U contains the first min(m,n) columns of U
* (the left singular vectors, stored columnwise);
* if JOBU = 'N' or 'O', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= 1; if
* JOBU = 'S' or 'A', LDU >= M.
*
* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
* V**T;
* if JOBVT = 'S', VT contains the first min(m,n) rows of
* V**T (the right singular vectors, stored rowwise);
* if JOBVT = 'N' or 'O', VT is not referenced.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= 1; if
* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged
* superdiagonal elements of an upper bidiagonal matrix B
* whose diagonal is in S (not necessarily sorted). B
* satisfies A = U * B * VT, so it has the same singular values
* as A, and singular vectors related by U and VT.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).
* For good performance, LWORK should generally be larger.
*
* 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.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if DBDSQR did not converge, INFO specifies how many
* superdiagonals of an intermediate bidiagonal form B
* did not converge to zero. See the description of WORK
* above for details.
*
*/
char job = 'A';
C_INT info = 0;
C_INT N = imax;
CVector< C_FLOAT64 > S(imax);
CMatrix< C_FLOAT64 > U(imax, imax);
CMatrix< C_FLOAT64 > VT(imax, imax);
C_INT lwork = -1; // Instruct dgesvd_ to determine work array size.
CVector< C_FLOAT64 > work;
work.resize(1);
dgesvd_(&job, &job, &N, &N, mCorrelation.array(), &N, S.array(), U.array(),
&N, VT.array(), &N, work.array(), &lwork, &info);
if (info)
{
mCorrelation = std::numeric_limits<C_FLOAT64>::quiet_NaN();
mParameterSD = std::numeric_limits<C_FLOAT64>::quiet_NaN();
CCopasiMessage(CCopasiMessage::WARNING, MCFitting + 1, info);
return false;
}
lwork = (C_INT) work[0];
work.resize(lwork);
// This actually calculates the SVD of mCorrelation^T, since dgesvd uses
// fortran notation, i.e., mCorrelation = V^T * B^T * U
dgesvd_(&job, &job, &N, &N, mCorrelation.array(), &N, S.array(), U.array(),
&N, VT.array(), &N, work.array(), &lwork, &info);
// Even if info is not zero we are still able to invert
if (info)
{
mCorrelation = std::numeric_limits<C_FLOAT64>::quiet_NaN();
mParameterSD = std::numeric_limits<C_FLOAT64>::quiet_NaN();
CCopasiMessage(CCopasiMessage::WARNING, MCFitting + 1, info);
return false;
}
// Now we invert the Fisher Information Matrix. Please note,
// that we are calculating a pseudo inverse in the case that one or
// more singular values are zero.
mCorrelation = 0.0;
for (i = 0; i < imax; i++)
if (S[i] == 0.0)
mCorrelation(i, i) = 0.0;
else
mCorrelation(i, i) = 1.0 / S[i];
CMatrix< C_FLOAT64 > Tmp(imax, imax);
char opN = 'N';
C_FLOAT64 Alpha = 1.0;
C_FLOAT64 Beta = 0.0;
dgemm_(&opN, &opN, &N, &N, &N, &Alpha, U.array(), &N,
mCorrelation.array(), &N, &Beta, Tmp.array(), &N);
dgemm_(&opN, &opN, &N, &N, &N, &Alpha, Tmp.array(), &N,
VT.array(), &N, &Beta, mCorrelation.array(), &N);
#endif // XXXX
// rescale the lower bound of the covariant matrix to have unit diagonal
for (i = 0; i < imax; i++)
{
C_FLOAT64 & tmp = S[i];
if (mCorrelation(i, i) > 0.0)
{
tmp = 1.0 / sqrt(mCorrelation(i, i));
mParameterSD[i] = mSD / tmp;
}
else if (mCorrelation(i, i) < 0.0)
{
tmp = 1.0 / sqrt(- mCorrelation(i, i));
mParameterSD[i] = mSD / tmp;
}
else
{
mParameterSD[i] = mInfinity;
tmp = 1.0;
mCorrelation(i, i) = 1.0;
}
}
for (i = 0; i < imax; i++)
for (l = 0; l < imax; l++)
mCorrelation(i, l) *= S[i] * S[l];
// Make sure the timer is acurate.
(*mCPUTime.getRefresh())();
return true;
}
/**
solve linear equation using SVD(Singular Value Decomposition)
by lapack library DGESVD (_a can be non-square matrix)
*/
int solveLinearEquationSVD(const dmatrix &_a, const dvector &_b, dvector &_x, double _sv_ratio)
{
const int m = _a.rows();
const int n = _a.cols();
assert( m == static_cast<int>(_b.size()) );
_x.resize(n);
int i, j;
char jobu = 'A';
char jobvt = 'A';
int max_mn = max(m,n);
int min_mn = min(m,n);
dmatrix a(m,n);
a = _a;
int lda = m;
double *s = new double[max_mn]; // singular values
int ldu = m;
double *u = new double[ldu*m];
int ldvt = n;
double *vt = new double[ldvt*n];
int lwork = max(3*min_mn+max_mn, 5*min_mn); // for CLAPACK ver.2 & ver.3
double *work = new double[lwork];
int info;
for(i = 0; i < max_mn; i++) s[i] = 0.0;
dgesvd_(&jobu, &jobvt, &m, &n, &(a(0,0)), &lda, s, u, &ldu, vt, &ldvt, work,
&lwork, &info);
double tmp;
double smin, smax=0.0;
for (j = 0; j < min_mn; j++) if (s[j] > smax) smax = s[j];
smin = smax*_sv_ratio; // 1.0e-3;
for (j = 0; j < min_mn; j++) if (s[j] < smin) s[j] = 0.0;
double *utb = new double[m]; // U^T*b
for (j = 0; j < m; j++){
tmp = 0;
if (s[j]){
for (i = 0; i < m; i++) tmp += u[j*m+i] * _b(i);
tmp /= s[j];
}
utb[j] = tmp;
}
// v*utb
for (j = 0; j < n; j++){
tmp = 0;
for (i = 0; i < n; i++){
if(s[i]) tmp += utb[i] * vt[j*n+i];
}
_x(j) = tmp;
}
delete [] utb;
delete [] work;
delete [] vt;
delete [] s;
delete [] u;
return info;
}
/**
calculate Pseudo-Inverse using SVD(Singular Value Decomposition)
by lapack library DGESVD (_a can be non-square matrix)
*/
int calcPseudoInverse(const dmatrix &_a, dmatrix &_a_pseu, double _sv_ratio)
{
int i, j, k;
char jobu = 'A';
char jobvt = 'A';
int m = (int)_a.rows();
int n = (int)_a.cols();
int max_mn = max(m,n);
int min_mn = min(m,n);
dmatrix a(m,n);
a = _a;
int lda = m;
double *s = new double[max_mn];
int ldu = m;
double *u = new double[ldu*m];
int ldvt = n;
double *vt = new double[ldvt*n];
int lwork = max(3*min_mn+max_mn, 5*min_mn); // for CLAPACK ver.2 & ver.3
double *work = new double[lwork];
int info;
for(i = 0; i < max_mn; i++) s[i] = 0.0;
dgesvd_(&jobu, &jobvt, &m, &n, &(a(0,0)), &lda, s, u, &ldu, vt, &ldvt, work,
&lwork, &info);
double smin, smax=0.0;
for (j = 0; j < min_mn; j++) if (s[j] > smax) smax = s[j];
smin = smax*_sv_ratio; // default _sv_ratio is 1.0e-3
for (j = 0; j < min_mn; j++) if (s[j] < smin) s[j] = 0.0;
//------------ calculate pseudo inverse pinv(A) = V*S^(-1)*U^(T)
// S^(-1)*U^(T)
for (j = 0; j < m; j++){
if (s[j]){
for (i = 0; i < m; i++) u[j*m+i] /= s[j];
}
else {
for (i = 0; i < m; i++) u[j*m+i] = 0.0;
}
}
// V * (S^(-1)*U^(T))
_a_pseu.resize(n,m);
for(j = 0; j < n; j++){
for(i = 0; i < m; i++){
_a_pseu(j,i) = 0.0;
for(k = 0; k < min_mn; k++){
if(s[k]) _a_pseu(j,i) += vt[j*n+k] * u[k*m+i];
}
}
}
delete [] work;
delete [] vt;
delete [] s;
delete [] u;
return info;
}