Esempio n. 1
0
/*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);
} 
Esempio n. 2
0
CAMLprim value ml_gsl_linalg_QR_unpack(value QR, value TAU, value Q, value R)
{
  _DECLARE_MATRIX3(QR, Q, R);
  _DECLARE_VECTOR(TAU);
  _CONVERT_MATRIX3(QR, Q, R);
  _CONVERT_VECTOR(TAU);
  gsl_linalg_QR_unpack(&m_QR, &v_TAU, &m_Q, &m_R);
  return Val_unit;
}
/* compute QR factorization 
M is mxn; Q is mxm and R is mxn
this is slow
*/
void compute_QR_factorization(gsl_matrix *M, gsl_matrix *Q, gsl_matrix *R){
    //printf("QR setup..\n");
    gsl_matrix *QR = gsl_matrix_calloc(M->size1, M->size2); 
    gsl_vector *tau = gsl_vector_alloc(min(M->size1,M->size2));
    gsl_matrix_memcpy (QR, M);

    //printf("QR decomp..\n");
    gsl_linalg_QR_decomp (QR, tau);
    //printf("QR unpack..\n");
    gsl_linalg_QR_unpack (QR, tau, Q, R);
    //printf("done QR..\n");
}
Esempio n. 4
0
File: test_reg.c Progetto: FMX/gsl
/* generate random square orthogonal matrix via QR decomposition */
static void
test_random_matrix_orth(gsl_matrix *m, const gsl_rng *r)
{
  const size_t M = m->size1;
  gsl_matrix *A = gsl_matrix_alloc(M, M);
  gsl_vector *tau = gsl_vector_alloc(M);
  gsl_matrix *R = gsl_matrix_alloc(M, M);

  test_random_matrix(A, r, -1.0, 1.0);
  gsl_linalg_QR_decomp(A, tau);
  gsl_linalg_QR_unpack(A, tau, m, R);

  gsl_matrix_free(A);
  gsl_matrix_free(R);
  gsl_vector_free(tau);
}
Esempio n. 5
0
static int
set (void *vstate, gsl_multiroot_function * func, gsl_vector * x, gsl_vector * f, gsl_vector * dx, int scale)
{
  hybrid_state_t *state = (hybrid_state_t *) vstate;

  gsl_matrix *J = state->J;
  gsl_matrix *q = state->q;
  gsl_matrix *r = state->r;
  gsl_vector *tau = state->tau;
  gsl_vector *diag = state->diag;
  
  GSL_MULTIROOT_FN_EVAL (func, x, f);

  gsl_multiroot_fdjacobian (func, x, f, GSL_SQRT_DBL_EPSILON, J) ;

  state->iter = 1;
  state->fnorm = enorm (f);
  state->ncfail = 0;
  state->ncsuc = 0;
  state->nslow1 = 0;
  state->nslow2 = 0;

  gsl_vector_set_all (dx, 0.0);

  /* Store column norms in diag */

  if (scale)
    compute_diag (J, diag);
  else
    gsl_vector_set_all (diag, 1.0);

  /* Set delta to factor |D x| or to factor if |D x| is zero */

  state->delta = compute_delta (diag, x);

  /* Factorize J into QR decomposition */

  gsl_linalg_QR_decomp (J, tau);
  gsl_linalg_QR_unpack (J, tau, q, r);

  return GSL_SUCCESS;
}
Esempio n. 6
0
static int
md_qr(lua_State *L)                                            /* (-1,+2,e) */
{
    mMatReal *m = qlua_checkMatReal(L, 1);
    mMatReal *qr = qlua_newMatReal(L, m->l_size, m->r_size);
    mMatReal *q = qlua_newMatReal(L, m->l_size, m->l_size);
    mMatReal *r = qlua_newMatReal(L, m->l_size, m->r_size);
    int nm = m->l_size < m->r_size? m->l_size: m->r_size;
    gsl_vector *tau;

    gsl_matrix_memcpy(qr->m, m->m);
    tau = new_gsl_vector(L, nm);
    if (gsl_linalg_QR_decomp(qr->m, tau))
        luaL_error(L, "matrix:qr() failed");
    
    if (gsl_linalg_QR_unpack(qr->m, tau, q->m, r->m))
        luaL_error(L, "matrix:qr() failed");
    gsl_vector_free(tau);
    
    return 2;
}
Esempio n. 7
0
int
gsl_linalg_QRPT_decomp2 (const gsl_matrix * A, gsl_matrix * q, gsl_matrix * r, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm)
{
  const size_t M = A->size1;
  const size_t N = A->size2;

  if (q->size1 != M || q->size2 !=M) 
    {
      GSL_ERROR ("q must be M x M", GSL_EBADLEN);
    }
  else if (r->size1 != M || r->size2 !=N)
    {
      GSL_ERROR ("r must be M x N", GSL_EBADLEN);
    }
  else if (tau->size != GSL_MIN (M, N))
    {
      GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
    }
  else if (p->size != N)
    {
      GSL_ERROR ("permutation size must be N", GSL_EBADLEN);
    }
  else if (norm->size != N)
    {
      GSL_ERROR ("norm size must be N", GSL_EBADLEN);
    }

  gsl_matrix_memcpy (r, A);

  gsl_linalg_QRPT_decomp (r, tau, p, signum, norm);

  /* FIXME:  aliased arguments depends on behavior of unpack routine! */

  gsl_linalg_QR_unpack (r, tau, q, r);

  return GSL_SUCCESS;
}
Esempio n. 8
0
 /**
  * C++ version of gsl_linalg_QR_unpack().
  * @param QR A QR decomposition matrix
  * @param tau A vector
  * @param Q A matrix
  * @param R A matrix
  * @return Error code on failure
  */
 inline int QR_unpack( matrix const& QR, vector const& tau, matrix& Q, matrix& R ){
   return gsl_linalg_QR_unpack( QR.get(), tau.get(), Q.get(), R.get() ); } 
