int CLapack::syev(char jobz,char uplo,CFortranMatrix& a,CVector& w)
{
int info = 0;
int nrows = a.GetNumberOfRows();
int nwork = -1;
double twork[1];
// query workspace length
dsyev_(&jobz,&uplo,&nrows,a.GetRawDataField(),&nrows,w.GetRawDataField(),
twork,&nwork,&info);
if( info != 0 ){
CSmallString error;
error << "unable to determine lwork, info = " << info;
INVALID_ARGUMENT(error);
}
// allocate work space
CVector work;
nwork = static_cast<int>(twork[0]) + 1;
work.CreateVector(nwork);
// run again
dsyev_(&jobz,&uplo,&nrows,a.GetRawDataField(),&nrows,w.GetRawDataField(),
work.GetRawDataField(),&nwork,&info);
return(info);
}
/*! calculate eigenvalues and eigenvectors.\n
All of the arguments need not to be initialized.
w and v are overwitten and become
eigenvalues and eigenvectors, respectively.
This matrix is also overwritten.
*/
inline long dsymatrix::dsyev(std::vector<double>& w, std::vector<drovector>& v)
{VERBOSE_REPORT;
w.resize(n); v.resize(n);
for(long i=0; i<n; i++){ v[i].resize(n); }
char JOBZ('V'), UPLO('l');
long LDA(n), INFO(1), LWORK(-1);
double *WORK(new double[1]);
dsyev_(JOBZ, UPLO, n, array, LDA, &w[0], WORK, LWORK, INFO);
INFO=1;
LWORK = long(WORK[0]);
delete [] WORK; WORK = new double[LWORK];
dsyev_(JOBZ, UPLO, n, array, LDA, &w[0], WORK, LWORK, INFO);
delete [] WORK;
//// forming ////
for(long i=0; i<n; i++){ for(long j=0; j<n; j++){
v[j](i) = array[i+n*j];
}}
if(INFO!=0){
WARNING_REPORT;
std::cerr << "Serious trouble happend. INFO = " << INFO << "." << std::endl;
}
return INFO;
}
int main()
{
int n = 100;
std::vector<double> m(n*n);
// fill "matrix"
for (size_t i=0;i<size_t(n*n);i++) m[i] = 5*drand48();
// symmetrize:
for (size_t i=0;i<size_t(n);i++)
for (size_t j=i+1;j<size_t(n);j++)
m[i+j*n] = m[j+i*n];
std::vector<double> eigs(n);
char jobz='V';
char uplo='U';
int lda=n;
std::vector<double> work(3);
int info = 0;
int lwork= -1;
// query:
dsyev_(&jobz,&uplo,&n,&(m[0]),&lda, &(eigs[0]),&(work[0]),&lwork, &info);
if (info!=0) {
std::cerr<<"diag: dsyev_: failed with info="<<info<<"\n";
return 1;
}
lwork = int(work[0])+1;
work.resize(lwork+1);
// real work:
dsyev_(&jobz,&uplo,&n,&(m[0]),&lda, &(eigs[0]),&(work[0]),&lwork, &info);
if (info!=0) {
std::cerr<<"diag: dsyev_: failed with info="<<info<<"\n";
return 1;
}
}
void Eigensystem( char* jobz, char* uplo, int* n, double* a, int* lda, double* w)
{
/* Query and allocate the optimal workspace */
int info=0;
double wkopt;
int lwork = -1;
dsyev_( jobz, uplo, n, a, lda, w, &wkopt, &lwork, &info );
lwork = (int)wkopt;
// printf("%d\n", lwork);
double* work = (double*)malloc( lwork*sizeof(double) );
/* Solve eigenproblem */
dsyev_( jobz, uplo, n, a, lda, w, work, &lwork, &info );
/* Check for convergence */
if( info > 0 ) { printf( "The algorithm failed to compute eigenvalues.\n" ); exit( 1 ); }
/* Free workspace */
free( (void*)work );
}
int Factorize ( double * A, double * val, int n){
char JOBZ = 'V';
char UPLO = 'L';
int N;
int INFO;
static double * WORK=NULL;
static int LWORK=0;
static int last_n=0;
N = n;
if (n>last_n){
if(NULL==WORK){
WORK=malloc(sizeof(double));
}
LWORK=-1;
dsyev_ (&JOBZ,&UPLO,&N,A,&N,val,WORK,&LWORK,&INFO);
LWORK=(int)WORK[0];
free(WORK);
WORK = malloc(LWORK*sizeof(double));
last_n = n;
}
dsyev_ (&JOBZ,&UPLO,&N,A,&N,val,WORK,&LWORK,&INFO);
return INFO;
}
void eigenvectorOfN(double *N, float* q){
static float q_pre[4]; // previous result
int dimN = 4;
double w[4]; // eigenvalues
double *work = new double; // workspace
int info;
int lwork = -1;
dsyev_((char*)"V", (char*)"U",
&dimN, N, &dimN,
w, work, &lwork, &info);
if(info != 0){
fprintf(stderr, "info = %d\n", info);
exit(1);
}
lwork = (int)work[0];
delete work;
work = new double [lwork];
dsyev_((char*)"V", (char*)"U",
&dimN, N, &dimN,
w, work, &lwork, &info);
delete [] work;
if(info != 0){
fprintf(stderr, "computing eigenvector FAIL! info = %d\n", info);
//exit(1);
// if fail, put back the previous result
for(int i=0; i<4; i++){
q[i] = q_pre[i];
}
}else{
// last column of N is the eigenvector of the largest eigenvalue
// and N is stored column-major
for(int i=0; i<4; i++){
q[i] = N[4*3 + i];
q_pre[i] = q[i];
}
}
}
void ProtoMol::Lapack::dsyev(char *jobz, char *uplo, int *n, double *a,
int *lda, double *w, double *work, int *lwork,
int *info) {
FAHCheckIn();
#if defined(HAVE_LAPACK)
dsyev_(jobz, uplo, n, a, lda, w, work, lwork, info);
#elif defined(HAVE_SIMTK_LAPACK)
dsyev_(*jobz, *uplo, *n, a, *lda, w, work, *lwork, *info);
#elif defined(HAVE_MKL_LAPACK)
DSYEV(jobz, uplo, n, a, lda, w, work, lwork, info);
#else
THROW(std::string(__func__) + " not supported");
#endif
}
int eigs_sym (int di, const float * m, float * eigval, float * eigvec)
{
int i, j;
FINTEGER d=di;
double * md = (double *) memalign (16, sizeof (*md) * d * d);
/* processing is performed in double precision */
for (i = 0 ; i < d ; i++) {
for (j = 0 ; j < d ; j++)
md[i * d + j] = (float) m[i * d + j];
}
/* variable for lapack function */
double workopt = 0;
FINTEGER lwork = -1, info;
double * lambda = (double *) memalign (16, sizeof (*lambda) * d);
dsyev_( "V", "L", &d, md, &d, lambda, &workopt, &lwork, &info );
lwork = (int) workopt;
double * work = (double *) memalign (16, lwork * sizeof (*work));
dsyev_( "V", "L", &d, md, &d, lambda, work, &lwork, &info );
if (info > 0) {
fprintf (stderr, "# eigs_sym: problem while computing eigen-vectors/values info=%d\n",info);
goto error;
}
/* normalize the eigenvectors, copy and free */
double nr = 1;
for (i = 0 ; i < d ; i++) {
if(eigval)
eigval[i] = (float) lambda[i];
if(eigvec)
for (j = 0 ; j < d ; j++)
eigvec[i * d + j] = (float) (md[i * d + j] / nr);
}
error:
free (md);
free (lambda);
free (work);
return info;
}
int CLapack::syev(char jobz,char uplo,CFortranMatrix& a,CVector& w,CVector& work)
{
int info = 0;
int nrows = a.GetNumberOfRows();
int nwork = work.GetLength();
dsyev_(&jobz,&uplo,&nrows,a.GetRawDataField(),&nrows,w.GetRawDataField(),
work.GetRawDataField(),&nwork,&info);
return(info);
}
void QuasiNewton<double>::stdHerDiag(int NTrial, ostream &output){
// Solve E(R)| X(R) > = | X(R) > ω
char JOBV = 'V';
char UPLO = 'L';
int INFO;
RealCMMap A(this->XTSigmaRMem,NTrial,NTrial);
//cout << "HERE" << endl;
//cout << endl << A << endl;
dsyev_(&JOBV,&UPLO,&NTrial,this->XTSigmaRMem,&NTrial,
this->ERMem,this->WORK,&this->LWORK,&INFO);
if(INFO!=0) CErr("DSYEV failed to converge in Davison Iterations",output);
} // stdHerDiag
void
linalg_sym_eigvecs (double *A, double *eig_vals, int N)
{
const int rows = N;
char jobz = 'V';
char upper = 'U';
int info = 0;
int lwork = N * N;
double *work = (double *) malloc (sizeof (double) * lwork);
dsyev_ (&jobz, &upper, &rows, A, &rows, eig_vals, work, &lwork, &info);
free (work);
}
void THLapack_(syev)(char jobz, char uplo, int n, real *a, int lda, real *w, real *work, int lwork, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
dsyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, info);
#else
ssyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, info);
#endif
#else
THError("syev : Lapack library not found in compile time\n");
#endif
}
/*! calculate eigenvalues and eigenvectors.\n
All of the arguments need not to be initialized.
w is overwitten and become eigenvalues.
This matrix is also overwritten.
if jobz=1, this matrix becomes eigenvectors.
*/
inline long dsymatrix::dsyev(std::vector<double>& w, const bool& jobz=0)
{VERBOSE_REPORT;
w.resize(n);
char JOBZ, UPLO('l');
if(jobz==0){ JOBZ='n'; } else{ JOBZ='V'; }
long LDA(n), INFO(1), LWORK(-1);
double *WORK(new double[1]);
dsyev_(JOBZ, UPLO, n, array, LDA, &w[0], WORK, LWORK, INFO);
INFO=1;
LWORK = long(WORK[0]);
delete [] WORK; WORK = new double[LWORK];
dsyev_(JOBZ, UPLO, n, array, LDA, &w[0], WORK, LWORK, INFO);
delete [] WORK;
if(INFO!=0){
WARNING_REPORT;
std::cerr << "Serious trouble happend. INFO = " << INFO << "." << std::endl;
}
return INFO;
}
/* LAPACK using 1D arrays for storing matricies.
/ 0 3 6 \
| 1 4 7 | = [ 0 1 2 3 4 5 6 7 8 ]
\ 2 5 8 / */
double * lapack_diag ( struct mtx * M, int jobtype ) {
char job; //job type
char uplo='L'; //operate on lower triagle
double * work; //working space for dsyev
int lwork; //size of work array
int rval=0; //returned from dsyev_
double * eigvals;
char linebuf[MAXLINE];
//eigenvectors or no?
if ( jobtype == 2 ) job='V';
else job = 'N';
if ( M->dim == 0 ) return NULL;
//allocate eigenvalues array
eigvals = malloc(M->dim*sizeof(double));
checknull(eigvals,"double * eigvals",M->dim*sizeof(double));
//optimize the size of work array
lwork = -1;
work = malloc(sizeof(double));
checknull(work,"double * work",sizeof(double));
dsyev_(&job, &uplo, &(M->dim), M->val, &(M->dim), eigvals, work, &lwork, &rval);
//now optimize work array size is stored as work[0]
lwork=(int)work[0];
work = realloc(work,lwork*sizeof(double));
checknull(work,"double * work",lwork*sizeof(double));
//diagonalize
dsyev_(&job, &uplo, &(M->dim), M->val, &(M->dim), eigvals, work, &lwork, &rval);
if ( rval != 0 ) {
sprintf(linebuf,"error: LAPACK: dsyev returned error: %d\n", rval);
error(linebuf);
die(-1);
}
free(work);
return eigvals;
}
int efp_dsyev(char jobz, char uplo, int n, double *a, int lda, double *w)
{
int info, lwork;
double *work;
lwork = n * n;
work = (double *)malloc(lwork * sizeof(double));
dsyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, &info);
free(work);
return (info);
}
void THLapack_(syev)(char jobz, char uplo, int n, real *a, int lda, real *w, real *work, int lwork, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
extern void dsyev_(char *jobz, char *uplo, int *n, double *a, int *lda, double *w, double *work, int *lwork, int *info);
dsyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, info);
#else
extern void ssyev_(char *jobz, char *uplo, int *n, float *a, int *lda, float *w, float *work, int *lwork, int *info);
ssyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, info);
#endif
#else
THError("syev : Lapack library not found in compile time\n");
#endif
}
void LapackSSEP(int hn, double* A, double* lami, double* evecs)
{
integer n = hn;
for(int i=0;i<n*n;i++) evecs[i] = A[i];
char jobzm = 'V' , uplo = 'U';
integer lwork=2*n*n;
double* work = new double[lwork];
integer info;
dsyev_(&jobzm,&uplo , &n , evecs , &n, lami, work, &lwork, &info);
delete[] work;
}
/** \brief compute the 3 eigen values and eigenvectors for a 3x3 covariance matrix
* \param covariance_matrix a 3x3 covariance matrix in eigen2::matrix3d format
* \param eigen_values the resulted eigenvalues in eigen2::vector3d
* \param eigen_vectors a 3x3 matrix in eigen2::matrix3d format, containing each eigenvector on a new line
*/
bool
eigen_cov (Eigen::Matrix3d covariance_matrix, Eigen::Vector3d &eigen_values, Eigen::Matrix3d &eigen_vectors)
{
char jobz = 'V'; // 'V': Compute eigenvalues and eigenvectors
char uplo = 'U'; // 'U': Upper triangle of A is stored
int n = 3, lda = 3, info = -1;
int lwork = 3 * n - 1;
double *work = new double[lwork];
for (int i = 0; i < 3; i++)
for (int j = 0; j < 3; j++)
eigen_vectors (i, j) = covariance_matrix (i, j);
dsyev_ (&jobz, &uplo, &n, eigen_vectors.data (), &lda, eigen_values.data (), work, &lwork, &info);
delete work;
return (info == 0);
}
JNIEXPORT jint JNICALL Java_NativeLinAlg_dsyev(
JNIEnv * env,
jclass obj,
jchar jobz_j,
jchar uplo_j,
jint n_j,
jdoubleArray a_j,
jint lda_j,
jdoubleArray w_j,
jdoubleArray work_j,
jint lwork_j,
jintArray info_j)
{
/* Subroutine int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a,
integer *lda, doublereal *w, doublereal *work, integer *lwork,
integer *info)
*/
char jobz = jobz_j;
char uplo = uplo_j;
__CLPK_integer n = n_j;
__CLPK_doublereal* a_p = (*env)->GetDoubleArrayElements(env, a_j, 0);
__CLPK_integer lda = lda_j;
__CLPK_doublereal* w_p = (*env)->GetDoubleArrayElements(env, w_j, 0);
__CLPK_doublereal* work_p = (*env)->GetDoubleArrayElements(env, work_j, 0);
__CLPK_integer lwork = lwork_j;
__CLPK_integer* info_p = (*env)->GetIntArrayElements(env, info_j, 0);
dsyev_(&jobz, &uplo, &n, a_p, &lda, w_p,
work_p, &lwork,
info_p);
(*env)-> ReleaseDoubleArrayElements(env, a_j, (double *)a_p, 0);
(*env)-> ReleaseDoubleArrayElements(env, w_j, (double *)w_p, 0);
(*env)-> ReleaseDoubleArrayElements(env, work_j, (double *)work_p, 0);
(*env)-> ReleaseIntArrayElements(env, info_j, (jint *)info_p, 0);
return info_p[0];
}
void lapack_dsyev(int nn, dreal *AA, dreal *ww)
{
int lda, lwork, info;
char jobz = 'V', uplo = 'U';
dreal *work = NULL;
lda = (1 > nn) ? 1 : nn;
lwork = (1 > 3*nn-1) ? 1 : 3*nn-1;
work = (dreal *) calloc(lwork, sizeof(dreal));
check_mem(work, "work");
dsyev_(&jobz, &uplo, &nn, AA, &lda, ww, work, &lwork, &info);
freeup(work);
return;
error:
if(work) freeup(work);
abort();
}
double diagonalize (double I[3][3], double evec[3][3], double evals[3]) {
char jobz = 'V'; /* find evalues and evectors */
char uplo = 'L'; /* amtrix is stored as lower (fortran convention) */
int N = 3; /* the order of matrix */
int leading_dim = N;
int i, j, retval;
double A[N*N];
double workspace[3*N];
int workspace_size = 3*N;
void dsyev_(char * jobz, char * uplo, int* N,
double * A, int * leading_dim,
double * eigenvalues,
double *workspace, int *workspace_size,
int * retval);
for (i=0; i < 3; i++) {
for (j=0; j < 3; j++) {
A[i*3+j] = I[i][j];
}
}
dsyev_ ( &jobz, &uplo, &N, A, &leading_dim, evals,
workspace, &workspace_size, &retval);
if ( retval ) {
fprintf (stderr, "error in dsyev()\n");
exit (1);
}
for (i=0; i < 3; i++) {
double norm = 0;
for (j=0; j < 3; j++) {
evec[i][j] = A[i*3+j];
norm += evec[i][j]*evec[i][j];
}
}
return 0;
}
double * sqrtCov(size_t N, double * eigs, double * cov)
{
double * sqrt_cov = calloc_double(N*N);
size_t lwork = N*8;
double * work = calloc_double(lwork);
int info;
dsyev_("V","L",&N,cov,&N,eigs,work,&lwork,&info);
if (info != 0){
fprintf(stderr, "info = %d in computing sqrt of cov\n",info);
}
assert (info == 0);
size_t ii,jj;
for (ii = 0; ii < N; ii++){
for (jj = 0; jj < N; jj++){
sqrt_cov[ii*N+jj] = cov[(N-1-ii)*N+jj]*sqrt(eigs[N-1-ii]); // eigenvalues are stored in ascending order
}
}
return sqrt_cov;
}
void print_evals (double *A, int n)
{
int lwork;
double *work;
int info;
// eigen values
double *w;
//eigen vectors
double *ev;
int i;
w = (double *)malloc (n * sizeof(double));
ev = (double *)malloc (n * n * sizeof(double));
memcpy (ev, A, n * n * sizeof(double));
lwork = (3 * n - 1 > 1 ? 3 * n - 1 : 1);
work = (double *)malloc (lwork * sizeof(double));
dsyev_ ("V", "L", &n, ev, &n, w, work, &lwork, &info);
assert (info == 0);
fprintf(stderr, "\n evals:");
for(i = 0; i < n; i++) {
fprintf (stderr, " %lf ,", w[i]);
}
fprintf (stderr, "\n");
free (ev);
free (w);
free (work);
return;
}
void compute_D (int n, int n_ele, double *F, double *D)
{
int lwork;
double *work;
int info;
// eigen values
double *w;
//eigen vectors
double *ev;
double *tmp;
int m;
m = n_ele/2;
w = (double *)malloc (n * sizeof(double));
ev = (double *)malloc (n * n * sizeof(double));
tmp = (double *)malloc (n * n * sizeof(double));
memcpy (ev, F, n * n * sizeof(double));
lwork = (3 * n - 1 > 1 ? 3 * n - 1 : 1);
work = (double *)malloc (lwork * sizeof(double));
dsyev_ ("V", "L", &n, ev, &n, w, work, &lwork, &info);
assert (info == 0);
memcpy (tmp, ev, n * n * sizeof(double));
cblas_dgemm (CblasColMajor, CblasNoTrans, CblasTrans, n, n, m,
1.0, tmp, n, ev, n, 0.0, D, n);
free (tmp);
free (ev);
free (w);
free (work);
return;
}
///Solve symmatric matrix eigen problem
void snake::math::SSMED(double* Matrix,int Dim,double* EigenValue)
{
assert(Dim>0);
char jobz = 'V';
char uplo = 'U';
const int n = Dim;
const int lda = n;
int info = 0;
int lwork = 3*Dim;
double*work = new double[lwork];
assert(work);
dsyev_(jobz,uplo,n,Matrix,lda,EigenValue,work,lwork,info);
delete []work;
//if(info == 0) std::cout<<"successful in SSMDiag"<<std::endl;
//
// else std::cout<<"fail in SSMDiag"<<std::endl;
//
}
int factorize (double ** rate_sym, double * freq, double VL[N][N],double VR[N][N],double egvl[N]) {
int i, j, k;
double sum = 0, norm;
double rate[N][N];
double a[N][N];
double b[N][N];
double c[N][N];
double d[N][N];
double **A;
int n = N, lda = N, info, lwork;
double wkopt;
double* work;
void dsyev_ ( char* jobz, char* uplo, int* n, double* a, int* lda,
double* egvl, double* work, int* lwork, int* info);
if (! ( A=dmatrix(N,N))) return 1;
for (i=0; i<N; i++) {
for (j=0; j<N; j++) {
if (i==j) continue;
rate[i][j] = freq[i]*rate_sym[i][j];
}
}
/* normalize */
norm = 0;
for (i=0; i<N; i++) {
for (j=0; j<N; j++) {
if (i==j) continue;
norm += rate[i][j]*freq[j];
}
}
for (i=0; i<N; i++) {
for (j=0; j<N; j++) {
if (i==j) continue;
rate[i][j] /= norm;
rate_sym[i][j] /= norm;
}
}
/* the columns should add up to zero */
for (i=0; i<N; i++) {
sum = 0.0;
for (j=0; j<N; j++) {
if (i==j) continue;
sum += rate[j][i];
}
rate [i][i] = -sum;
}
/* write rate as a product of a diagonal and sym matrix */
for (i=0; i<N; i++) {
for (j=i+1; j<N; j++) {
b[i][j] = b[j][i] = rate_sym[i][j];
d[i][j] = d[j][i] = 0.0;
}
b[i][i] = 0;
for (j=0; j<N; j++) {
if (i==j) continue;
b[i][i] -= freq[j]* b[i][j];
}
b[i][i] /= freq[i];
d[i][i] = freq[i];
}
for (i=0; i<N; i++) {
for (j=0; j<N; j++) {
a[i][j] = 0;
for (k=0; k<N; k++) {
a[i][j] += d[i][k]*b[k][j];
}
}
}
/* c, our new symmetric matrix to be diagonalized */
for (i=0; i<N; i++) {
for (j=0; j<N; j++) {
c[i][j] = c[j][i] = b[i][j]*sqrt(freq[i]*freq[j]);
}
}
/* transpose the matrix c or just, copy, doesn't matter*/
for (i=0; i<N; i++) {
for (j=0; j<N; j++) {
A[i][j] = c[j][i];
}
}
lwork = -1;
dsyev_ ( "Vectors", "Upper", &n, A[0], &lda, egvl, &wkopt, &lwork, &info );
lwork = (int)wkopt;
work = (double*)malloc( lwork*sizeof(double) );
/* Solve eigenproblem */
dsyev_ ( "Vectors", "Upper", &n, A[0], &lda, egvl, work, &lwork, &info );
for (i=0; i<N; i++) {
for (j=0; j<N; j++) {
VL[i][j] = A[j][i]*sqrt(freq[i]);
VR[i][j] = A[i][j]/sqrt(freq[j]);
}
}
# if 0
for (i=0; i<N; i++) {
for (j=0; j<N; j++) {
a[i][j] = 0;
for (k=0; k<N; k++) {
a[i][j] += VL[i][k]*exp(egvl[k])*VR[k][j];
}
}
}
for (i=0; i<N; i++) {
for (j=0; j<N; j++) {
printf (" %6.3lf", a[i][j]);
}
printf ("\n");
}
printf ("check:\n");
for (i=0; i<N; i++) {
sum = 0.0;
for (j=0; j<N; j++) {
sum += a[j][i];
}
printf (" %3d %6.3lf\n", i , sum);
}
exit (1);
# endif
free_dmatrix(A);
free(work);
return 0;
}
int gene_reml(double *reml, double *Y, double *Z, double *X, int ns, int num_covars, int wnum, float wsum, double YTY, double *ZTY, double *ZTZ, double detZTZ, double YTCY, float priora, float priorb)
{
int j, k, count;
int nfree, one=1, info, lwork, best, stop;
double alpha, beta, wkopt, *work;
double lbetaab, S1, S2, S3, T1, T2, T3;
double gam, like, like2, like3, maxlike, likenull, deriv, dderiv, d2, dd2;
double lambda, lamdiff, her, hernew, sd, sdlog;
double statlrt, pvalrt, statscore, pvascore, remlbf;
double *XTY, *XTZ, *XTCX, *XTCXtemp, *E, *U, *D, *Dtemp1, *Dtemp2;
nfree=ns-num_covars;
likenull=-.5*nfree*(1+log(2*M_PI*YTCY/nfree))-.5*detZTZ;
//fill reml assuming gene does not contribute
reml[0]=0;reml[1]=0;reml[2]=likenull;reml[3]=0;reml[4]=1;reml[5]=0;reml[6]=1;
reml[7]=log(1.0/99999);reml[8]=0;reml[9]=-10; //reml[10]=YTCY/nfree;
if(wsum>0)
{
XTY=malloc(sizeof(double)*wnum);
XTZ=malloc(sizeof(double)*wnum*num_covars);
XTCX=malloc(sizeof(double)*wnum*wnum);
XTCXtemp=malloc(sizeof(double)*wnum*num_covars);
E=malloc(sizeof(double)*wnum);
U=malloc(sizeof(double)*wnum*wnum);
D=malloc(sizeof(double)*wnum);
//set lbetaab (use 1/wsum if not using priors)
lbetaab=-log(wsum);
if(priora!=-1){lbetaab=lgamma(priora)+lgamma(priorb)-lgamma(priora+priorb);}
//calc XTY, XTZ, XTCX = XTX - XTZ (inv)ZTZ * ZTX
alpha=1.0;beta=0.0;
dgemv_("T", &ns, &wnum, &alpha, X, &ns, Y, &one, &beta, XTY, &one);
dgemm_("T", "N", &wnum, &num_covars, &ns, &alpha, X, &ns, Z, &ns, &beta, XTZ, &wnum);
alpha=1.0;beta=0.0;
dgemm_("T", "N", &wnum, &wnum, &ns, &alpha, X, &ns, X, &ns, &beta, XTCX, &wnum);
dgemm_("N", "N", &wnum, &num_covars, &num_covars, &alpha, XTZ, &wnum, ZTZ, &num_covars, &beta, XTCXtemp, &wnum);
alpha=-1.0;beta=1.0;
dgemm_("N", "T", &wnum, &wnum, &num_covars, &alpha, XTCXtemp, &wnum, XTZ, &wnum, &beta, XTCX, &wnum);
//decomp XTCX
for(j=0;j<wnum;j++)
{
for(k=0;k<wnum;k++){U[j+k*wnum]=XTCX[j+k*wnum];}
}
lwork=-1;
dsyev_("V", "U", &wnum, U, &wnum, E, &wkopt, &lwork, &info );
lwork=(int)wkopt;
work=malloc(sizeof(double)*lwork);
dsyev_("V", "U", &wnum, U, &wnum, E, work, &lwork, &info);
free(work);
if(info!=0){printf("error\n");}
//get D=UTXTCY = UT XTY - UT XTZ (inv)ZTZ ZTY
Dtemp1=malloc(sizeof(double)*num_covars);
Dtemp2=malloc(sizeof(double)*wnum);
alpha=1.0;beta=0.0;
dgemv_("T", &wnum, &wnum, &alpha, U, &wnum, XTY, &one, &beta, D, &one);
dgemv_("N", &num_covars, &num_covars, &alpha, ZTZ, &num_covars, ZTY, &one, &beta, Dtemp1, &one);
dgemv_("N", &wnum, &num_covars, &alpha, XTZ, &wnum, Dtemp1, &one, &beta, Dtemp2, &one);
alpha=-1.0;beta=1.0;
dgemv_("T", &wnum, &wnum, &alpha, U, &wnum, Dtemp2, &one, &beta, D, &one);
free(Dtemp1);
free(Dtemp2);
//ready for REML - adding on prior alog(w) +(b-1)log(lam) -(a+b)log(w+lam) -log(beta)
//first test lambdas and start with best fitting one
best=-9;
for(k=-6;k<10;k++)
{
lambda=wsum*pow(2,k);
S1=0;for(j=0;j<wnum;j++){if(E[j]+lambda>0){S1+=log(E[j]+lambda);}}
T1=0;for(j=0;j<wnum;j++){T1+=pow(D[j],2)*pow(E[j]+lambda,-1);}
gam=YTCY-T1;
like=-.5*nfree*(1+log(2*M_PI*gam/nfree))-.5*S1+.5*wnum*log(lambda)-.5*detZTZ;
like+=priora*log(wsum)+(priorb-1)*log(lambda)-(priora+priorb)*log(wsum+lambda)-lbetaab;
if(best==-9){best=k;maxlike=like;}
if(like>maxlike){best=k;maxlike=like;}
}
lambda=wsum*pow(2,best);
her=wsum/(wsum+lambda);
like2=0;stop=0;count=0;
while(1)
{
S1=0;for(j=0;j<wnum;j++){if(E[j]+lambda>0){S1+=log(E[j]+lambda);}}
S2=0;for(j=0;j<wnum;j++){S2+=pow(E[j]+lambda,-1);}
S3=0;for(j=0;j<wnum;j++){S3+=pow(E[j]+lambda,-2);}
T1=0;for(j=0;j<wnum;j++){T1+=pow(D[j],2)*pow(E[j]+lambda,-1);}
T2=0;for(j=0;j<wnum;j++){T2+=pow(D[j],2)*pow(E[j]+lambda,-2);}
T3=0;for(j=0;j<wnum;j++){T3+=pow(D[j],2)*pow(E[j]+lambda,-3);}
//get gamma then derivs and like
gam=YTCY-T1;
deriv=-.5*nfree/gam*T2-.5*S2+.5*wnum/lambda +(priorb-1)/lambda-(priora+priorb)/(wsum+lambda);
dderiv=.5*nfree/gam*(pow(T2,2)/gam+2*T3)+.5*S3-.5*wnum*pow(lambda,-2) -(priorb-1)*pow(lambda,-2)+(priora+priorb)*pow(wsum+lambda,-2);
like3=like2;like2=like;
like=-.5*nfree*(1+log(2*M_PI*gam/nfree))-.5*S1+.5*wnum*log(lambda)-.5*detZTZ;
like+=priora*log(wsum)+(priorb-1)*log(lambda)-(priora+priorb)*log(wsum+lambda)-lbetaab;
//always want to break before updating
if(abs(like-like2)<0.0001&&abs(like2-like3)<0.0001){break;}
if(count==1000){printf("Gene did not finish after %d REML iterations, I hope it got close\n", count);break;}
lamdiff=deriv/dderiv;
if(lamdiff>lambda-0.00001*wsum){lamdiff=lambda-0.00001*wsum;} //this implies h near 1
if(lamdiff<lambda-99999*wsum){lamdiff=lambda-99999*wsum;} //implies h near 0
lambda=lambda-lamdiff;
hernew=wsum/(wsum+lambda);
if(hernew-her>0.1){hernew=her+.1;lambda=wsum*(1-hernew)/hernew;}
if(her-hernew>0.1){hernew=her-.1;lambda=wsum*(1-hernew)/hernew;}
her=hernew;
count++;
}
if(lambda==0.00001*wsum){her=1.0;lambda=0;}
if(lambda==99999*wsum){her=0;like=likenull;}
//get sd and mltest
dd2=pow(wsum+lambda,4)*pow(wsum,-2)*dderiv;
sd=pow(-dd2,-.5);
if(dd2>0){sd=-1;}
if(her==0){sd=0;}
statlrt=2*(like-likenull);
pvalrt=cdfN(-pow(statlrt,.5));
if(statlrt<0){pvalrt=1;}
//get bf from integral
remlbf=(like+.5*log(-2*M_PI/dd2)-likenull)/log(10);
if(dd2>0){remlbf=-10;}
//for score test get deriv for 1/lambda at zero
S2=0;for(j=0;j<wnum;j++){S2+=E[j];}
S3=0;for(j=0;j<wnum;j++){S3+=pow(E[j],2);}
T2=0;for(j=0;j<wnum;j++){T2+=pow(D[j],2);}
T3=0;for(j=0;j<wnum;j++){T3+=pow(D[j],2)*E[j];}
d2=.5*nfree*T2/YTCY-.5*S2;
dd2=.5*nfree/YTCY*(pow(T2,2)/YTCY-2*T3)+.5*S3;
//think only care if deriv is positive
statscore=d2/pow(-dd2,.5);
pvascore=cdfN(-statscore);
//if(statscore>0){statscore=-statscore;}
//pvascore=2*cdfN(statscore);
if(dd2>0){pvascore=1.0;}
//want also sd for log (1/lambda) = log (h/(1-h)/w)
dd2=pow(lambda,2)*dderiv;
sdlog=pow(-dd2,-.5);
reml[0]=her;reml[1]=sd;reml[2]=like;reml[3]=statlrt;reml[4]=pvalrt/2;reml[5]=statscore;reml[6]=pvascore;
if(her>0){reml[7]=log(wsum)-log(lambda);reml[8]=sdlog;reml[9]=remlbf;reml[10]=gam/nfree;}
free(XTY);free(XTZ);free(XTCX);free(XTCXtemp);free(E);free(U);free(D);
} //end of if wnum>0
return(0);
} //end of gene_reml
GURLS_EXPORT void syev( char* jobz, char* uplo, int* n, double* a, int* lda, double* w, double* work, int* lwork, int* info)
{
dsyev_(jobz, uplo, n, a, lda, w, work, lwork, info);
}
int line_fit (double **point, int no_of_points,
double p[], double center_of_mass[]) {
double I[3][3] = {{0.0}}; /* the "moments of inertia" */
double my_point[no_of_points][3];
int i, x, y;
double normalize (double *p);
/***************************/
/* find the center of mass */
/***************************/
for ( x=0; x<3; x++) center_of_mass[x] = 0.0;
for (i=0; i< no_of_points; i++ ) {
for ( x=0; x<3; x++) {
center_of_mass[x] += point[i][x];
}
}
for ( x=0; x<3; x++) {
center_of_mass[x] /= no_of_points;
}
/***********************************/
/* move the points to the cm frame */
/***********************************/
for (i=0; i< no_of_points; i++ ) {
for ( x=0; x<3; x++) {
my_point[i][x] = point[i][x] - center_of_mass[x];
}
}
/**********************************/
/* find the "moments of inertia" */
/**********************************/
for (i=0; i< no_of_points; i++ ) {
for ( x=0; x<3; x++) { /* modulo = circular permutation */
I[x][x] += my_point[i][(x+1)%3]*my_point[i][(x+1)%3] +
my_point[i][(x+2)%3]*my_point[i][(x+2)%3];
for ( y=x+1; y<3; y++) { /* off diag elements */
I[x][y] -= my_point[i][x]*my_point[i][y];
}
}
}
for ( x=0; x<3; x++) {
for ( y=x+1; y<3; y++) {
I[y][x] = I[x][y];
}
}
/*****************************************/
/* diagonalize I[][], pick the direction
with the smallest moment of inertia,
and rotate back to the initial frame */
/*****************************************/
void dsyev_ ( char * jobz, char * uplo, int* N, double * A, int * leading_dim,
double * eigenvalues, double *workspace, int *workspace_size, int * retval);
char jobz = 'V'; /* find evalues and evectors */
char uplo = 'L'; /* amtrix is stored as lower (fortran convention) */
int N = 3; /* the order of matrix */
int leading_dim = N;
int retval;
double A[N*N];
double eigenvalues[N];
double workspace[3*N];
int workspace_size = 3*N;
for ( x=0; x<3; x++) {
for ( y=0; y<3; y++) {
A[x*3+y] = I[x][y];
}
}
dsyev_ ( &jobz, &uplo, &N, A, &leading_dim, eigenvalues,
workspace, &workspace_size, &retval);
if ( retval ) {
fprintf ( stderr, "Dsyev error: %d.\n", retval);
exit (1);
}
/* the eigenvalues are returned in ascending order, so the first guy is mine: */
x = 0;
for ( y=0; y<3; y++) {
p[y] = A[x*3+y];/*this is p, the direction vector */
}
/* is it pointing toward C-terminal of my helix? */
/* scalar product between the vector from the
first to the last point in the helix and p -
if negative, change the sign of p */
{
double *pt_last = my_point[no_of_points-1];
double *pt_first = my_point[0];
double scp = 0.0;
for ( y=0; y<3; y++) {
scp += ( pt_last[y]-pt_first[y] )*p[y];
}
if ( scp < 0 ) for ( y=0; y<3; y++) p[y] = - p[y];
}
return 0;
}
/* Subroutine */ int dsygv_(integer *itype, char *jobz, char *uplo, integer *
n, doublereal *a, integer *lda, doublereal *b, integer *ldb,
doublereal *w, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
integer nb, neig;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
char trans[1];
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
logical upper;
extern /* Subroutine */ int dsyev_(char *, char *, integer *, doublereal *
, integer *, doublereal *, doublereal *, integer *, integer *);
logical wantz;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *,
integer *, integer *);
integer lwkmin;
extern /* Subroutine */ int dsygst_(integer *, char *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYGV computes all the eigenvalues, and optionally, the eigenvectors */
/* of a real generalized symmetric-definite eigenproblem, of the form */
/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */
/* Here A and B are assumed to be symmetric and B is also */
/* positive definite. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the problem type to be solved: */
/* = 1: A*x = (lambda)*B*x */
/* = 2: A*B*x = (lambda)*x */
/* = 3: B*A*x = (lambda)*x */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangles of A and B are stored; */
/* = 'L': Lower triangles of A and B are stored. */
/* N (input) INTEGER */
/* The order of the matrices A and B. 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. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of A contains */
/* the lower triangular part of the matrix A. */
/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
/* matrix Z of eigenvectors. The eigenvectors are normalized */
/* as follows: */
/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
/* or the lower triangle (if UPLO='L') of A, including the */
/* diagonal, is destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
/* On entry, the symmetric positive definite matrix B. */
/* If UPLO = 'U', the leading N-by-N upper triangular part of B */
/* contains the upper triangular part of the matrix B. */
/* If UPLO = 'L', the leading N-by-N lower triangular part of B */
/* contains the lower triangular part of the matrix B. */
/* On exit, if INFO <= N, the part of B containing the matrix is */
/* overwritten by the triangular factor U or L from the Cholesky */
/* factorization B = U**T*U or B = L*L**T. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(1,3*N-1). */
/* For optimal efficiency, LWORK >= (NB+2)*N, */
/* where NB is the blocksize for DSYTRD 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: DPOTRF or DSYEV returned an error code: */
/* <= N: if INFO = i, DSYEV failed to converge; */
/* i off-diagonal elements of an intermediate */
/* tridiagonal form did not converge to zero; */
/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
/* minor of order i of B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--w;
--work;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1;
*info = 0;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info == 0) {
/* Computing MAX */
i__1 = 1, i__2 = *n * 3 - 1;
lwkmin = max(i__1,i__2);
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = lwkmin, i__2 = (nb + 2) * *n;
lwkopt = max(i__1,i__2);
work[1] = (doublereal) lwkopt;
if (*lwork < lwkmin && ! lquery) {
*info = -11;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYGV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
dpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
dsyev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, info);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
dtrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[
b_offset], ldb, &a[a_offset], lda);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x; */
/* backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'T';
} else {
*(unsigned char *)trans = 'N';
}
dtrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[
b_offset], ldb, &a[a_offset], lda);
}
}
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYGV */
} /* dsygv_ */
