Пример #1
0
	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;
	}
Пример #2
0
	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;
	}
Пример #3
0
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"));
}
Пример #4
0
/*! 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;
}
Пример #5
0
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);
}
Пример #6
0
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);
}
Пример #7
0
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;

}
Пример #8
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;
}
Пример #9
0
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);
}
Пример #10
0
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
}
Пример #11
0
Файл: layout.c Проект: ekg/mars
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);
}
Пример #12
0
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) ;
}
Пример #13
0
//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;
}
Пример #14
0
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
}
Пример #15
0
/** 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;
}
Пример #16
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);

}
Пример #17
0
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;
}
Пример #18
0
/* 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;
}
Пример #19
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;
}
Пример #20
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

  }
Пример #21
0
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
        );
}
Пример #22
0
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;
}
Пример #23
0
/*
 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;
}	
Пример #24
0
//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);
}
Пример #25
0
	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
	}
Пример #26
0
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);
}
Пример #27
0
/* 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_ */
Пример #28
0
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;
		}