void variational_H(){
/* Fill matricies */
read_basis();
printf("CALCULATING MATRIX ELEMENTS\n");
gsl_matrix *coefficents = gsl_matrix_alloc (num_eigenvalues, num_eigenvalues);
gsl_vector *energy = gsl_vector_alloc (num_eigenvalues);
for(char i=num_eigenvalues;i>=0;i--){
for(char j=num_eigenvalues;j>=i;j--){
overlap[num_eigenvalues*i + j] = overlap_elem(i,j);
overlap[num_eigenvalues*j + i] = overlap[num_eigenvalues*i + j];
hamiltonian[num_eigenvalues*i + j] = hamiltonian_elem(i,j);
hamiltonian[num_eigenvalues*j + i] = hamiltonian[num_eigenvalues*i + j];
}
}
printf("DIAGONALIZING MATRIX\n");
gsl_matrix_view s = gsl_matrix_view_array (overlap, 4, 4);
gsl_matrix_view h = gsl_matrix_view_array (hamiltonian, 4, 4);
gsl_eigen_gensymmv_workspace * eigen_sys = gsl_eigen_gensymmv_alloc(num_eigenvalues);
gsl_eigen_gensymmv(&h.matrix, &s.matrix, energy, coefficents, eigen_sys);
gsl_eigen_gensymmv_free(eigen_sys);
gsl_eigen_gensymmv_sort(energy, coefficents, GSL_EIGEN_SORT_VAL_DESC);
printf("DONE!\n");
printf("OUTPUT:\n");
for(char i=num_eigenvalues-1;i>=0;i--){
double energy_i = gsl_vector_get (energy, i);
printf("Energy level %d = %g\n", abs(i-num_eigenvalues) , energy_i);
}
printf("Coefficent Matrix for plotting\n");
for(char i=num_eigenvalues-1;i>=0;i--){
for(char j=num_eigenvalues-1;j>=0;j--){
printf("%g\t", gsl_matrix_get(coefficents,i,j));
}
printf("\n");
}
}
int
main (void)
{
double a[] = { 0.11, 0.12, 0.13,
0.21, 0.22, 0.23 };
double b[] = { 1011, 1012,
1021, 1022,
1031, 1032 };
double c[] = { 0.00, 0.00,
0.00, 0.00 };
gsl_matrix_view A = gsl_matrix_view_array(a, 2, 3);
gsl_matrix_view B = gsl_matrix_view_array(b, 3, 2);
gsl_matrix_view C = gsl_matrix_view_array(c, 2, 2);
/* Compute C = A B */
gsl_blas_dgemm (CblasNoTrans, CblasNoTrans,
1.0, &A.matrix, &B.matrix,
0.0, &C.matrix);
printf ("[ %g, %g\n", c[0], c[1]);
printf (" %g, %g ]\n", c[2], c[3]);
return 0;
}
void GICPOptimizer::compute_dr(gsl_vector const* x, gsl_matrix const* gsl_temp_mat_r, gsl_vector *g)
{
double dR_dPhi[3][3];
double dR_dTheta[3][3];
double dR_dPsi[3][3];
gsl_matrix_view gsl_d_rx = gsl_matrix_view_array(&dR_dPhi[0][0],3, 3);
gsl_matrix_view gsl_d_ry = gsl_matrix_view_array(&dR_dTheta[0][0],3, 3);
gsl_matrix_view gsl_d_rz = gsl_matrix_view_array(&dR_dPsi[0][0],3, 3);
double phi = gsl_vector_get(x ,3);
double theta = gsl_vector_get(x ,4);
double psi = gsl_vector_get(x ,5);
double cphi = cos(phi), sphi = sin(phi);
double ctheta = cos(theta), stheta = sin(theta);
double cpsi = cos(psi), spsi = sin(psi);
dR_dPhi[0][0] = 0.;
dR_dPhi[1][0] = 0.;
dR_dPhi[2][0] = 0.;
dR_dPhi[0][1] = sphi*spsi + cphi*cpsi*stheta;
dR_dPhi[1][1] = -cpsi*sphi + cphi*spsi*stheta;
dR_dPhi[2][1] = cphi*ctheta;
dR_dPhi[0][2] = cphi*spsi - cpsi*sphi*stheta;
dR_dPhi[1][2] = -cphi*cpsi - sphi*spsi*stheta;
dR_dPhi[2][2] = -ctheta*sphi;
dR_dTheta[0][0] = -cpsi*stheta;
dR_dTheta[1][0] = -spsi*stheta;
dR_dTheta[2][0] = -ctheta;
dR_dTheta[0][1] = cpsi*ctheta*sphi;
dR_dTheta[1][1] = ctheta*sphi*spsi;
dR_dTheta[2][1] = -sphi*stheta;
dR_dTheta[0][2] = cphi*cpsi*ctheta;
dR_dTheta[1][2] = cphi*ctheta*spsi;
dR_dTheta[2][2] = -cphi*stheta;
dR_dPsi[0][0] = -ctheta*spsi;
dR_dPsi[1][0] = cpsi*ctheta;
dR_dPsi[2][0] = 0.;
dR_dPsi[0][1] = -cphi*cpsi - sphi*spsi*stheta;
dR_dPsi[1][1] = -cphi*spsi + cpsi*sphi*stheta;
dR_dPsi[2][1] = 0.;
dR_dPsi[0][2] = cpsi*sphi - cphi*spsi*stheta;
dR_dPsi[1][2] = sphi*spsi + cphi*cpsi*stheta;
dR_dPsi[2][2] = 0.;
// set d/d_rx = tr(dR_dPhi'*gsl_temp_mat_r) [= <dR_dPhi, gsl_temp_mat_r>]
gsl_vector_set(g, 3, mat_inner_prod(&gsl_d_rx.matrix, gsl_temp_mat_r));
// set d/d_ry = tr(dR_dTheta'*gsl_temp_mat_r) = [<dR_dTheta, gsl_temp_mat_r>]
gsl_vector_set(g, 4, mat_inner_prod(&gsl_d_ry.matrix, gsl_temp_mat_r));
// set d/d_rz = tr(dR_dPsi'*gsl_temp_mat_r) = [<dR_dPsi, gsl_temp_mat_r>]
gsl_vector_set(g, 5, mat_inner_prod(&gsl_d_rz.matrix, gsl_temp_mat_r));
}
/* Copy variables from the previous sample in the RMHMC working storage to make
* space for the new proposal.
* Arguments:
* state: a pointer to internal working storage for RMHMC.
* kernel: a pointer to the RMHMC kernel data structure.
* Result:
* returns zero for success and non-zero for failure.
*/
static int copyStateVariables(rmhmc_params* state, mcmc_kernel* kernel){
int N = kernel->N;
gsl_vector_view p_v = gsl_vector_view_array(state->momentum, N);
gsl_vector_view new_p_v = gsl_vector_view_array(state->new_momentum, N);
gsl_vector_memcpy(&new_p_v.vector, &p_v.vector);
gsl_vector_view x_v = gsl_vector_view_array(kernel->x, N);
gsl_vector_view new_x_v = gsl_vector_view_array(state->new_x, N);
gsl_vector_memcpy(&new_x_v.vector, &x_v.vector);
gsl_vector_view dfx_v = gsl_vector_view_array(state->dfx, N);
gsl_vector_view new_dfx_v = gsl_vector_view_array(state->new_dfx, N);
gsl_vector_memcpy(&new_dfx_v.vector, &dfx_v.vector);
gsl_matrix_view invM_v = gsl_matrix_view_array(state->invMx, N, N);
gsl_matrix_view new_invM_v = gsl_matrix_view_array(state->new_invMx, N, N);
gsl_matrix_memcpy(&new_invM_v.matrix, &invM_v.matrix);
int i;
for(i = 0; i < N*N*N; i++){
state->new_dMx[i] = state->dMx[i];
}
return 0;
}
/* Update momentum variables using an implicit solver for
* equation (16) of Girolami and Calderhead (2011).
* Arguments:
* state: a pointer to internal working storage for RMHMC.
* p0: current value of momentum parameters.
* iterations: number of fixed point iterations. For iterations=1 then the function is
* equivalent to the explicit solver for equation (18) of Girolami and Calderhead (2011).
* N: number of parameters.
* stepSize: integration step-size.
* Result:
* The method directly updates the new_momentum array in the state structure.
* returns number of iterations succussefuly completed.
*/
static int momentumNewtonUpdate(rmhmc_params* state, double* p0, int iterations, int N, double stepSize){
gsl_vector_view new_p_v = gsl_vector_view_array(state->new_momentum, N);
gsl_matrix_view new_invM_v = gsl_matrix_view_array(state->new_invMx, N, N);
gsl_vector_view a_v = gsl_vector_view_array(state->atmp, N);
gsl_vector_view b_v = gsl_vector_view_array(state->btmp, N);
/* update trace terms */
calculateTraceTerms(N, state->new_invMx, state->new_dMx, state->tr_invM_dM);
int i,d;
for (i = 0; i < iterations; i++) {
/* a = invM*pNew; */
gsl_blas_dgemv(CblasNoTrans, 1.0, &new_invM_v.matrix, &new_p_v.vector, 0.0, &a_v.vector);
for (d = 0; d < N; d++) {
gsl_matrix_view dMx_dv = gsl_matrix_view_array(&(state->new_dMx[d*N*N]), N,N);
/* b = dM/dx_n * invM*pNew = dM/dx_n * a */
gsl_blas_dgemv (CblasNoTrans, 1.0, &dMx_dv.matrix, &a_v.vector, 0.0, &b_v.vector);
/*p_update = pNew^T*invM * dM/dx_n * invM*pNew = a^T * b */
double p_update = 0;
gsl_blas_ddot(&a_v.vector, &b_v.vector, &p_update);
p_update = p0[d] + 0.5*stepSize*( 0.5*p_update + state->new_dfx[d] - 0.5*state->tr_invM_dM[d] );
state->new_momentum[d] = p_update;
}
}
return i;
}
/* Update parameters using an implicit solver for
* equation (17) of Girolami and Calderhead (2011).
* Arguments:
* state: a pointer to internal working storage for RMHMC.
* model: a pointer to the rmhmc_model structure with pointers to user defined functions.
* N: number of parameters.
* stepSize: integration step-size.
* Result:
* The method directly updates the new_x array in the state structure.
* returns 0 for success or non-zero for failure.
*/
static int parametersNewtonUpdate(rmhmc_params* state, rmhmc_model* model, int N , double stepSize){
gsl_vector_view new_x_v = gsl_vector_view_array(state->new_x, N);
gsl_vector_view new_p_v = gsl_vector_view_array(state->new_momentum, N);
gsl_matrix_view new_cholM_v = gsl_matrix_view_array(state->new_cholMx, N, N);
/* temp copy of parameters */
gsl_vector_view x0_v = gsl_vector_view_array(state->btmp, N);
gsl_vector_memcpy(&x0_v.vector, &new_x_v.vector);
/* temp copy of inverse Metric */
gsl_matrix_view new_invM_v = gsl_matrix_view_array(state->new_invMx, N, N);
gsl_matrix_view invM0_v = gsl_matrix_view_array(state->tmpM, N, N);
gsl_matrix_memcpy(&invM0_v.matrix, &new_invM_v.matrix);
gsl_vector_view a_v = gsl_vector_view_array(state->atmp, N);
/* a = invM0*pNew */
/* TODO: replace gsl_blas_dgemv with gsl_blas_dsymv since invM0_v.matrix is symetric */
gsl_blas_dgemv(CblasNoTrans, 1.0, &invM0_v.matrix, &new_p_v.vector, 0.0, &a_v.vector);
int iterations = state->fIt;
int flag = 0;
int i;
for (i = 0; i < iterations; i++) {
/* new_x = invM_new*p_new */
/* TODO: replace gsl_blas_dgemv with gsl_blas_dsymv since inew_invM_v.matrix is symetric */
gsl_blas_dgemv(CblasNoTrans, 1.0, &new_invM_v.matrix, &new_p_v.vector, 0.0, &new_x_v.vector);
/* Calculates new_x_v = x0 + 0.5*stepSize*(invM_0*newP + newInvM*newP) */
gsl_vector_add(&new_x_v.vector, &a_v.vector);
gsl_vector_scale(&new_x_v.vector, 0.5*stepSize);
gsl_vector_add(&new_x_v.vector, &x0_v.vector);
/* calculate metric at the current position or update everything if this is the last iteration */
if ( (i == iterations-1) )
/* call user defined function for updating all quantities */
model->PosteriorAll(state->new_x, model->m_params, &state->new_fx, state->new_dfx, state->new_cholMx, state->new_dMx);
else
/* call user defined function for updating only the metric ternsor */
model->Metric(state->new_x, model->m_params, state->new_cholMx);
/* calculate cholesky factor for current metric */
gsl_error_handler_t* old_handle = gsl_set_error_handler_off();
flag = gsl_linalg_cholesky_decomp( &new_cholM_v.matrix );
if (flag != 0){
fprintf(stderr,"RMHMC: matrix not positive definite in parametersNewtonUpdate.\n");
return flag;
}
gsl_set_error_handler(old_handle);
/* calculate inverse for current metric */
gsl_matrix_memcpy(&new_invM_v.matrix, &new_cholM_v.matrix );
gsl_linalg_cholesky_invert(&new_invM_v.matrix);
}
return flag;
}
/*assumes we have a "coded" QR decomposition (a,tau) of the original matrix*/
inline void qr_decomp(double* a, double* tau, double* q, double* r,int m,int n){
gsl_matrix_view qv=gsl_matrix_view_array(q,m,m);
gsl_matrix_view rv=gsl_matrix_view_array(r,m,n);
gsl_matrix_view av=gsl_matrix_view_array(a,m,n);
int d;
if (m<n) d=m; else d=n;
gsl_vector_view tv=gsl_vector_view_array(tau,d);
gsl_linalg_QR_unpack(&av.matrix,&tv.vector,&qv.matrix,&rv.matrix);
}
/*
void invert(valarray<double>& Mi,const valarray<double>& M){
int Dim = sqrt(double(M.size()));
vector<int> indx(Dim);
valarray<double> Mt = M;
valarray<double> vv(Dim);
//// LU decomposition
for(int i=0; i<Dim; ++i){
double big = 0.0;
for(int j=0; j<Dim; ++j) big = max(big,fabs(Mt[i*Dim+j]));
vv[i] = 1.0/big;
}
for(int j=0; j<Dim; ++j){
for(int i=0; i<j; ++i){
double sum = Mt[i*Dim+j];
for(int k=0; k<i; ++k) sum -= Mt[i*Dim+k]*Mt[k*Dim+j];
Mt[i*Dim+j] = sum;
}
double big=0.0;
int imax;
for(int i=j; i<Dim; ++i){
imax = j;
double sum = Mt[i*Dim+j];
for(int k=0; k<j; ++k) sum -= Mt[i*Dim+k]*Mt[k*Dim+j];
Mt[i*Dim+j] = sum;
if(double dum= vv[i]*fabs(sum) >= big){
big = dum;
imax = i;
}
}
if(j!=imax){
for(int k=0; k<Dim; ++k) swap(Mt[imax*Dim+k],Mt[j*Dim+k]);
vv[imax] = vv[j];
}
indx[j]= imax;
if(j !=Dim-1)
for(int i=j+1; i<Dim; ++i) Mt[i*Dim+j] /= Mt[j*Dim+j];
}
///////
for(int k=0; k<Dim; ++k){
for(int l=0; l<Dim; ++l)
CCIO::cout<<" LU["<<k<<","<<l<<"]="<<Mt[k*Dim+l];
CCIO::cout<<"\n";
}
//// forward/backward subtractions
for(int j=0; j<Dim; ++j){
vector<double> col(Dim,0.0);
col[j] = 1.0;
int ii = 0;
for(int i=0; i<Dim; ++i){
double sum = col[indx[i]];
col[indx[i]] = col[i];
if(ii)
for(int k=ii; k<i; ++k) sum -= Mt[i*Dim+k]*col[k];
else if(sum) ii = i;
col[i] = sum;
}
for(int i=Dim-1; i>=0; --i){
double sum = col[i];
for(int k=i+1; k<Dim; ++k) sum -= Mt[i*Dim+k]*col[k];
col[i] = sum/Mt[i*Dim+i];
}
for(int i=0; i<Dim; ++i) Mi[i*Dim+j] = col[i];
}
}
*/
void invert(valarray<double>& Mi,const valarray<double>& M){
int Dim = sqrt(double(M.size()));
valarray<double> Mt(M);
gsl_matrix_view m = gsl_matrix_view_array(&(Mt[0]),Dim,Dim);
gsl_matrix_view mi = gsl_matrix_view_array(&(Mi[0]),Dim,Dim);
gsl_permutation* p = gsl_permutation_alloc(Dim);
int sgn;
gsl_linalg_LU_decomp(&m.matrix,p,&sgn);
gsl_linalg_LU_invert(&m.matrix,p,&mi.matrix);
}
/*same as above but with transpose for q; i.e QtS and not QS */
inline void qr_qtmproduct(double* a, double* tau,
double* s, int m,int n,int p){
gsl_matrix_view av=gsl_matrix_view_array(a,m,n);
gsl_matrix_view sv=gsl_matrix_view_array(s,m,p);
int d;
if (m<n) d=m; else d=n;
gsl_vector_view tv=gsl_vector_view_array(tau,d);
int i;
for (i=0;i<p;i++){
gsl_vector_view scv=gsl_matrix_column(&sv.matrix,i);
gsl_linalg_QR_QTvec(&av.matrix,&tv.vector,&scv.vector);
}
}
void
test_eigen_nonsymm(void)
{
size_t N_max = 20;
size_t n, i;
gsl_rng *r = gsl_rng_alloc(gsl_rng_default);
for (n = 1; n <= N_max; ++n)
{
gsl_matrix * m = gsl_matrix_alloc(n, n);
gsl_eigen_nonsymmv_workspace * w = gsl_eigen_nonsymmv_alloc(n);
for (i = 0; i < 5; ++i)
{
create_random_nonsymm_matrix(m, r, -10, 10);
gsl_eigen_nonsymmv_params(0, w);
test_eigen_nonsymm_matrix(m, i, "random, unbalanced", w);
gsl_eigen_nonsymmv_params(1, w);
test_eigen_nonsymm_matrix(m, i, "random, balanced", w);
}
gsl_matrix_free(m);
gsl_eigen_nonsymmv_free(w);
}
gsl_rng_free(r);
{
double dat1[] = { 0, 1, 1, 1,
1, 1, 1, 1,
0, 0, 0, 0,
0, 0, 0, 0 };
double dat2[] = { 1, 1, 0, 1,
1, 1, 1, 1,
1, 1, 1, 1,
0, 1, 0, 0 };
gsl_matrix_view v;
gsl_eigen_nonsymmv_workspace * w = gsl_eigen_nonsymmv_alloc(4);
v = gsl_matrix_view_array (dat1, 4, 4);
test_eigen_nonsymm_matrix(&v.matrix, 0, "integer", w);
v = gsl_matrix_view_array (dat2, 4, 4);
test_eigen_nonsymm_matrix(&v.matrix, 1, "integer", w);
gsl_eigen_nonsymmv_free(w);
}
} /* test_eigen_nonsymm() */
int
kalman_meas (Kalman * k, const double * z, int M, double dt,
KalmanMeasFunc meas_func, KalmanMeasJacobFunc meas_jacob_func,
KalmanMeasCovFunc meas_cov_func)
{
kalman_pred (k, dt);
double K[k->N * M];
double PHt[k->N * M];
double H[M * k->N];
double R[M * M];
double I[M * M];
double h[M];
gsl_matrix_view Kv = gsl_matrix_view_array (K, k->N, M);
gsl_matrix_view PHtv = gsl_matrix_view_array (PHt, k->N, M);
gsl_matrix_view Hv = gsl_matrix_view_array (H, M, k->N);
gsl_matrix_view Rv = gsl_matrix_view_array (R, M, M);
gsl_matrix_view Iv = gsl_matrix_view_array (I, M, M);
gsl_vector_view hv = gsl_vector_view_array (h, M);
meas_jacob_func (H, M, k->x, k->N, k->user);
/* K = P_*H'*inv(H*P_*H' + R) */
gsl_blas_dgemm (CblasNoTrans, CblasTrans, 1.0, &k->Pv.matrix,
&Hv.matrix, 0.0, &PHtv.matrix);
meas_cov_func (R, M, k->user);
gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, &Hv.matrix,
&PHtv.matrix, 1.0, &Rv.matrix);
size_t permv[M];
gsl_permutation perm = { M, permv };
int signum;
gsl_linalg_LU_decomp (&Rv.matrix, &perm, &signum);
gsl_linalg_LU_invert (&Rv.matrix, &perm, &Iv.matrix);
gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, &PHtv.matrix,
&Iv.matrix, 0.0, &Kv.matrix);
/* x = x + K*(z - h(x)) */
meas_func (h, M, k->x, k->N, k->user);
vector_sub_nd (z, h, M, h);
gsl_blas_dgemv (CblasNoTrans, 1.0, &Kv.matrix, &hv.vector, 1.0,
&k->xv.vector);
/* P = P_ - K*H*P_ */
gsl_blas_dgemm (CblasNoTrans, CblasTrans, -1.0, &Kv.matrix,
&PHtv.matrix, 1.0, &k->Pv.matrix);
return 0;
}
static int
exp1_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(exp1_J, exp1_N, exp1_P);
double x1 = gsl_vector_get(x, 0);
double x2 = gsl_vector_get(x, 1);
double x3 = gsl_vector_get(x, 2);
double x4 = gsl_vector_get(x, 3);
size_t i;
for (i = 0; i < exp1_N; ++i)
{
double ti = 0.02*(i + 1.0);
double term1 = exp(x1*ti);
double term2 = exp(x2*ti);
gsl_matrix_set(&J.matrix, i, 0, -x3*ti*term1);
gsl_matrix_set(&J.matrix, i, 1, -x4*ti*term2);
gsl_matrix_set(&J.matrix, i, 2, -term1);
gsl_matrix_set(&J.matrix, i, 3, -term2);
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
int
gsl_multifit_linear_L_decomp (gsl_matrix * L, gsl_vector * tau)
{
const size_t m = L->size1;
const size_t p = L->size2;
int status;
if (tau->size != GSL_MIN(m, p))
{
GSL_ERROR("tau vector must be min(m,p)", GSL_EBADLEN);
}
else if (m >= p)
{
/* square or tall L matrix */
status = gsl_linalg_QR_decomp(L, tau);
return status;
}
else
{
/* more columns than rows, compute qr(L^T) */
gsl_matrix_view LTQR = gsl_matrix_view_array(L->data, p, m);
gsl_matrix *LT = gsl_matrix_alloc(p, m);
/* XXX: use temporary storage due to difficulties in transforming
* a rectangular matrix in-place */
gsl_matrix_transpose_memcpy(LT, L);
gsl_matrix_memcpy(<QR.matrix, LT);
gsl_matrix_free(LT);
status = gsl_linalg_QR_decomp(<QR.matrix, tau);
return status;
}
}
int
jac (double t, const double y[], double *dfdy,
double dfdt[], void *params)
{
ODEparams * pa = (ODEparams *)params;
double alpha = gsl_spline_eval(pa->a_spline,t, pa->a_acc);
double beta = gsl_spline_eval(pa->b_spline,t, pa->b_acc);
double gamma=pa->gamma,gamma2=gamma*gamma;
double yy=y[1],x=y[0];
/* double * p = (double *)params;*/
gsl_matrix_view dfdy_mat = gsl_matrix_view_array (dfdy, 2, 2);
gsl_matrix * m = &dfdy_mat.matrix;
/* 0 1
-k -2*c*y -(p-b)-cx^2
*/
gsl_matrix_set (m, 0, 0, 0.0);
gsl_matrix_set (m, 0, 1, 1.0);
gsl_matrix_set (m, 1, 0, -beta*gamma2 - 3*gamma2*x*x - 2*gamma*x*yy + 2*gamma2*x - gamma*yy);
gsl_matrix_set (m, 1, 1, -gamma*x*x - gamma*x);
dfdt[0] = 0.0;
dfdt[1] = 0.0;
return GSL_SUCCESS;
}
int
jac_predprey (double t, const double x[], double *dfdy,
double dfdt[], void *params)
{
predprey_params * p = (predprey_params *)params;
double alpha = p->alpha;
double beta = p->beta;
double gamma = p->gamma;
gsl_matrix_view dfdy_mat = gsl_matrix_view_array (dfdy, 3, 3);
gsl_matrix * m = &dfdy_mat.matrix;
++ p->jac_count;
gsl_matrix_set(m, 0, 0, 1-x[1]-2*x[0]/x[2]);
gsl_matrix_set(m, 0, 1, -x[0]);
gsl_matrix_set(m, 0, 2, (x[0]/x[2])*(x[0]/x[2]));
gsl_matrix_set(m, 1, 0, alpha*x[1]);
gsl_matrix_set(m, 1, 1, alpha*x[0]-1);
gsl_matrix_set(m, 1, 2, 0);
gsl_matrix_set(m, 2, 0, -beta);
gsl_matrix_set(m, 2, 1 ,0);
gsl_matrix_set(m, 2, 2, 0);
dfdt[0] = 0.0;
dfdt[1] = 0.0;
dfdt[2] = 0.0;
return GSL_SUCCESS;
}
static int
meyer_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(meyer_J, meyer_N, meyer_P);
double x1 = gsl_vector_get(x, 0);
double x2 = gsl_vector_get(x, 1);
double x3 = gsl_vector_get(x, 2);
size_t i;
for (i = 0; i < meyer_N; ++i)
{
double ti = 45.0 + 5.0*(i + 1.0);
double term1 = ti + x3;
double term2 = exp(x2 / term1);
gsl_matrix_set(&J.matrix, i, 0, term2);
gsl_matrix_set(&J.matrix, i, 1, x1*term2/term1);
gsl_matrix_set(&J.matrix, i, 2, -x1*x2*term2/(term1*term1));
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
void eigensolve(vector vec1, vector vec2, vector vec3,
real *vals, matrix symmat)
{
int i, j;
double data[9];
gsl_matrix_view mat;
gsl_vector_view vec;
gsl_vector *eigval = gsl_vector_alloc(3);
gsl_matrix *eigvec = gsl_matrix_alloc(3, 3);
gsl_eigen_symmv_workspace *work = gsl_eigen_symmv_alloc(3);
for (i = 0; i < 3; i++)
for (j = 0; j < 3; j++)
data[3*i + j] = symmat[i][j];
mat = gsl_matrix_view_array(data, 3, 3);
gsl_eigen_symmv(&mat.matrix, eigval, eigvec, work);
gsl_eigen_symmv_free(work);
gsl_eigen_symmv_sort(eigval, eigvec, GSL_EIGEN_SORT_VAL_DESC);
for (i = 0; i < 3; i++)
vals[i] = gsl_vector_get(eigval, i);
vec = gsl_matrix_column(eigvec, 0);
for (i = 0; i < 3; i++)
vec1[i] = gsl_vector_get(&vec.vector, i);
vec = gsl_matrix_column(eigvec, 1);
for (i = 0; i < 3; i++)
vec2[i] = gsl_vector_get(&vec.vector, i);
vec = gsl_matrix_column(eigvec, 2);
for (i = 0; i < 3; i++)
vec3[i] = gsl_vector_get(&vec.vector, i);
gsl_vector_free(eigval);
gsl_matrix_free(eigvec);
}
int main(int argc, char *argv[])
{
const size_t NDIM = 3;
double data[NDIM * NDIM];
gsl_matrix_view m = gsl_matrix_view_array(data, NDIM, NDIM);
gsl_vector *eval = gsl_vector_alloc (NDIM);
gsl_matrix *evec = gsl_matrix_alloc (NDIM, NDIM);
gsl_eigen_symmv_workspace * w =
gsl_eigen_symmv_alloc (NDIM);
gsl_eigen_symmv (&m.matrix, eval, evec, w);
gsl_eigen_symmv_free (w);
//Sort Eigenvalues in ascending order
gsl_eigen_symmv_sort (eval, evec,
GSL_EIGEN_SORT_VAL_ASC);
// for (size_t i = 0; i < NDIM; i++)
// {
// retVal.EigenVal[i] = gsl_vector_get(eval, i) / range->size();
//
// gsl_vector_view evec_i
// = gsl_matrix_column (evec, i);
//
// //EigenVec Components
// for (size_t j = 0; j < NDIM; j++)
// retVal.EigenVec[i][j] = gsl_vector_get(&evec_i.vector, j);
// }
//Cleanup GSL
gsl_vector_free (eval);
gsl_matrix_free (evec);
}
// center must be allocated to ndims vals at least.
// coord are the vertice coords
// center is the center of the resulting ndims-sphere
// function returns its radius squared
double SimplexSphere(double **coord, int ndims,double *center)
{
double a_data[ndims*ndims];
double b_data[ndims];
gsl_matrix_view m=gsl_matrix_view_array (a_data, ndims, ndims);
gsl_vector_view b=gsl_vector_view_array (b_data, ndims);
gsl_vector_view x = gsl_vector_view_array (center,ndims);
gsl_permutation * p = gsl_permutation_alloc (ndims);
int s;
int i,j,k;
double d;
for (i=0,k=0;i<ndims;i++)
{
b_data[i]=0;
for (j=0;j<ndims;j++,k++)
{
a_data[k]=((double)coord[0][j]-(double)coord[i+1][j]);
b_data[i]+=((double)coord[0][j]*(double)coord[0][j]-(double)coord[i+1][j]*(double)coord[i+1][j]);
}
b_data[i]*=0.5;
}
gsl_linalg_LU_decomp (&m.matrix, p, &s);
gsl_linalg_LU_solve (&m.matrix, p, &b.vector, &x.vector);
gsl_permutation_free (p);
for (i=0,d=0;i<ndims;i++)
d+=((double)center[i]-(double)coord[0][i])*((double)center[i]-(double)coord[0][i]);
return d;
}
/*affects a! so we might need to clone a. This is just a wrapper of GSL function
the result is stored in a and tau.*/
inline void qr_coded(double* a, double* tau, int m,int n){
gsl_matrix_view av=gsl_matrix_view_array(a,m,n);
int d;
if (m<n) d=m; else d=n;
gsl_vector_view tv=gsl_vector_view_array(tau,d);
gsl_linalg_QR_decomp(&av.matrix,&tv.vector);
}
//-----------------------------------------------------------------------------
// Returns the eigendecomposition A = X*D*X^-1.
// d is the diagonal entries of D.
// X and d must be preallocated: X should be n x n and d should be length n.
//-----------------------------------------------------------------------------
void eigendecomp (double **A, double complex **X, double complex *d, int n)
{
double *a;
double complex **Xtmp;
double complex *dtmp;
gsl_matrix_view m;
gsl_vector_complex *eval;
gsl_matrix_complex *evec;
gsl_eigen_nonsymmv_workspace *w;
// Use GSL routine to compute eigenvalues and eigenvectors
a = matrixToVector (A, n, n);
m = gsl_matrix_view_array (a, n, n);
eval = gsl_vector_complex_alloc (n);
evec = gsl_matrix_complex_alloc (n, n);
w = gsl_eigen_nonsymmv_alloc (n);
gsl_eigen_nonsymmv (&m.matrix, eval, evec, w);
gsl_eigen_nonsymmv_free (w);
// Convert from GSL to intrinsic types
Xtmp = gslmToCx (evec, n, n);
dtmp = gslvToCx (eval, n);
copycm_inplace (X, Xtmp, n, n);
copycv_inplace (d, dtmp, n);
freecmatrix(Xtmp, n);
free(a);
free(dtmp);
gsl_vector_complex_free(eval);
gsl_matrix_complex_free(evec);
}
int
jac (double t, const double y[], double *dfdy,
double dfdt[], void *params)
{
double d = *(double *)params;
double w1, w2, z1, z2;
w1 = -m*g*r*cos(y[2]+gamm);
w2 = -k+(m*g*l0+marmg_gam)*sin(y[2])+m*g*r*y[0]*sin(y[2]+gamm)+m*g*r*cos(y[2]+gamm);
z1 = C*cos(y[2]+gamm)*m*g*r;
z2 = -m*g*r*A*cos(y[2]+gamm);
gsl_matrix_view dfdy_mat
= gsl_matrix_view_array (dfdy, 4, 4);
gsl_matrix * m = &dfdy_mat.matrix;
gsl_matrix_set (m, 0, 0, 0.0);
gsl_matrix_set (m, 0, 1, 1.0);
gsl_matrix_set (m, 0, 2, 0.0);
gsl_matrix_set (m, 0, 3, 0.0);
gsl_matrix_set (m, 1, 0, z1);
gsl_matrix_set (m, 1, 1, 0.0);
gsl_matrix_set (m, 1, 2, (B*w1-C*w2)/det);
gsl_matrix_set (m, 1, 3, 0.0);
gsl_matrix_set (m, 2, 0, 0.0);
gsl_matrix_set (m, 2, 3, 1.0);
gsl_matrix_set (m, 2, 2, 0.0);
gsl_matrix_set (m, 2, 1, 0.0);
gsl_matrix_set (m, 3, 0, z2);
gsl_matrix_set (m, 3, 3, 0.0);
gsl_matrix_set (m, 3, 2, (-C*w1+A*w2)/det);
gsl_matrix_set (m, 3, 1, 0.0);
dfdt[0] = 0.0;
dfdt[1] = 0.0;
dfdt[2] = 0.0;
dfdt[3] = 0.0;
return GSL_SUCCESS;
}
static int calc_jac(double t, const double y[], double *dfdy, double dfdt[], void *data)
{
VALUE params, proc, ary;
VALUE result, vdfdt;
VALUE vy, vmjac;
gsl_vector_view ytmp, dfdttmp;
gsl_matrix_view mv;
size_t dim;
ary = (VALUE) data;
proc = rb_ary_entry(ary, 1);
if (NIL_P(proc)) rb_raise(rb_eRuntimeError, "df function not given");
dim = FIX2INT(rb_ary_entry(ary, 2));
params = rb_ary_entry(ary, 3);
ytmp.vector.data = (double *) y;
ytmp.vector.size = dim;
ytmp.vector.stride = 1;
dfdttmp.vector.data = dfdt;
dfdttmp.vector.size = dim;
dfdttmp.vector.stride = 1;
mv = gsl_matrix_view_array(dfdy, dim, dim);
vy = Data_Wrap_Struct(cgsl_vector_view_ro, 0, NULL, &ytmp);
vmjac = Data_Wrap_Struct(cgsl_matrix_view, 0, NULL, &mv);
vdfdt = Data_Wrap_Struct(cgsl_vector_view, 0, NULL, &dfdttmp);
if (NIL_P(params)) result = rb_funcall((VALUE) proc, RBGSL_ID_call, 4, rb_float_new(t),
vy, vmjac, vdfdt);
else result = rb_funcall((VALUE) proc, RBGSL_ID_call, 5, rb_float_new(t),
vy, vmjac, vdfdt, params);
return GSL_SUCCESS;
}
static int
boxbod_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(boxbod_J, boxbod_N, boxbod_P);
double b[boxbod_P];
size_t i;
for (i = 0; i < boxbod_P; i++)
{
b[i] = gsl_vector_get(x, i);
}
for (i = 0; i < boxbod_N; i++)
{
double xi = boxbod_X[i];
double term = exp(-b[1] * xi);
gsl_matrix_set (&J.matrix, i, 0, 1.0 - term);
gsl_matrix_set (&J.matrix, i, 1, b[0] * term * xi);
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
//TODO: what is dfdt?
int jac_vdp(double t, const double y[], double dfdy[], double dfdt[], void *params){
vdp_params *p = (vdp_params *)params;
++p->jac_count;
double alpha = p->alpha;
double beta = p->beta;
double gamma = p->gamma;
double gmax = p->gmax;
gsl_matrix_view dfdy_mat = gsl_matrix_view_array(dfdy, 2, 2);
gsl_matrix *m = &dfdy_mat.matrix;
//Set value at (i,j) to something
gsl_matrix_set(m, 0, 0, 1 - y[1]-2*y[0]/y[2]);
gsl_matrix_set(m, 0, 1, -y[0]);
gsl_matrix_set(m, 0, 2, y[0]*y[0]/(y[2]*y[2]));
gsl_matrix_set(m, 1, 0, alpha*y[1]);
gsl_matrix_set(m, 1, 1, alpha*(y[0]-1));
gsl_matrix_set(m, 1, 2, 0);
gsl_matrix_set(m, 2, 0, -beta);
gsl_matrix_set(m, 2, 1, 0);
gsl_matrix_set(m, 2, 2, -gamma/gmax);
dfdt[0] = 0.0;
dfdt[1] = 0.0;
dfdt[2] = 0.0;
return GSL_SUCCESS;
}
void Geo3d_Cov_Orientation(double *cov, double *vec, double *ext)
{
#ifdef HAVE_LIBGSL
gsl_matrix_view gmv = gsl_matrix_view_array(cov, 3, 3);
gsl_vector *eval = gsl_vector_alloc(3);
gsl_matrix *evec = gsl_matrix_alloc(3,3);
gsl_eigen_symmv_workspace *w = gsl_eigen_symmv_alloc(3);
gsl_eigen_symmv(&(gmv.matrix), eval, evec, w);
gsl_eigen_symmv_sort(eval, evec, GSL_EIGEN_SORT_VAL_DESC);
if(ext != NULL) {
darraycpy(ext, gsl_vector_const_ptr(eval, 0), 0, 3);
}
gsl_vector_view v = gsl_vector_view_array(vec, 3);
gsl_matrix_get_col(&(v.vector), evec, 0);
gsl_vector_free(eval);
gsl_matrix_free(evec);
gsl_eigen_symmv_free(w);
#else
double eigv[3];
Matrix_Eigen_Value_Cs(cov[0], cov[4], cov[8], cov[1], cov[2], cov[5], eigv);
Matrix_Eigen_Vector_Cs(cov[0], cov[4], cov[8], cov[1], cov[2], cov[5],
eigv[0], vec);
if(ext != NULL) {
darraycpy(ext, eigv, 0, 3);
}
#endif
}
static int
beale_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(beale_J, beale_N, beale_P);
double x1 = gsl_vector_get(x, 0);
double x2 = gsl_vector_get(x, 1);
size_t i;
for (i = 0; i < beale_N; ++i)
{
double term = pow(x2, (double) i);
gsl_matrix_set(&J.matrix, i, 0, term*x2 - 1.0);
gsl_matrix_set(&J.matrix, i, 1, (i + 1.0) * x1 * term);
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
static int
wood_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(wood_J, wood_N, wood_P);
double x1 = gsl_vector_get(x, 0);
double x3 = gsl_vector_get(x, 2);
double s90 = sqrt(90.0);
double s10 = sqrt(10.0);
gsl_matrix_set_zero(&J.matrix);
gsl_matrix_set(&J.matrix, 0, 0, -20.0*x1);
gsl_matrix_set(&J.matrix, 0, 1, 10.0);
gsl_matrix_set(&J.matrix, 1, 0, -1.0);
gsl_matrix_set(&J.matrix, 2, 2, -2.0*s90*x3);
gsl_matrix_set(&J.matrix, 2, 3, s90);
gsl_matrix_set(&J.matrix, 3, 2, -1.0);
gsl_matrix_set(&J.matrix, 4, 1, s10);
gsl_matrix_set(&J.matrix, 4, 3, s10);
gsl_matrix_set(&J.matrix, 5, 1, 1.0/s10);
gsl_matrix_set(&J.matrix, 5, 3, -1.0/s10);
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
(void)params; /* avoid unused parameter warning */
return GSL_SUCCESS;
}
static int
wnlin_df (CBLAS_TRANSPOSE_t TransJ, const gsl_vector * x,
const gsl_vector * u, void * params, gsl_vector * v,
gsl_matrix * JTJ)
{
gsl_matrix_view J = gsl_matrix_view_array(wnlin_J, wnlin_N, wnlin_P);
double A = gsl_vector_get (x, 0);
double lambda = gsl_vector_get (x, 1);
size_t i;
for (i = 0; i < wnlin_N; i++)
{
gsl_vector_view v = gsl_matrix_row(&J.matrix, i);
double ti = i;
double swi = sqrt(wnlin_W[i]);
double e = exp(-lambda * ti);
gsl_vector_set(&v.vector, 0, e);
gsl_vector_set(&v.vector, 1, -ti * A * e);
gsl_vector_set(&v.vector, 2, 1.0);
gsl_vector_scale(&v.vector, swi);
}
if (v)
gsl_blas_dgemv(TransJ, 1.0, &J.matrix, u, 0.0, v);
if (JTJ)
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &J.matrix, 0.0, JTJ);
return GSL_SUCCESS;
}
void kjg_fpca_XTXA (
const gsl_matrix *A1,
gsl_matrix *B,
gsl_matrix *A2) {
size_t m = get_ncols();
size_t n = get_nrows();
size_t i, r; // row index
double *Y = malloc(sizeof(double) * n * KJG_FPCA_ROWS); // normalized
gsl_matrix_view Bi, Xi;
gsl_matrix_set_zero(A2);
for (i = 0; i < m; i += KJG_FPCA_ROWS) {
r = kjg_geno_get_normalized_rows(i, KJG_FPCA_ROWS, Y);
Xi = gsl_matrix_view_array(Y, r, n);
Bi = gsl_matrix_submatrix(B, i, 0, r, B->size2);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1, &Xi.matrix, A1, 0,
&Bi.matrix);
gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1, &Xi.matrix, &Bi.matrix,
1, A2);
}
free(Y);
}
