void
matrix_copy(Matrix *ToBeCopied, Matrix *Copy)
{
// In R notation, Copy <-ToBeCopied
const index_t nrow=numrows(Copy);
const index_t ncol=numcols(Copy);
if ((nrow!=numrows(ToBeCopied))||(ncol!=numcols(ToBeCopied)))
error("Incompatible dims in matrix_copy()");
// Much faster copying:
memcpy(Copy,ToBeCopied,sizeof(double)*nrow*ncol);
return;
}
void
matrix_sum_xx_m_mu_by_precinct(Matrix * const SS,
Matrix * const OMEGAS,
Matrix * const mu_mat_cu)
{
//
// Computes: \sum_{i=1}^{n} (\omega_{i}-\mu_{i})(\omega_{i}-\mu_{i})^{T}
// Implemented as: matrix_sum_xx_m_mu_by_precinct(SS, OMEGAS, mu_mat_cu);
//
const index_t n = numrows(OMEGAS);
if (numrows(mu_mat_cu)!=n)
error("OMEGAS and mu_mat_cu must have the same number of rows");
const index_t p = numcols(OMEGAS);
if (numcols(mu_mat_cu)!=p)
error("OMEGAS and mu_mat_cu must have the same number of cols");
if ((numrows(SS)!=p) || (numcols(SS)!=p))
error("SS must be p x p");
double tmp_omega_i_minus_mu_i[p];
index_t ii, jj, kk;
// First, set SS to zero matrix:
matrix_fastset(SS,0);
// Precinct-by-precinct:
for (ii=0; ii<n; ii++){
// First, do the omega_i - mu_i bit:
for (jj=0; jj<p; jj++){
tmp_omega_i_minus_mu_i[jj] = matrix_fast_get_element(OMEGAS,ii,jj,n) - matrix_fast_get_element(mu_mat_cu,ii,jj,n);
}
// Now do the xx^{T} bit:
for (jj=0; jj<p; jj++){
for (kk=0; kk<p; kk++){
matrix_fast_increment_element(SS,jj,kk,p, (tmp_omega_i_minus_mu_i[jj]*tmp_omega_i_minus_mu_i[kk]));
}
}
}
#ifdef _DBG_
Rprintf("Computing sum_{i=1}^{n}(omega_i-mu_i)(omega_i-mu_i)^{T}:\n\n");
Rprintf("OMEGAS:\n");
matrix_print_subset(OMEGAS,0,1,0,numcols(OMEGAS)-1);
Rprintf("MUS:\n");
matrix_print_subset(mu_mat_cu,0,1,0,numcols(mu_mat_cu)-1);
Rprintf("Result:\n");
matrix_print_all(SS);
#endif
return;
}
void
matrix_ADJUST(Matrix *xx, index_t kk)
{
// A function needed to sweep a matrix. See Goodnight,
// 33(3) Am. Stat. 149 (1979) for complete explanation.
// Function performs ADJUST(kk) on matrix xx.
index_t ii, jj;
double aa, aa_kk, aa_ik;
index_t nrow_xx = numrows(xx);
index_t ncol_xx = numcols(xx);
// Adjust row kk.
aa_kk = matrix_get_element(xx, kk, kk);
for (jj=(kk+1); jj<ncol_xx; jj++){
aa = matrix_get_element(xx, kk, jj);
matrix_set_element(xx, kk, jj, aa/aa_kk);
}
matrix_set_element(xx, kk, kk, 1.0);
// Adjust rows != kk.
for (ii=0; ii<nrow_xx; ii++){
if (ii == kk)
continue;
aa_ik = matrix_get_element(xx, ii, kk);
matrix_set_element(xx, ii, kk, 0.0);
for (jj=(kk+1); jj<ncol_xx; jj++){
aa = matrix_get_element(xx, ii, jj);
matrix_set_element(xx, ii, jj, aa-(aa_ik * matrix_get_element(xx, kk, jj)));
}
}
}
void
matrix_subtract(Matrix *xx, Matrix *yy, Matrix *zz)
{
// In R notation, implements zz <- xx - yy
index_t ii, jj, nrow_xx = numrows(xx), ncol_xx = numcols(xx);
for (ii=0; ii<nrow_xx; ii++)
for (jj=0; jj<ncol_xx; jj++)
matrix_set_element(zz, ii, jj, matrix_get_element(xx, ii, jj) - matrix_get_element(yy, ii, jj));
return;
}
void matrix_identity(Matrix *xx)
{
index_t ii, nr=numrows(xx), nc=numcols(xx);
if (nr!=nc)
error("Non-square matrix in matrix_identity()");
matrix_fastset(xx,0);
for (ii=0; ii<nr; ii++)
matrix_set_element(xx,ii,ii, 1.0);
return;
}
int
matrix_assert_vec(Matrix *xx)
{
// Runs several standard checks on a matrix that is supposed
// to be a vector (column or row). Returns 0 if anything is amiss,
// 1 if all is well.
if (xx == NULL)
error("Error: Vector that should not be NULL is NULL.\n");
index_t minn = min(numrows(xx), numcols(xx));
index_t maxx = max(numrows(xx), numcols(xx));
if (minn != 1)
error("Error: Vector has dimension less than 1.\n");
if (maxx < 1)
error("Error: Vector has no room for elements.\n");
return 1;
}
double matrix_quadform(Matrix *x, Matrix *A, Matrix *y)
{
// Computes x^{T}Ay
index_t i,j, nrowy=numrows(y), nrowx=numrows(x);
double ret=0.0;
if ((nrowy!=numcols(A)) || (nrowx!=numrows(A)))
error("Incompatible dims in matrix_quadform()");
for (i=0; i<nrowx; i++)
for (j=0; j<nrowy; j++)
ret += (matrix_get_element(x,i,0)*matrix_get_element(A,i,j)*matrix_get_element(y,j,0));
return ret;
}
void
matrix_transpose(Matrix *xx, Matrix *yy)
{ // yy <- t(xx)
index_t ii, jj;
const index_t nrow_xx=numrows(xx);
const index_t nrow_yy=numrows(yy);
const index_t ncol_xx=numcols(xx);
for (ii=0; ii<nrow_xx; ii++)
for (jj=0; jj<ncol_xx; jj++)
matrix_fast_set_element(yy, jj,ii,nrow_yy, matrix_fast_get_element(xx, ii,jj,nrow_xx));
return;
}
void
matrix_print_all(Matrix const * const xx)
{
index_t ii, jj, nrow_xx = numrows(xx), ncol_xx = numcols(xx);
for (ii=0; ii<nrow_xx; ii++){
for (jj=0; jj<ncol_xx; jj++){
matrix_print_element(xx, ii, jj);
}
Rprintf("\n");
}
return;
}
void
matrix_scalar_multiply(Matrix *xx, double ss, Matrix *yy)
{
// In R notation, executes yy <- ss * xx. User responsible
// for allocating memory to yy. yy can be the same as xx.
const index_t nrtnc=numrows(xx)*numcols(xx);
matrix_copy(xx,yy);
index_t ii;
for (ii=0; ii<nrtnc; ii++)
yy[ii] *= ss;
return;
}
static VOID set_internal_transformation P3C(int, vars, LVAL, m, LVAL, b)
{
int i, j, k, rows, cols;
LVAL data;
if (vars <= 0) return;
if (vars > maxvars) {
maxvars = 0;
StFree(transformdata);
StFree(transform);
StFree(inbasis);
transformdata = (double *) StCalloc(vars * vars, sizeof(double));
transform = (double **) StCalloc(vars, sizeof(double *));
for (i = 0; i < vars; i++) transform[i] = transformdata + vars * i;
inbasis = (int *) StCalloc(vars, sizeof(double));
maxvars = vars;
}
if (! matrixp(m)) xlerror("not a matrix", m);
rows = numrows(m);
cols = numcols(m);
if (rows > vars) rows = vars;
if (cols > vars) cols = vars;
if (rows != cols) xlerror("bad transformation matrix", m);
/* fill in upper left corner of transform from m; rest is identity */
data = getdarraydata(m);
for (i = 0, k = 0; i < rows; i++) {
for (j = 0; j < cols; j++, k++)
transform[i][j] = makefloat(gettvecelement(data, k));
for (j = cols; j < vars; j++)
transform[i][j] = (i == j) ? 1.0 : 0.0;
}
for (i = rows; i < vars; i++)
for (j = 0; j < vars; j++)
transform[i][j] = (i == j) ? 1.0 : 0.0;
/* figure out basis elements using b and size of m */
if (b != NIL) {
if (! seqp(b)) xlerror("not a sequence", b);
if (seqlen(b) != rows) xlerror("wrong length for basis", b);
for (i = 0; i < rows; i++)
inbasis[i] = (getnextelement(&b, i) != NIL) ? TRUE : FALSE;
}
else for (i = 0; i < rows; i++) inbasis[i] = TRUE;
for (i = rows; i < vars; i++) inbasis[i] = FALSE;
}
void
matrix_add(Matrix *xx, Matrix *yy, Matrix *zz)
{
// In R notation, implements zz <- xx + yy. User responsible
// for allocating memory to zz. zz could be the same as xx
// or yy.
index_t ii, jj;
const index_t nrow_xx = numrows(xx);
const index_t ncol_xx = numcols(xx);
const index_t nrow_yy = numrows(yy);
const index_t nrow_zz = numrows(zz);
for (ii=0; ii<nrow_xx; ii++)
for (jj=0; jj<ncol_xx; jj++)
matrix_fast_set_element(zz,ii,jj,nrow_zz, matrix_fast_get_element(xx, ii,jj,nrow_xx) +
matrix_fast_get_element(yy, ii,jj,nrow_yy));
return;
}
int
matrix_assert(Matrix *xx)
{
// Runs several standard checks on a matrix. Returns 0
// if anything is amiss, 1 if all is well
int ret_val = 1;
if (xx == NULL){
Rprintf("Error: Matrix that should not be NULL is NULL.\n");
ret_val = 0;
}
if ((numrows(xx) <= 0) || (numcols(xx) <= 0)){
Rprintf("Error: Matrix has fewer than 1 row or fewer than 1 column.\n");
ret_val = 0;
}
return ret_val;
}
int
matrix_assert_row_vec(Matrix *xx)
{
// Runs several standard checks on a matrix that is supposed
// to be a row vetor. Returns 0 if anything is amiss, 1 if
// all is well.
if (xx == NULL)
error("Error: Row vector that should not be NULL is NULL.\n");
if (numcols(xx) <= 0)
error("Error: Row vector has fewer than 1 column.\n");
if (numrows(xx) != 1)
error("Error: Row vector has number of rows not equal to 1.\n");
return 1;
}
void
matrix_transpose_same(Matrix *xx)
{
// In R notation, xx<-t(xx), but ONLY FOR SQUARE xx.
// Second function written for speed.
double aa;
index_t ii, jj, nrow_xx = numrows(xx), ncol_xx = numcols(xx);
for (ii=0; ii<nrow_xx; ii++){
for (jj=(ii+1); jj<ncol_xx; jj++){
aa = matrix_get_element(xx, ii, jj);
matrix_set_element(xx, ii, jj, matrix_get_element(xx, jj, ii));
matrix_set_element(xx, jj, ii, aa);
}
}
return;
}
int
matrix_assert_column_vec(Matrix *xx)
{
// Runs several standard checks on a matrix that is supposed
// to be a column vector. Returns 0
// if anything is amiss, 1 if all is well.
int ret_val = 1;
if (xx == NULL)
error("Error: Column vector that should not be NULL is NULL.\n");
if (numrows(xx) <= 0)
error("Error: Column vector has fewer than 1 row.\n");
if (numcols(xx) != 1)
error("Error: Column vector has number of columns not equal to 1.\n");
return ret_val;
}
void
matrix_sum_xx_m_mu(Matrix *yy, Matrix *xx, Matrix *mu_vec)
{
// Subtracts the row vector mu_vec from each row of XX,
// then multiplies the transpose of the resulting matrix
// by itself, sets the result equal to YY. In R notation,
// YY <- t(XX - t(mu_vec)) %*% (XX-t(mu_vec)). User
// allocates all memory.
// First, set y to zero matrix:
matrix_fastset(yy,0);
index_t ii, jj, kk;
const index_t nrow_mu = numrows(mu_vec);
const index_t nrow_yy = numrows(yy);
const index_t nrow_xx = numrows(xx);
const index_t ncol_xx = numcols(xx);
//double tmp_jj_factor;
// Begin by filling in the diagonals and upper triangle.
for (ii=0; ii<nrow_xx; ii++){
for (jj=0; jj<ncol_xx; jj++){
// Cache the unchanging elements (added 12/08/08) -- REMOVED, ACTUALLY SLOWER.
// tmp_jj_factor = (matrix_fast_get_element(xx, ii,jj,nrow_xx) - matrix_fast_get_element(mu_vec, 0,jj,nrow_mu));
for (kk=jj; kk<ncol_xx; kk++){
matrix_fast_increment_element(yy, jj,kk,nrow_yy,
(matrix_fast_get_element(xx, ii,jj,nrow_xx) - matrix_fast_get_element(mu_vec, 0,jj,nrow_mu))*
(matrix_fast_get_element(xx, ii,kk,nrow_xx) - matrix_fast_get_element(mu_vec, 0,kk,nrow_mu)));
}
}
}
// Now fill in the part below the diagonal.
for (jj=1; jj<ncol_xx; jj++){
for (kk=0; kk<jj; kk++){
matrix_fast_set_element(yy,jj,kk,nrow_yy, matrix_fast_get_element(yy,kk,jj,nrow_yy));
}
}
return;
}
LVAL xssurface_contour(V)
{
LVAL s1, s2, mat, result;
LVAL x, y, z;
double *dx, *dy, *dz;
double v;
int i, j, n, m;
s1 = xlgaseq();
s2 = xlgaseq();
mat = xlgamatrix();
v = makefloat(xlgetarg());
xllastarg();
n = seqlen(s1);
m = seqlen(s2);
if (n != numrows(mat) || m != numcols(mat))
xlfail("dimensions do not match");
xlstkcheck(4);
xlsave(x);
xlsave(y);
xlsave(z);
xlsave(result);
x = gen2linalg(s1, n, 1, s_c_double, FALSE); dx = REDAT(x);
y = gen2linalg(s2, m, 1, s_c_double, FALSE); dy = REDAT(y);
z = gen2linalg(mat, n, m, s_c_double, FALSE); dz = REDAT(z);
result = NIL;
for (i = 0; i < n - 1; i++) {
for (j = 0; j < m - 1; j++) {
result = add_contour_point(m, i, j, i, j+1, dx, dy, dz, v, result);
result = add_contour_point(m, i, j+1, i+1, j+1, dx, dy, dz, v, result);
result = add_contour_point(m, i+1, j+1, i+1, j, dx, dy, dz, v, result);
result = add_contour_point(m, i+1, j, i, j, dx, dy, dz, v, result);
}
}
xlpopn(4);
return(result);
}
void matrix_cholesky(Matrix *X, Matrix *Y)
{
// Sets Y equal to the cholesky decomp of X. Note per the definition,
// the cholesky decomp is an upper triangular matrix.
int i,j, m=numrows(X),n=numcols(X);
if (n!=m)
error("Non-square matrix in matrix_cholesky()");
// Copy X to Y (error check for dims inside matrix_copy)
matrix_copy(X,Y);
// Zero out lower triangle
for (j=0; j<n; j++)
for (i=j+1; i<n; i++)
matrix_set_element(Y,i,j,0.0);
// Compute: Cholesky factorization of Y (upper triangular)
//
//SUBROUTINE DPOTRF(UPLO,N,A,LDA,INFO)
//
// UPLO = 'U' => Upper triangle stored, 'L' => Lower triangle
// N = numrows(A)
// A = LDA-by-N matrix, leading N-by-N matrix to be factored
// On exit, the Cholesky factor
// LDA = Leading dimension of A
// INFO =0 => Successful exit
// >0 => if INFO = -i the ith argument had an illegal value
// <0 => if INFO = i the leading minor of order i is not p.d.
//
F77_CALL(dpotrf)("Upper",&m,Y,&m,&i);
//F77_CALL(chol)(X,&n,&n,Y,i);
if (i!=0){
if (i>0)
error("Leading minor is not positive definite in matrix_cholesky()");
error("Illegal value in matrix_cholesky()");
}
return;
}
/*
void
matrix_get_row(Matrix *m, index_t i, Matrix *v)
{
// Extracts the ith row of m to the column vector v
index_t j;
const index_t nc=numcols(m);
#ifdef _DBG_
len=numrows(v),
if (len!=nc)
error("Incompatible dimensions in matrix_get_row()");
#endif
for (j=0; j<nc; j++)
matrix_set_element(v,j,0, matrix_get_element(m,i,j));
return;
}
*/
int
matrix_is_symmetric(Matrix *xx)
{
// Checks a matrix for symmetry, aindex_t with other basic checks.
// Returns 1 if the matrix is
// symmetric, 0 if not symmetric (if something else is wrong).
int retval = 1;
index_t ii, jj, nrow_xx = numrows(xx), ncol_xx = numcols(xx);
Matrix *yy = matrix_new(nrow_xx, ncol_xx);
matrix_transpose(xx, yy);
matrix_scalar_multiply(yy, -1.0, yy);
matrix_add(xx, yy, yy);
for (ii=0; ii<nrow_xx; ii++)
for (jj=0; jj<ncol_xx; jj++)
if (matrix_get_element(yy, ii, jj) > DBL_EPSILON)
retval = 0;
matrix_free(yy);
return retval;
}
void
matrix_DOOLITTLE(Matrix *xx, index_t kk)
{
// A function needed to find the determinant and to
// find the cholesky decomposition of a matrix. See Goodnight,
// 33(3) Am. Stat. 149 (1979) for complete explanation.
// Function performs DOOLITTLE(kk) on matrix xx.
// Function will only work on a square matrix.
double aa_ij, aa_ik, aa_kk, aa_kj;
index_t ii, jj, nrow_xx = numrows(xx), ncol_xx = numcols(xx);
// Adjust rows below kk
aa_kk = matrix_get_element(xx, kk, kk);
for (ii=(kk+1); ii<nrow_xx; ii++){
aa_ik = matrix_get_element(xx, ii, kk);
for(jj=(kk+1); jj<ncol_xx; jj++){
aa_ij = matrix_get_element(xx, ii, jj);
aa_kj = matrix_get_element(xx, kk, jj);
matrix_set_element(xx, ii, jj, aa_ij - ((aa_ik/aa_kk)*aa_kj));
}
matrix_set_element(xx, ii, kk, 0.0);
}
}
void
matrix_cholesky(Matrix *xx, Matrix *yy)
{
// Sets yy equal to the cholesky decomp of xx. Note per the definition,
// the cholesky decomp is an upper triangular matrix.
index_t kk, jj;
double aa;
matrix_get_set_block(yy, 0, numrows(yy)-1, 0, numcols(yy)-1, xx, 0, numrows(xx)-1, 0, numcols(xx)-1);
for (kk=0; kk<(numrows(yy)-1); kk++){
matrix_DOOLITTLE(yy, kk);
aa = matrix_get_element(yy, kk, kk);
for (jj=kk; jj<numcols(yy); jj++){
matrix_set_element(yy, kk, jj, matrix_get_element(yy, kk, jj)/sqrt(aa));
}
}
matrix_set_element(yy, numcols(yy)-1, numcols(yy)-1,
sqrt(matrix_get_element(yy, numcols(yy)-1, numcols(yy)-1)));
}
void
matrix_multiply(Matrix * xx,
char tX,
Matrix * yy,
char tY,
Matrix * zz)
{
// In R notation, this function does zz <- xx %*% yy.
// User is responsible for allocating memory for zz.
index_t mm, nn, pp;
double aa;
const index_t nrow_xx = numrows(xx);
const index_t ncol_xx = numcols(xx);
const index_t ncol_yy = numcols(yy);
const index_t nrow_yy = numrows(yy);
const index_t nrow_zz = numrows(zz);
if ((tX=='N')&&(tY=='N')){
for (mm=0; mm<nrow_xx; mm++){
for (pp=0; pp<ncol_yy; pp++){
aa = 0.0;
for (nn=0; nn<ncol_xx; nn++){
aa += matrix_fast_get_element(xx,mm,nn,nrow_xx)*matrix_fast_get_element(yy,nn,pp,nrow_yy);
}
matrix_fast_set_element(zz, mm,pp,nrow_zz, aa);
}
}
return;
} else if ((tX=='T')&&(tY=='N')){
for (mm=0; mm<ncol_xx; mm++){
for (pp=0; pp<ncol_yy; pp++){
aa = 0.0;
for (nn=0; nn<nrow_xx; nn++){
aa += matrix_fast_get_element(xx,nn,mm,nrow_xx)*matrix_fast_get_element(yy,nn,pp,nrow_yy);
}
matrix_fast_set_element(zz, mm,pp,nrow_zz, aa);
}
}
return;
} else if ((tX=='N')&&(tY=='T')){
for (mm=0; mm<nrow_xx; mm++){
for (pp=0; pp<nrow_yy; pp++){
aa = 0.0;
for (nn=0; nn<ncol_xx; nn++){
aa += matrix_fast_get_element(xx,mm,nn,nrow_xx)*matrix_fast_get_element(yy,pp,nn,nrow_yy);
}
matrix_fast_set_element(zz, mm,pp,nrow_zz, aa);
}
}
return;
} else if ((tX=='T')&&(tY=='T')){
for (mm=0; mm<ncol_xx; mm++){
for (pp=0; pp<nrow_yy; pp++){
aa = 0.0;
for (nn=0; nn<nrow_xx; nn++){
aa += matrix_fast_get_element(xx,nn,mm,nrow_xx)*matrix_fast_get_element(yy,pp,nn,nrow_yy);
}
matrix_fast_set_element(zz, mm,pp,nrow_zz, aa);
}
}
return;
} else
error("Invalid tX and tY arguments in matrix multiply");
/*
Matrix *xx_copy, *yy_copy;
if (tX=='T'){
nrow_xx=numcols(xx), ncol_xx=numrows(xx);
xx_copy = matrix_new(nrow_xx,ncol_xx);
matrix_transpose(xx,xx_copy);
} else {
xx_copy = xx;
}
if (tY=='T'){
nrow_yy=numcols(yy), ncol_yy=numrows(yy);
yy_copy = matrix_new(nrow_yy,ncol_yy);
matrix_transpose(yy,yy_copy);
} else {
yy_copy = yy;
}
const index_t nrow_xxcpy = numrows(xx_copy);
const index_t nrow_yycpy = numrows(yy_copy);
for (mm=0; mm<nrow_xx; mm++){
for (pp=0; pp<ncol_yy; pp++){
aa = 0.0;
for (nn=0; nn<ncol_xx; nn++){
aa += matrix_fast_get_element(xx_copy, mm,nn,nrow_xxcpy)*
matrix_fast_get_element(yy_copy, nn,pp,nrow_yycpy);
}
matrix_fast_set_element(zz, mm,pp,nrow_zz, aa);
}
}
if (tX=='T')
matrix_free(xx_copy);
if (tY=='T')
matrix_free(yy_copy);
}
*/
return;
}
void matrix_multiply(Matrix *A, char tA, Matrix *B, char tB, Matrix *C)
{
char *transa, *transb;
int lda = numrows(A);
int ldb = numrows(B);
int ldc = numrows(C);
int m; // numrows(TRANSA(A)) == numrows(C)
int n; // numcols(TRANSB(B)) == numcols(C)
int k; // numcols(TRANSA(A)) == numrows(TRANSB(B))
int kChk;
if (tA=='T'){
transa="T";
m = numcols(A);
k = numrows(A);
} else {
transa="N";
m = numrows(A);
k = numcols(A);
}
if (tB=='T'){
transb="T";
n = numrows(B);
kChk = numcols(B);
} else {
transb = "N";
n = numcols(B);
kChk = numrows(B);
}
// Checks:
if (k!=kChk)
error("Incompatible dimensions in matrix_multiply()");
if ( (m!=numrows(C)) || (n!=numcols(C)) )
error("Incompatible output matrix in matrix_multiply()");
double one=1.0, zero=0.0;
// Compute: C := alpha*TRANSA(A)%*%TRANSB(B) + beta*C
//
//SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
//
// M = numrows(TRANSA(A)) == numrows(C)
// N = numcols(TRANSB(B)) == numcols(C)
// K = numcols(TRANSA(A)) == numcols(TRANSB(B))
// ALPHA = Scalar multiple of TRANSA(A)%*%TRANSB(B)
//
// A = Matrix A (LDA x ka) where 'N' => ka=K, 'T' => ka=M
// LDA = First dim of TRANS(A) (i.e. 'N'>=max(1,M), 'T'>=max(1,K))
// [NOTE: Only the first M (if 'N') or K (if 'T') rows are used]
//
// B = Matrix B (LDB x kb) where 'N' => kb=N, 'T' => kb=K
// LDB = First dim of TRANS(A) (i.e. 'N'>=max(1,K), 'T'>=max(1,N))
// [NOTE: Only the first N (if 'N') or K (if 'T') rows are used]
//
// BETA = Scalar multiple of C on RHS
// C = Matrix C (output)
// LDC = First dim of C (i.e. LDC>=max(1,M))
//
// C is the only input that is changed on exit
if (m>0 && n>0 && k>0){
F77_CALL(dgemm)(transa,transb,&m,&n,&k,&one,A,&lda,B,&ldb,&zero,C,&ldc);
} else
matrix_fastset(C,0);
return;
}
double matrix_determinant(Matrix *X, Matrix *Xsamedims, unsigned useLog)
{
// Returns = log(det(X)) if useLog!=0, det(X) if useLog==0
// Compute: An LU factorization of a general MxN matrix A
// using partial pivoting with row interchanges.
//
//SUBROUTINE DGETRF(M,N,A,LDA,IPIV,INFO)
//
// M = numrows(A)
// N = numcols(A)
// A = LDA-by-N matrix, with the leading M-by-N submatrix to be factored
// On exit, the factors L and U from the factorization
// A = P*L*U; the unit diagonal elements of L are not stored.
// LDA = Leading dimension of the array A. LDA >= max(1,M)
// IPIV = (output) INTEGER array, dimension (min(M,N))
// The pivot indices; for 1 <= i <= min(M,N), row i of the
// matrix was interchanged with row IPIV(i).
// INFO =0 => successful exit
// <0 => If INFO = -i, the i-th argument had an illegal value
// >0 => If INFO = i, U(i,i) is exactly zero. The factorization
// has been completed, but the factor U is exactly
// singular, and division by zero will occur if it is used
// to solve a system of equations.
int m = numrows(X), n = numcols(X);
// Copy to a deformable version (error check for dims in matrix_copy)
matrix_copy(X,Xsamedims);
int ii, info, sign, ipiv[(m<n)?m:n];
double modulus;
//dgetrf(m,n,Xsamedims,m,ipiv,&info); // C version
F77_CALL(dgetrf)(&m,&n,Xsamedims,&m,ipiv,&info); // R version
if (!info)
{//LU-decomposition successful:
sign = 1;
for (ii=0; ii<n; ii++)
if (ipiv[ii] != (ii+1))
sign = -sign;
if (useLog)
{
modulus = 0.0;
for (ii=0; ii<n; ii++){
double d_ii = Xsamedims[ii*(n+1)];
modulus += log( d_ii<0 ? -d_ii : d_ii );
if (d_ii<0)
sign = -sign;
}
} else {
modulus = 1.0;
for (ii=0; ii<n; ii++)
modulus *= Xsamedims[ii*(n+1)];
if (modulus<0){
modulus = -modulus;
sign = -sign;
}
}
// Customized for Jim's application where SIGMA should be p.d.:
if (sign<0)
error("Matrix not positive definite in matrix_determinant()");
return modulus;
} else
{//LU-decomposition failed:
if (info<0)
error("Illegal value in matrix_determinant()");
else
return (useLog ? R_NegInf : 0.0 );
}
return R_NegInf; // Can never reach here :)
}
