void gslu_rand_gaussian_matrix (const gsl_rng *r, gsl_matrix *A, const gsl_vector *mu, const gsl_matrix *Sigma, const gsl_matrix *L) { assert (A->size1 == mu->size && (Sigma || L)); for (size_t i=0; i<A->size1; i++) for (size_t j=0; j<A->size2; j++) gsl_matrix_set (A, i, j, gsl_ran_gaussian_ziggurat (r, 1.0)); if (L) { assert (L->size1 == L->size2 && L->size1 == mu->size); gsl_blas_dtrmm (CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, 1.0, L, A); } else { assert (Sigma->size1 == Sigma->size2 && Sigma->size1 == mu->size); gsl_matrix *_L = gsl_matrix_alloc (Sigma->size1, Sigma->size2); gsl_matrix_memcpy (_L, Sigma); gsl_linalg_cholesky_decomp (_L); gsl_blas_dtrmm (CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, 1.0, _L, A); gsl_matrix_free (_L); } for (size_t j=0; j<A->size2; j++) { gsl_vector_view a = gsl_matrix_column (A, j); gsl_vector_add (&a.vector, mu); } }
//Wishart distribution random number generator int ran_wishart(const gsl_rng *r, const double nu, const gsl_matrix *V, gsl_matrix *X) { const int k = V->size1; int i, j; gsl_matrix *A = gsl_matrix_calloc(k, k); gsl_matrix *L = gsl_matrix_alloc(k, k); for(i=0; i<k; i++) { gsl_matrix_set(A, i, i, sqrt(gsl_ran_chisq(r, (nu-i)))); for (j=0; j<i; j++){ gsl_matrix_set(A, i, j, gsl_ran_gaussian(r, 1)); } } gsl_matrix_memcpy(L, V); gsl_linalg_cholesky_decomp(L); gsl_blas_dtrmm(CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, 1.0, L, A); gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, A, A, 0.0, X); gsl_matrix_free(A); gsl_matrix_free(L); return 0; }
int rwishart(const gsl_rng *r, const unsigned int n, const unsigned int dof, const gsl_matrix *scale, gsl_matrix *result) { unsigned int k,l; gsl_matrix *work = gsl_matrix_calloc(n,n); for(k=0; k<n; k++){ gsl_matrix_set( work, k, k, sqrt( gsl_ran_chisq( r, (dof-k) ) ) ); for(l=0; l<k; l++) gsl_matrix_set( work, k, l, gsl_ran_ugaussian(r) ); } gsl_matrix_memcpy(result,scale); gsl_linalg_cholesky_decomp(result); gsl_blas_dtrmm(CblasLeft,CblasLower,CblasNoTrans,CblasNonUnit,1.0,result,work); gsl_blas_dsyrk(CblasUpper,CblasNoTrans,1.0,work,0.0,result); return 0; }
void GenerateRandMVnorm(gsl_rng * r, const size_t numSamples, const double * mu, const gsl_matrix *sigChol, const size_t NumParam, gsl_matrix * returnSamples) { // generate standard normal random samples for(size_t i = 0; i < numSamples; i++) for(size_t j = 0; j < NumParam; j++) gsl_matrix_set(returnSamples, i, j, gsl_ran_gaussian(r, 1.0)); gsl_blas_dtrmm(CblasRight, CblasLower, CblasTrans, CblasNonUnit, 1.0, sigChol, returnSamples); // matrix multiplcation stdNormSamples %*% sigChol, for upper triangular matrix // add mu to each row gsl_vector_const_view vecMu = gsl_vector_const_view_array(mu, NumParam); #pragma omp parallel for for(size_t i = 0; i < numSamples; i++){ gsl_vector_view tmpRow = gsl_matrix_row(returnSamples, i); gsl_vector_add(&tmpRow.vector, &vecMu.vector); } return; }
static VALUE rb_gsl_blas_dtrmm(VALUE obj, VALUE s, VALUE u, VALUE ta, VALUE d, VALUE a, VALUE aa, VALUE bb) { gsl_matrix *A = NULL, *B = NULL; double alpha; CBLAS_SIDE_t Side; CBLAS_UPLO_t Uplo; CBLAS_TRANSPOSE_t TransA; CBLAS_DIAG_t Diag; CHECK_FIXNUM(s); CHECK_FIXNUM(u); CHECK_FIXNUM(ta); CHECK_FIXNUM(d); Need_Float(a); CHECK_MATRIX(aa); CHECK_MATRIX(bb); Side = FIX2INT(s); Uplo = FIX2INT(u); TransA = FIX2INT(ta); Diag = FIX2INT(d); alpha = NUM2DBL(a); Data_Get_Struct(aa, gsl_matrix, A); Data_Get_Struct(bb, gsl_matrix, B); gsl_blas_dtrmm(Side, Uplo, TransA, Diag, alpha, A, B); return bb; }
static VALUE rb_gsl_blas_dtrmm2(VALUE obj, VALUE s, VALUE u, VALUE ta, VALUE d, VALUE a, VALUE aa, VALUE bb) { gsl_matrix *A = NULL, *B = NULL, *Bnew = NULL; double alpha; CBLAS_SIDE_t Side; CBLAS_UPLO_t Uplo; CBLAS_TRANSPOSE_t TransA; CBLAS_DIAG_t Diag; CHECK_FIXNUM(s); CHECK_FIXNUM(u); CHECK_FIXNUM(ta); CHECK_FIXNUM(d); Need_Float(a); CHECK_MATRIX(aa); CHECK_MATRIX(bb); Side = FIX2INT(s); Uplo = FIX2INT(u); TransA = FIX2INT(ta); Diag = FIX2INT(d); alpha = NUM2DBL(a); Data_Get_Struct(aa, gsl_matrix, A); Data_Get_Struct(bb, gsl_matrix, B); Bnew = gsl_matrix_alloc(B->size1, B->size2); gsl_matrix_memcpy(Bnew, B); gsl_blas_dtrmm(Side, Uplo, TransA, Diag, alpha, A, Bnew); return Data_Wrap_Struct(cgsl_matrix, 0, gsl_matrix_free, Bnew); }
static int my_main (int argc, char **argv) { setlocale (LC_ALL, ""); scm_dynwind_begin (0); CBLAS_SIDE_t Side = side_func (argv[1]); CBLAS_UPLO_t Uplo = uplo_func (argv[2]); CBLAS_TRANSPOSE_t TransA = trans_func (argv[3]); CBLAS_DIAG_t Diag = diag_func (argv[4]); int m = atoi (argv[5]); int n = atoi (argv[6]); mpq_t alpha; mpq_init (alpha); scm_dynwind_mpq_clear (alpha); mpq_set_str (alpha, argv[7], 0); mpq_canonicalize (alpha); int k = (Side == CblasLeft) ? m : n; mpq_t A[k][k]; mpq_matrix_init (k, k, A); scm_dynwind_mpq_matrix_clear (k, k, A); mpq_t B[m][n]; mpq_matrix_init (m, n, B); scm_dynwind_mpq_matrix_clear (m, n, B); double A1[k][k]; double B1[m][n]; gsl_matrix_view mA1 = gsl_matrix_view_array (&A1[0][0], k, k); gsl_matrix_view mB1 = gsl_matrix_view_array (&B1[0][0], m, n); unsigned int i_argv = 8; for (unsigned int i = 0; i < k; i++) for (unsigned int j = 0; j < k; j++) { mpq_set_str (A[i][j], argv[i_argv], 0); mpq_canonicalize (A[i][j]); A1[i][j] = mpq_get_d (A[i][j]); i_argv++; } for (unsigned int i = 0; i < m; i++) for (unsigned int j = 0; j < n; j++) { mpq_set_str (B[i][j], argv[i_argv], 0); mpq_canonicalize (B[i][j]); B1[i][j] = mpq_get_d (B[i][j]); i_argv++; } mpq_matrix_trmm (Side, Uplo, TransA, Diag, m, n, alpha, A, B); gsl_blas_dtrmm (Side, Uplo, TransA, Diag, mpq_get_d (alpha), &mA1.matrix, &mB1.matrix); int exit_status = 0; // Check that we get the same results as gsl_blas_dtrmm. for (unsigned int i = 0; i < m; i++) for (unsigned int j = 0; j < n; j++) { gmp_printf ("B[%u][%u] = %lf\t%Qd\n", i, j, B1[i][j], B[i][j]); if (10000 * DBL_EPSILON < fabs (mpq_get_d (B[i][j]) - B1[i][j])) exit_status = 1; } scm_dynwind_end (); return exit_status; }
/** * C++ version of gsl_blas_dtrmm(). * @param Side Side to apply operation to * @param Uplo Upper or lower triangular * @param TransA Transpose type * @param Diag Diagonal type * @param alpha A constant * @param A A matrix * @param B Another matrix * @return Error code on failure */ int dtrmm( CBLAS_SIDE_t Side, CBLAS_UPLO_t Uplo, CBLAS_TRANSPOSE_t TransA, CBLAS_DIAG_t Diag, double alpha, matrix const& A, matrix& B ){ return gsl_blas_dtrmm( Side, Uplo, TransA, Diag, alpha, A.get(), B.get() ); }
// Wald Test used in both summary and anova (polymophism) int GlmTest::GeeWald(glm *Alt, gsl_matrix *LL, gsl_vector *teststat) { gsl_set_error_handler_off(); unsigned int i, j, l; double alpha, result, sum=0; unsigned int nP = Alt->nParams; unsigned int nDF = LL->size1; unsigned int nVars=tm->nVars, nRows=tm->nRows; int status; gsl_vector *LBeta = gsl_vector_alloc(nVars*nDF); gsl_vector_set_zero(LBeta); gsl_matrix *w1jX1=gsl_matrix_alloc(nRows, nP); gsl_matrix *XwX=gsl_matrix_alloc(nP, nP); gsl_matrix *Rl2 = gsl_matrix_alloc(nDF, nP); gsl_matrix *IinvN = gsl_matrix_alloc(nDF, nDF); gsl_matrix *IinvRl = gsl_matrix_alloc(nVars*nDF, nVars*nDF); gsl_vector *tmp = gsl_vector_alloc(nVars*nDF); gsl_vector_view tmp2, wj, LBj, bj; //, dj; gsl_matrix_view Rl; gsl_matrix_set_zero(IinvRl); GrpMat *Z = (GrpMat*)malloc(nVars*sizeof(GrpMat)); for (j=0; j<nVars; j++){ Z[j].matrix = gsl_matrix_alloc(nP, nRows); // w1jX1 = W^1/2 * X wj=gsl_matrix_column(Alt->wHalf, j); for (i=0; i<nP; i++) gsl_matrix_set_col (w1jX1, i, &wj.vector); gsl_matrix_mul_elements (w1jX1, Alt->Xref); // LBeta = L*Beta LBj=gsl_vector_subvector(LBeta, j*nDF, nDF); bj=gsl_matrix_column(Alt->Beta, j); gsl_blas_dgemv(CblasNoTrans,1,LL,&bj.vector,0,&LBj.vector); // Z = (X^T W X)^-1 * X^T W^1/2. gsl_matrix_set_identity(XwX); gsl_blas_dsyrk (CblasLower,CblasTrans,1.0,w1jX1,0.0,XwX); status=gsl_linalg_cholesky_decomp (XwX); if (status==GSL_EDOM) { if (tm->warning==TRUE) printf("Warning:singular matrix in wald test. An eps*I is added to the singular matrix.\n"); gsl_matrix_set_identity(XwX); gsl_blas_dsyrk(CblasLower,CblasTrans,1.0,w1jX1,eps,XwX); gsl_linalg_cholesky_decomp(XwX); } gsl_linalg_cholesky_invert(XwX); gsl_blas_dgemm(CblasNoTrans,CblasTrans,1.0,XwX,w1jX1,0.0, Z[j].matrix); gsl_matrix_memcpy(Rl2, LL); gsl_blas_dtrmm (CblasRight,CblasLower,CblasNoTrans,CblasNonUnit,1.0,XwX,Rl2); // L*(X'WX)^-1 gsl_blas_dgemm (CblasNoTrans, CblasTrans, 1.0, Rl2, LL, 0.0, IinvN); // L*(X^T*W*X)^-1*L^T if ( (tm->punit!=NONE) || (tm->corr==IDENTITY) ) { status=gsl_linalg_cholesky_decomp (IinvN); if (status==GSL_EDOM) { if (tm->warning==TRUE) printf("Warning:singular IinvN in wald test.\n"); } tmp2=gsl_vector_subvector(tmp, 0, nDF); gsl_linalg_cholesky_solve (IinvN, &LBj.vector, &tmp2.vector); gsl_blas_ddot (&LBj.vector, &tmp2.vector, &result); gsl_vector_set(teststat, j+1, sqrt(result)); sum = sum + result; } if (tm->corr!=IDENTITY) { // IinvRl=L*vSandRl*L^T for (l=0; l<=j; l++) { Rl=gsl_matrix_submatrix(IinvRl,j*nDF,l*nDF,nDF,nDF); alpha = gsl_matrix_get(Rlambda, j, l); // borrow XwX space to store vSandRl gsl_blas_dgemm(CblasNoTrans,CblasTrans,alpha,Z[j].matrix,Z[l].matrix, 0.0, XwX); // Rl2 = L*vSandRl*L^T gsl_blas_dgemm(CblasNoTrans,CblasNoTrans,1.0,LL,XwX,0.0,Rl2); gsl_blas_dgemm(CblasNoTrans,CblasTrans,1.0,Rl2,LL,0.0,&Rl.matrix); } // end l } // end if (tm->corr) } // end for j=1:nVars if ( tm->corr==IDENTITY ) gsl_vector_set(teststat, 0, sqrt(sum)); else { status=gsl_linalg_cholesky_decomp (IinvRl); if (status==GSL_EDOM) { if (tm->warning==TRUE) printf("Warning:singular matrix in multivariate wald test.\n"); } gsl_linalg_cholesky_solve (IinvRl, LBeta, tmp); gsl_blas_ddot (LBeta, tmp, &result); gsl_vector_set(teststat, 0, sqrt(result)); } // free memory for (j=0; j<nVars; j++) gsl_matrix_free(Z[j].matrix); free(Z); gsl_vector_free(LBeta); gsl_matrix_free(w1jX1); gsl_matrix_free(XwX); gsl_matrix_free(Rl2); gsl_matrix_free(IinvN); gsl_matrix_free(IinvRl); gsl_vector_free(tmp); return SUCCESS; }
void HLayeredBlWStructure::VkB( gsl_matrix *X, long k, const gsl_matrix *B ) const { gsl_matrix_memcpy(X, B); gsl_blas_dtrmm(CblasLeft, CblasLower, (k > 0 ? CblasNoTrans : CblasTrans), CblasNonUnit, 1.0, getWk(abs(k)), X); }
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; }