Esempio n. 9
0
static int
iterate (void *vstate, gsl_multiroot_function * func, gsl_vector * x, gsl_vector * f, gsl_vector * dx, int scale)
{
  hybrid_state_t *state = (hybrid_state_t *) vstate;

  const double fnorm = state->fnorm;

  gsl_matrix *J = state->J;
  gsl_matrix *q = state->q;
  gsl_matrix *r = state->r;
  gsl_vector *tau = state->tau;
  gsl_vector *diag = state->diag;
  gsl_vector *qtf = state->qtf;
  gsl_vector *x_trial = state->x_trial;
  gsl_vector *f_trial = state->f_trial;
  gsl_vector *df = state->df;
  gsl_vector *qtdf = state->qtdf;
  gsl_vector *rdx = state->rdx;
  gsl_vector *w = state->w;
  gsl_vector *v = state->v;

  double prered, actred;
  double pnorm, fnorm1, fnorm1p;
  double ratio;
  double p1 = 0.1, p5 = 0.5, p001 = 0.001, p0001 = 0.0001;

  /* Compute qtf = Q^T f */

  compute_qtf (q, f, qtf);

  /* Compute dogleg step */

  dogleg (r, qtf, diag, state->delta, state->newton, state->gradient, dx);

  /* Take a trial step */

  compute_trial_step (x, dx, state->x_trial);

  pnorm = scaled_enorm (diag, dx);

  if (state->iter == 1)
    {
      if (pnorm < state->delta)
	{
	  state->delta = pnorm;
	}
    }

  /* Evaluate function at x + p */

  {
    int status = GSL_MULTIROOT_FN_EVAL (func, x_trial, f_trial);

    if (status != GSL_SUCCESS) 
      {
        return GSL_EBADFUNC;
      }
  }
  
  /* Set df = f_trial - f */

  compute_df (f_trial, f, df);

  /* Compute the scaled actual reduction */

  fnorm1 = enorm (f_trial);

  actred = compute_actual_reduction (fnorm, fnorm1);

  /* Compute rdx = R dx */

  compute_rdx (r, dx, rdx);

  /* Compute the scaled predicted reduction phi1p = |Q^T f + R dx| */

  fnorm1p = enorm_sum (qtf, rdx);

  prered = compute_predicted_reduction (fnorm, fnorm1p);

  /* Compute the ratio of the actual to predicted reduction */

  if (prered > 0)
    {
      ratio = actred / prered;
    }
  else
    {
      ratio = 0;
    }

  /* Update the step bound */

  if (ratio < p1)
    {
      state->ncsuc = 0;
      state->ncfail++;
      state->delta *= p5;
    }
  else
    {
      state->ncfail = 0;
      state->ncsuc++;

      if (ratio >= p5 || state->ncsuc > 1)
	state->delta = GSL_MAX (state->delta, pnorm / p5);
      if (fabs (ratio - 1) <= p1)
	state->delta = pnorm / p5;
    }

  /* Test for successful iteration */

  if (ratio >= p0001)
    {
      gsl_vector_memcpy (x, x_trial);
      gsl_vector_memcpy (f, f_trial);
      state->fnorm = fnorm1;
      state->iter++;
    }

  /* Determine the progress of the iteration */

  state->nslow1++;
  if (actred >= p001)
    state->nslow1 = 0;

  if (actred >= p1)
    state->nslow2 = 0;

  if (state->ncfail == 2)
    {
      gsl_multiroot_fdjacobian (func, x, f, GSL_SQRT_DBL_EPSILON, J) ;

      state->nslow2++;

      if (state->iter == 1)
	{
          if (scale)
            compute_diag (J, diag);
	  state->delta = compute_delta (diag, x);
	}
      else
        {
          if (scale)
            update_diag (J, diag);
        }

      /* Factorize J into QR decomposition */

      gsl_linalg_QR_decomp (J, tau);
      gsl_linalg_QR_unpack (J, tau, q, r);

      return GSL_SUCCESS;
    }

  /* Compute qtdf = Q^T df, w = (Q^T df - R dx)/|dx|,  v = D^2 dx/|dx| */

  compute_qtf (q, df, qtdf);

  compute_wv (qtdf, rdx, dx, diag, pnorm, w, v);

  /* Rank-1 update of the jacobian Q'R' = Q(R + w v^T) */

  gsl_linalg_QR_update (q, r, w, v);

  /* No progress as measured by jacobian evaluations */

  if (state->nslow2 == 5)
    {
      return GSL_ENOPROGJ;
    }

  /* No progress as measured by function evaluations */

  if (state->nslow1 == 10)
    {
      return GSL_ENOPROG;
    }

  return GSL_SUCCESS;
}
Esempio n. 10
0
void Module_DLT::rq_decomp(double* solucion, 
	       gsl_matrix* R_prima,
	       gsl_matrix* Q_prima,
	       gsl_vector* x
	       ){
/*
	int i, j, lotkin_signum, frank_signum;
	int DIM = 3;
	gsl_matrix *lotkin_a, *frank_a;
	gsl_vector *x, *lotkin_b, *frank_b, *lotkin_x, *frank_x;
	gsl_vector *lotkin_tau, *frank_tau;

	/* allocate a, x, b 
	lotkin_a = gsl_matrix_alloc(DIM, DIM);
	frank_a = gsl_matrix_alloc(DIM, DIM);
	x = gsl_vector_alloc(DIM);
	lotkin_b = gsl_vector_alloc(DIM);
	frank_b = gsl_vector_alloc(DIM);
	lotkin_x = gsl_vector_alloc(DIM);
	frank_x = gsl_vector_alloc(DIM);

	/* set x = [1 2 ... DIM] 
	for(i = 0; i < DIM; i++)
		gsl_vector_set(x, i, (double)i);

	/* set Lotkin matrix                      */
	/* a_ij = 1 (i = 1) or 1/(i+j-1) (i != 1) 
	for(i = 0; i < DIM; i++)
		gsl_matrix_set(lotkin_a, 0, i, 1.0);
	for(i = 1; i < DIM; i++)
		for(j = 0; j < DIM; j++)
			gsl_matrix_set(lotkin_a, i, j, 1.0 / (double)(i + j + 1));

	/* set Frank matrix       
	/* a_ij = DIM - min(i,j) + 1 
	for(i = 0; i < DIM; i++)
		for(j = 0; j < DIM; j++)
			gsl_matrix_set(frank_a, i, j, (double)DIM - (double)GSL_MAX(i, j) );
	*/

	/* set A matrix                
	gsl_matrix_set(lotkin_a, 0, 0, 12);
	gsl_matrix_set(lotkin_a, 0, 1, 6);
	gsl_matrix_set(lotkin_a, 0, 2, -4);
	gsl_matrix_set(lotkin_a, 1, 0, -51);
	gsl_matrix_set(lotkin_a, 1, 1, 167);
	gsl_matrix_set(lotkin_a, 1, 2, 24);
	gsl_matrix_set(lotkin_a, 2, 0, 4);
	gsl_matrix_set(lotkin_a, 2, 1, -68);
	gsl_matrix_set(lotkin_a, 2, 2, -41);


	/* Print matrix 
	for(i = 0; i < DIM; i++)
	{
		printf("%3d: ", i);
		for(j = 0; j < DIM; j++)
			printf("%g ", gsl_matrix_get(lotkin_a, i, j));
		printf("\n");
	}
	printf("\n");


	/* b = A * x 
	gsl_blas_dgemv(CblasNoTrans, 1.0, lotkin_a, x, 0.0, lotkin_b);

	/* QR decomposition and solve 
	lotkin_tau = gsl_vector_alloc(DIM);
	gsl_linalg_QR_decomp(lotkin_a, lotkin_tau);
	gsl_linalg_QR_solve(lotkin_a, lotkin_tau, lotkin_b, lotkin_x);
	gsl_vector_free(lotkin_tau);

	/* Print solution matrix 
	for(i = 0; i < DIM; i++)
	{
		printf("%3d: ", i);
		for(j = 0; j < DIM; j++)
			printf("%g ", gsl_matrix_get(lotkin_a, i, j));
		printf("\n");
	}
	printf("\n");
	for(i = 0; i < DIM; i++)
	{
		printf("%3d: ", i);
		for(j = 0; j < DIM; j++)
			//printf("%g ", gsl_vector_get(lotkin_x, i, j));
		printf("\n");
	}

	/* free a, x, b 
	gsl_matrix_free(lotkin_a);
	gsl_vector_free(x);
	gsl_vector_free(lotkin_b);
	gsl_vector_free(lotkin_x);

*/

/*

  gsl_matrix* C = gsl_matrix_alloc(3,3);
  /* Compute C = A B 
  gsl_blas_dgemm (CblasNoTrans, CblasNoTrans,
                  1.0, R_prima, Q_prima,
                  0.0, C);
  camera->rt11 = gsl_matrix_get(C, 0, 0);
  camera->rt12 = gsl_matrix_get(C, 0, 1);
  camera->rt13 = gsl_matrix_get(C, 0, 2);

  camera->rt21 = gsl_matrix_get(C, 1, 0);
  camera->rt22 = gsl_matrix_get(C, 1, 1);
  camera->rt23 = gsl_matrix_get(C, 1, 2);

  camera->rt31 = gsl_matrix_get(C, 2, 0);
  camera->rt32 = gsl_matrix_get(C, 2, 1);
  camera->rt33 = gsl_matrix_get(C, 2, 2);

  camera->rt41 = 0;
  camera->rt42 = 0;
  camera->rt43 = 0;
  camera->rt44 = 1;



**/

	std::cout << "RQ_Decomp" << std::endl;
	int n,mm,s,signum ;
	gsl_matrix *M,*Q,*R;
	gsl_vector* tau;
	double tmp,det;

	/* para invertir las matriz M,Q,R */
	gsl_permutation* p = gsl_permutation_alloc (3);
	gsl_permutation* p2 = gsl_permutation_alloc (3);
	gsl_permutation* p3 = gsl_permutation_alloc (3);
	gsl_matrix* M_prima = gsl_matrix_alloc(3,3);
	gsl_matrix* Q_prima_tmp = gsl_matrix_alloc(3,3);
  
	/* para resolver el centro de la camara usando Mx=C 
	donde C es el verctor p4 de la matriz P */
	gsl_vector* p4 = gsl_vector_alloc(3);
	
	gsl_matrix* temp = gsl_matrix_alloc(3,3);
	gsl_matrix* I_C = gsl_matrix_alloc(3,4);
	gsl_matrix* test = gsl_matrix_alloc(3,4);

	M = gsl_matrix_alloc(3,3);
	Q = gsl_matrix_alloc(3,3);
	R = gsl_matrix_alloc(3,3);
	tau = gsl_vector_alloc(3);

	/* Copiamos la submatriz 3x3 Izq de la solucion P a la matriz M */
	gsl_matrix_set(M,0,0,solucion[0]);
	gsl_matrix_set(M,0,1,solucion[1]);
	gsl_matrix_set(M,0,2,solucion[2]);

	gsl_matrix_set(M,1,0,solucion[4]);
	gsl_matrix_set(M,1,1,solucion[5]);
	gsl_matrix_set(M,1,2,solucion[6]);

	gsl_matrix_set(M,2,0,solucion[8]);
	gsl_matrix_set(M,2,1,solucion[9]);
	gsl_matrix_set(M,2,2,solucion[10]);

	/* Copiamos el vector p4 */
	gsl_vector_set(p4,0,solucion[3]);
	gsl_vector_set(p4,1,solucion[7]);
	gsl_vector_set(p4,2,solucion[11]);

	/* invertimos la matriz M */
	gsl_linalg_LU_decomp (M, p, &s);
	gsl_linalg_LU_solve(M,p,p4,x);
	gsl_linalg_LU_invert (M, p, M_prima);
  
  /* Hacemos una descomposicion a la matriz M invertida */
  gsl_linalg_QR_decomp (M_prima,tau);
  gsl_linalg_QR_unpack (M_prima,tau,Q,R);

  /* Invertimos R */
  gsl_linalg_LU_decomp (R, p2, &s);
  gsl_linalg_LU_invert (R, p2, R_prima);
  
  /* Invertimos Q */
  gsl_linalg_LU_decomp (Q, p3, &s);
  gsl_linalg_LU_invert (Q, p3, Q_prima);
  gsl_matrix_memcpy(Q_prima_tmp, Q_prima);


std::cout << "Calculamos" << std::endl;
      if (DEBUG) {
/** checking results: 
	
	If the rq decompsition is correct we should obtain
	the decomposed matrix:

	orig_matrix = K*R*T

	where T = (I|C)
*/
     

    gsl_matrix_set(I_C,0,3,gsl_vector_get(x,0));
    gsl_matrix_set(I_C,1,3,gsl_vector_get(x,1));
    gsl_matrix_set(I_C,2,3,gsl_vector_get(x,2));
    
    gsl_matrix_set(I_C,0,0,1);
    gsl_matrix_set(I_C,0,1,0);
    gsl_matrix_set(I_C,0,2,0);
    
    gsl_matrix_set(I_C,1,0,0);
    gsl_matrix_set(I_C,1,1,1);
    gsl_matrix_set(I_C,1,2,0);
    
    gsl_matrix_set(I_C,2,0,0);
    gsl_matrix_set(I_C,2,1,0);
    gsl_matrix_set(I_C,2,2,1);
    
    gsl_linalg_matmult(R_prima,Q_prima,temp);
    gsl_linalg_matmult(temp,I_C,test);
    
    printf(" Result -> \n");
    
    for (n=0; n<3; n++){
//      for (mm=0; mm<4; mm++){
      for (mm=0; mm<3; mm++){
	printf(" %g \t",gsl_matrix_get(temp,n,mm));
// se debe sacar test
      }
      printf("\n");
    }
  }
  
  /* El elemento (3,3) de la matriz R tiene que ser 1
     para ello tenemos que normalizar la matriz dividiendo
     entre este elemento
  */
  
  tmp = gsl_matrix_get(R_prima,2,2);
  for (n=0; n<3; n++)
    for (mm=0; mm<3; mm++){
      gsl_matrix_set(R_prima,n,mm, gsl_matrix_get(R_prima,n,mm)/tmp);
    }


  /*  Si obtenemos valores negativos en la
      diagonal de K tenemos que cambiar de signo la columna de K y la fila de Q
      correspondiente
  */
  
  if (DEBUG) 
    print_matrix(R_prima);
  if (DEBUG) 
    print_matrix(Q_prima);

  if (gsl_matrix_get(R_prima,0,0)<0){
  
    if (DEBUG) printf(" distancia focat 0,0 negativa\n");
    gsl_matrix_set(R_prima,0,0,
		   abs(gsl_matrix_get(R_prima,0,0))
		   );
    for (n=0;n<3;n++)
      gsl_matrix_set(Q_prima,0,n,
		     gsl_matrix_get(Q_prima,0,n)*-1
		     );
    
  }

  if (DEBUG)  printf("R_prima\n");
  print_matrix(R_prima);
  if (DEBUG) printf("Q_prima\n");
  print_matrix(Q_prima);

  if (gsl_matrix_get(R_prima,1,1)<0){
    if (DEBUG) printf(" distancia focal 1,1 negativa\n");
    for (n=0;n<3;n++){
      gsl_matrix_set(Q_prima,1,n,
		     gsl_matrix_get(Q_prima,1,n)*-1
		     );
      gsl_matrix_set(R_prima,n,1,
		     gsl_matrix_get(R_prima,n,1)*-1
		     );
    }
  }

  if (DEBUG) printf("R_prima\n");
  print_matrix(R_prima);
  if (DEBUG) printf("Q_prima\n");
  print_matrix(Q_prima);
  
  
  /*Finalmente, si Q queda con determinante -1 cambiamos de signo
    todos sus elementos para obtener una rotación sin "reflexion".
    
    NOTA: Este trozo de codigo lo he desactivado debido a que si lo
    hacemos obtenemos una orientacion equivocada a la hora de dibujarla
    con OGL
  */

  
  gsl_linalg_LU_decomp (Q_prima_tmp, p3, &s);
  signum=1;
  det = gsl_linalg_LU_det(Q_prima_tmp,signum);
    
  if (-1 == det && 0){
    if (DEBUG) printf("Q has a negatif det");
    for (n=0;n<3;n++)
      for (mm=0;mm<3;mm++)
	gsl_matrix_set(Q_prima,n,mm,gsl_matrix_get(Q_prima,n,mm)*-1);
    
  }  

}
Esempio n. 11
0
int main() {
	int ret;
	int i, j;
	gsl_vector* tau;
	gsl_matrix *A;
	gsl_matrix *Q, *R, *RTR;
	gsl_matrix_view Rtop;
	int M = 4;
	int N = 3;

	/*
	  gsl_matrix A;
	  double data[9];
	  memset(&A, 0, sizeof(gsl_matrix));
	  A.size1 = 3;
	  A.size2 = 3;
	  A.tda = 3;
	  A.data = data;
	  gsl_matrix_set(&A, 0, 0, 34.0);
	  gsl_matrix_set(&A, 0, 1, 4.0);
	  gsl_matrix_set(&A, 0, 2, 14.0);
	  gsl_matrix_set(&A, 1, 0, 1.0);
	  gsl_matrix_set(&A, 1, 1, 8.0);
	  gsl_matrix_set(&A, 1, 2, 3.0);
	  gsl_matrix_set(&A, 2, 0, 7.0);
	  gsl_matrix_set(&A, 2, 1, 1.0);
	  gsl_matrix_set(&A, 2, 2, 8.0);
	*/

	A = gsl_matrix_alloc(M, N);

	for (i=0; i<M; i++)
		for (j=0; j<N; j++)
			gsl_matrix_set(A, i, j, (double)rand()/(double)RAND_MAX);

	for (i=0; i<A->size1; i++) {
		printf((i==0) ? "A = (" : "    (");
		for (j=0; j<A->size2; j++) {
			printf(" %12.5g ", gsl_matrix_get(A, i, j));
		}
		printf(")\n");
	}
	printf("\n");

	tau = gsl_vector_alloc(N);

	ret = gsl_linalg_QR_decomp(A, tau);

	Q = gsl_matrix_alloc(M, M);
	R = gsl_matrix_alloc(M, N);

	ret = gsl_linalg_QR_unpack(A, tau, Q, R);

	for (i=0; i<Q->size1; i++) {
		printf((i==0) ? "Q = (" : "    (");
		for (j=0; j<Q->size2; j++) {
			printf(" %12.5g ", gsl_matrix_get(Q, i, j));
		}
		printf(")\n");
	}
	printf("\n");

	for (i=0; i<R->size1; i++) {
		printf((i==0) ? "R = (" : "    (");
		for (j=0; j<R->size2; j++) {
			printf(" %12.5g ", gsl_matrix_get(R, i, j));
		}
		printf(")\n");
	}
	printf("\n");


	Rtop = gsl_matrix_submatrix(R, 0, 0, N, N);
	RTR = gsl_matrix_alloc(N, N);
	gsl_matrix_memcpy(RTR, &(Rtop.matrix));
	ret = gsl_blas_dtrmm(CblasLeft, CblasUpper, CblasTrans, CblasNonUnit,
						 1.0, RTR, RTR);
	//(Rtop.matrix), &(Rtop.matrix));

	for (i=0; i<RTR->size1; i++) {
		printf((i==0) ? "RTR = (" : "      (");
		for (j=0; j<RTR->size2; j++) {
			printf(" %12.5g ", gsl_matrix_get(RTR, i, j));
		}
		printf(")\n");
	}
	printf("\n");

	gsl_matrix_free(RTR);


	gsl_matrix_free(Q);
	gsl_matrix_free(R);
	gsl_vector_free(tau);

	gsl_matrix_free(A);

	return 0;
}
Esempio n. 12
0
int
gsl_linalg_hesstri_decomp(gsl_matrix * A, gsl_matrix * B, gsl_matrix * U,
                          gsl_matrix * V, gsl_vector * work)
{
  const size_t N = A->size1;

  if ((N != A->size2) || (N != B->size1) || (N != B->size2))
    {
      GSL_ERROR ("Hessenberg-triangular reduction requires square matrices",
                 GSL_ENOTSQR);
    }
  else if (N != work->size)
    {
      GSL_ERROR ("length of workspace must match matrix dimension",
                 GSL_EBADLEN);
    }
  else
    {
      double cs, sn;          /* rotation parameters */
      size_t i, j;            /* looping */
      gsl_vector_view xv, yv; /* temporary views */

      /* B -> Q^T B = R (upper triangular) */
      gsl_linalg_QR_decomp(B, work);

      /* A -> Q^T A */
      gsl_linalg_QR_QTmat(B, work, A);

      /* initialize U and V if desired */

      if (U)
        {
          gsl_linalg_QR_unpack(B, work, U, B);
        }
      else
        {
          /* zero out lower triangle of B */
          for (j = 0; j < N - 1; ++j)
            {
              for (i = j + 1; i < N; ++i)
                gsl_matrix_set(B, i, j, 0.0);
            }
        }

      if (V)
        gsl_matrix_set_identity(V);

      if (N < 3)
        return GSL_SUCCESS; /* nothing more to do */

      /* reduce A and B */
      for (j = 0; j < N - 2; ++j)
        {
          for (i = N - 1; i >= (j + 2); --i)
            {
              /* step 1: rotate rows i - 1, i to kill A(i,j) */

              /*
               * compute G = [ CS SN ] so that G^t [ A(i-1,j) ] = [ * ]
               *             [-SN CS ]             [ A(i, j)  ]   [ 0 ]
               */
              gsl_linalg_givens(gsl_matrix_get(A, i - 1, j),
                                gsl_matrix_get(A, i, j),
                                &cs,
                                &sn);
              /* invert so drot() works correctly (G -> G^t) */
              sn = -sn;

              /* compute G^t A(i-1:i, j:n) */
              xv = gsl_matrix_subrow(A, i - 1, j, N - j);
              yv = gsl_matrix_subrow(A, i, j, N - j);
              gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

              /* compute G^t B(i-1:i, i-1:n) */
              xv = gsl_matrix_subrow(B, i - 1, i - 1, N - i + 1);
              yv = gsl_matrix_subrow(B, i, i - 1, N - i + 1);
              gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

              if (U)
                {
                  /* accumulate U: U -> U G */
                  xv = gsl_matrix_column(U, i - 1);
                  yv = gsl_matrix_column(U, i);
                  gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
                }

              /* step 2: rotate columns i, i - 1 to kill B(i, i - 1) */

              gsl_linalg_givens(-gsl_matrix_get(B, i, i),
                                gsl_matrix_get(B, i, i - 1),
                                &cs,
                                &sn);
              /* invert so drot() works correctly (G -> G^t) */
              sn = -sn;

              /* compute B(1:i, i-1:i) G */
              xv = gsl_matrix_subcolumn(B, i - 1, 0, i + 1);
              yv = gsl_matrix_subcolumn(B, i, 0, i + 1);
              gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

              /* apply to A(1:n, i-1:i) */
              xv = gsl_matrix_column(A, i - 1);
              yv = gsl_matrix_column(A, i);
              gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

              if (V)
                {
                  /* accumulate V: V -> V G */
                  xv = gsl_matrix_column(V, i - 1);
                  yv = gsl_matrix_column(V, i);
                  gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
                }
            }
        }

      return GSL_SUCCESS;
    }
} /* gsl_linalg_hesstri_decomp() */
Esempio n. 13
0
static void
linreg_fit_qr (const gsl_matrix *cov, linreg *l)
{
  double intcpt_coef = 0.0;
  double intercept_variance = 0.0;
  gsl_matrix *xtx;
  gsl_matrix *q;
  gsl_matrix *r;
  gsl_vector *xty;
  gsl_vector *tau;
  gsl_vector *params;
  double tmp = 0.0;
  size_t i;
  size_t j;

  xtx = gsl_matrix_alloc (cov->size1 - 1, cov->size2 - 1);
  xty = gsl_vector_alloc (cov->size1 - 1);
  tau = gsl_vector_alloc (cov->size1 - 1);
  params = gsl_vector_alloc (cov->size1 - 1);

  for (i = 0; i < xtx->size1; i++)
    {
      gsl_vector_set (xty, i, gsl_matrix_get (cov, cov->size2 - 1, i));
      for (j = 0; j < xtx->size2; j++)
	{
	  gsl_matrix_set (xtx, i, j, gsl_matrix_get (cov, i, j));
	}
    }
  gsl_linalg_QR_decomp (xtx, tau);
  q = gsl_matrix_alloc (xtx->size1, xtx->size2);
  r = gsl_matrix_alloc (xtx->size1, xtx->size2);

  gsl_linalg_QR_unpack (xtx, tau, q, r);
  gsl_linalg_QR_solve (xtx, tau, xty, params);
  for (i = 0; i < params->size; i++)
    {
      l->coeff[i] = gsl_vector_get (params, i);
    }
  l->sst = gsl_matrix_get (cov, cov->size1 - 1, cov->size2 - 1);
  l->ssm = 0.0;
  for (i = 0; i < l->n_indeps; i++)
    {
      l->ssm += gsl_vector_get (xty, i) * l->coeff[i];
    }
  l->sse = l->sst - l->ssm;

  gsl_blas_dtrsm (CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, linreg_mse (l),
		  r, q);
  /* Copy the lower triangle into the upper triangle. */
  for (i = 0; i < q->size1; i++)
    {
      gsl_matrix_set (l->cov, i + 1, i + 1, gsl_matrix_get (q, i, i));
      for (j = i + 1; j < q->size2; j++)
	{
	  intercept_variance -= 2.0 * gsl_matrix_get (q, i, j) *
	    linreg_get_indep_variable_mean (l, i) *
	    linreg_get_indep_variable_mean (l, j);
	  gsl_matrix_set (q, i, j, gsl_matrix_get (q, j, i));
	}
    }
  l->intercept = linreg_get_depvar_mean (l);
  tmp = 0.0;
  for (i = 0; i < l->n_indeps; i++)
    {
      tmp = linreg_get_indep_variable_mean (l, i);
      l->intercept -= l->coeff[i] * tmp;
      intercept_variance += tmp * tmp * gsl_matrix_get (q, i, i);
    }

  /* Covariances related to the intercept. */
  intercept_variance += linreg_mse (l) / linreg_n_obs (l);
  gsl_matrix_set (l->cov, 0, 0, intercept_variance);  
  for (i = 0; i < q->size1; i++)
    {
      for (j = 0; j < q->size2; j++)
	{
	  intcpt_coef -= gsl_matrix_get (q, i, j) 
	    * linreg_get_indep_variable_mean (l, j);
	}
      gsl_matrix_set (l->cov, 0, i + 1, intcpt_coef);
      gsl_matrix_set (l->cov, i + 1, 0, intcpt_coef);
      intcpt_coef = 0.0;
    }
      
  gsl_matrix_free (q);
  gsl_matrix_free (r);
  gsl_vector_free (xty);
  gsl_vector_free (tau);
  gsl_matrix_free (xtx);
  gsl_vector_free (params);
}