void prcomp(int n, int m,double **x,double **UtX,double *D)
{
int i,j;
double *mu,*nu,*ltsigma,**xx,**V,**Vt;
MAKE_VECTOR(mu,m);
MAKE_VECTOR(ltsigma,m*(m+1)/2);
meandispersion(x,n,m,mu,ltsigma);
FREE_VECTOR(ltsigma);
MAKE_MATRIX(xx,n,m);
for(i=0;i<n;i++) {
for(j=0;j<m;j++) xx[i][j]=(x[i][j]-mu[j])/sqrt(n-1.);
}
MAKE_MATRIX(V,m,m);
i=svdd(xx,n,m,D,UtX,V);
MAKE_MATRIX(Vt,m,m);
matrpose(V,m,m,Vt);
MAKE_VECTOR(nu,m);
i=matxvec(Vt,m,m,mu,m,nu);
FREE_MATRIX(Vt);
FREE_VECTOR(mu);
FREE_MATRIX(V);
FREE_MATRIX(xx);
for(i=0;i<n;i++) {
for(j=0;j<m;j++) {
UtX[i][j]*=D[j];
UtX[i][j]+=nu[j];
}
}
FREE_VECTOR(nu);
return;
}
int randomEMinit(double **x, int n, int p, int nclass, double *pi,
double **Mu, double **LTSigma)
{
int *ordr,i,j,*clas,*nc;
/* This is a bug. Modified by Wei-Chen Chen on 2009/03/13.
MAKE_VECTOR(ordr,n);
*/
MAKE_VECTOR(ordr, nclass);
MAKE_VECTOR(clas, n);
MAKE_VECTOR(nc, nclass);
do {
/* This is a bug. Modified by Wei-Chen Chen on 2009/03/13.
i=srswor(n, n, ordr);
*/
i=srswor(n, nclass, ordr);
for(i=0;i<nclass;i++){
for(j=0;j<p;j++) Mu[i][j]=x[ordr[i]][j];
}
for(i=0;i<n;i++) clas[i]=assign_closest(x[i],p,nclass,Mu);
j=initials(x,n,p,nclass,nc,Mu,LTSigma,clas);
} while (j==0);
for(i=0;i<nclass;i++) pi[i]=1.*nc[i]/n;
FREE_VECTOR(nc);
FREE_VECTOR(clas);
FREE_VECTOR(ordr);
return 0;
}
int svdd(double **a, int m, int n, double *d, double **u, double **v)
{
double *A, *U, *VT;
int lwork = -1;
int liwork = 8*MIN(m,n);
char jobz = 'S';
double dw,*work=&dw; /*points to a temporary cell*/
int *iwork;
int i, j, k, info,minmn=MIN(m,n);
MAKE_VECTOR(A, m*n);
for (j=0, k=0; j<n; j++) {
for (i=0; i<m; i++) A[k++] = a[i][j];
}
MAKE_VECTOR(U, m*minmn);
MAKE_VECTOR(VT,minmn*n);
MAKE_VECTOR(iwork, liwork);
lwork=-1;
dgesdd_(&jobz, &m, &n, A, &m, d, U, &m, VT, &n,
work, &lwork, iwork, &info); /*call to get optimal lwork*/
if (info!=0) {
//WCC printf("error: allocating LWORK in svdd\n");
//WCC exit(1);
error("error: allocating LWORK in svdd\n");
}
lwork=(int)*work;
MAKE_VECTOR(work, lwork);
dgesdd_(&jobz, &m, &n, A, &m, d, U, &m, VT, &minmn,
work, &lwork, iwork, &info);
FREE_VECTOR(A);
FREE_VECTOR(work);
FREE_VECTOR(iwork);
for (j=0, k=0; j<minmn; j++) {
for (i=0; i<m; i++) u[i][j]=U[k++];
}
/* VT, as calculated by dgesdd_(), is the transpose of the right
* multiplier. Here we undo the transpose so that the matrix
* v[][] returned by this function is not transposed anymore.
*/
for (i=0,k=0; i<n; i++) {
for (j=0; j<minmn; j++) v[i][j]=VT[k++];
}
FREE_VECTOR(U);
FREE_VECTOR(VT);
return info;
}
int eigend(double *A, double *EV, double *E, int n)
{
int lwork=-1,liwork=-1;
double dx,*z,*a,*w,*work = &dx;/* work points to a temporary cell */
int info,ix,i,j,*iwork = &ix; /* iwork points to a temporary cell */
char jobz='V', uplo='U';
MAKE_VECTOR(a,n*(n+1)/2);
MAKE_VECTOR(w,n);
MAKE_VECTOR(z,n*n);
for(i=0;i<n*(n+1)/2;i++) a[i]=A[i];
/* Call dspevd_() with lwork=-1 and liwork=-1 to query the optimal sizes of
* the work and iwork arrays.
* */
dspevd_(&jobz,&uplo,&n,a,w,z,&n,work,&lwork,iwork,&liwork,&info);
if (info==0) {
lwork = (int)*work;
liwork = *iwork;
/* allocate optimal sizes for work and iwork */
MAKE_VECTOR(work,lwork);
MAKE_VECTOR(iwork,liwork);
if (work!=NULL && iwork!=NULL) {
dspevd_(&jobz,&uplo,&n,a,w,z,&n,work,&lwork,iwork,&liwork,&info);
if (info==0) {
for(i=0;i<n;i++) {
E[i]=w[n-1-i];
for (j=0;j<n;j++) {
EV[j*n+i]=z[(n-1-j)*n+i];
}
}
}
else {
REprintf("error in dspvd at calculation stage: Error code %d\n",info);
}
}
FREE_VECTOR(work);
FREE_VECTOR(iwork);
}
FREE_VECTOR(a);
FREE_VECTOR(w);
FREE_VECTOR(z);
return info;
}
/* shortems() for model-based initializer. */
void shortems_mb(int n,int p,int nclass,double *pi,double **X,double **Mu,
double **LTSigma,int maxshortiter,double shorteps){
int i, iter, totiter = 0, n_par = p * (p + 1) / 2;
double *oldpi, **oldMu, **oldLTSigma, oldllh = -Inf, llhval;
MAKE_VECTOR(oldpi, nclass);
MAKE_MATRIX(oldMu, nclass, p);
MAKE_MATRIX(oldLTSigma, nclass, n_par);
do{
mb_init(X, n, p, nclass, oldpi, oldMu, oldLTSigma);
iter = maxshortiter - totiter;
iter = shortemcluster(n, p, nclass, oldpi, X, oldMu, oldLTSigma, iter,
shorteps, &llhval);
if(llhval >= oldllh){
oldllh = llhval;
cpy(oldMu, nclass, p, Mu);
cpy(oldLTSigma, nclass, n_par, LTSigma);
for(i = 0; i < nclass; i++) pi[i] = oldpi[i];
}
totiter += iter;
} while(totiter < maxshortiter);
FREE_MATRIX(oldMu);
FREE_MATRIX(oldLTSigma);
FREE_VECTOR(oldpi);
} /* End of shortems_mb(). */
int shortems(int n,int p,int nclass,double *pi,double **X,double **Mu,
double **LTSigma,int maxshortiter,double shorteps)
{
/*initializing as per Beiernacki, Celeaux, Govaert~(2003) */
int i,iter,totiter=0;
double *oldpi,**oldMu,**oldLTSigma,oldllh=-Inf,llhval;
MAKE_VECTOR(oldpi,nclass);
MAKE_MATRIX(oldMu,nclass,p);
MAKE_MATRIX(oldLTSigma,nclass,p*(p+1)/2);
do {
/* Modified by Wei-Chen Chen on 2009/03/08.
i=randomEMinit(X,n,p,nclass,oldpi,oldMu,oldLTSigma);
i = mb_randomEMinit(X, n, p, nclass, oldpi, oldMu, oldLTSigma);
*/
i = randomEMinit(X, n, p, nclass, oldpi, oldMu, oldLTSigma);
iter=maxshortiter-totiter;
iter=shortemcluster(n,p,nclass,oldpi,X,oldMu,oldLTSigma,iter,shorteps,
&llhval);
if (llhval >= oldllh) {
int i;
oldllh=llhval;
cpy(oldMu,nclass,p,Mu);
cpy(oldLTSigma,nclass,p*(p+1)/2,LTSigma);
for(i=0;i<nclass;i++) pi[i]=oldpi[i];
}
totiter+=iter;
} while (totiter < maxshortiter);
FREE_MATRIX(oldMu);
FREE_MATRIX(oldLTSigma);
FREE_VECTOR(oldpi);
return totiter;
}
void unique(int n,double *x,int *m,double *y) /* Returns the unique values in
x in ascending order: the
number of unique values is
output in m and the unique
values are output in sorted
order in y */
{
int i,j;
double *dum;
MAKE_VECTOR(dum,n);
for(i=0;i<n;i++) dum[i]=x[i];
sort(n,dum);
i=0;
j=0;
while (j<n) {
y[i]=dum[j];
while ((j<n) && (dum[j]==y[i])) {
j++;
}
i++;
}
(*m)=i;
FREE_VECTOR(dum);
return;
}
int posymatinv(int size,double **A,double (*determinant))
{
int i, j,INFO,N,LDA ;
char uplo='L';
double *AT; /* AT=transpose vectorized matrix (to accomodate Fortran) */
MAKE_VECTOR(AT,size*size);
for (i=0; i<size; i++) /* to call a Fortran routine from C */
{ /* have to transform the matrix */
for(j=0; j<size; j++) AT[j+size*i]=A[j][i];
}
N=size;
LDA=size;
dpotrf_ (&uplo, &N, AT, &LDA, &INFO);
/* LAPACK routine DPOTRF computes an Cholesky decomposition of
a symmetric positive definite matrix A.
Parameters in the order as they appear in the function call:
uplo="U" indicates that the strictly lower triangular part of
A will be ignored, N is the order of the matrix A, the
matrix A, the leading dimension of A, and the flag for the
result. On exit, the upper triangle of A contains U.*/
if (INFO==0) {
int i;
(*determinant)=1.0;
for (i=0; i<N; i++) {
(*determinant)*=AT[i+i*N]*AT[i+i*N];
}
dpotri_ (&uplo, &N, AT, &LDA, &INFO);
/* LAPACK routine DPOTRI computes the inverse of a matrix A
using the output of DPOTRF. This method inverts U using the
Cholesky factorization of A.
Parameters in the order as they appear in the function call:
uplo="U" indicates that the strictly lower triangular part of
A will be ignored, c1 is the order of the matrix A, the
matrix A, the leading dimension of A, and the flag for the
result. On exit, the upper triangle of A contains U.*/
if (INFO!=0) {
/* Marked by Wei-Chen Chen on 2009/06/07.
* printf("Problem in posymatinv: dpotri error %d\n",INFO);
*/
}
}
else {
/* Marked by Wei-Chen Chen on 2009/06/07.
* printf("Problem in posymatinv: dpotrf error %d\n",INFO);
*/
}
for (i=0; i<size; i++) { /*transform the matrix back*/
for(j=i; j<size; j++) {
A[j][i]=AT[j+size*i];
A[i][j]=AT[j+size*i];
}
}
FREE_VECTOR(AT);
return 0;
}
double dlmvnorm_singular(double *x, int p, double *mu, double *LTsigma)
{
/* Calculates the p-variate Gaussian log-density at the p-variate point x
with mean mu and the lower triangle (px(p+1)/2) LTsigma of the
pxp-dimensional dispersion matrix Sigma.
Note that this function actually incorporates the case for singular
determinants
*/
double *eivec,*eival,value=0;
int i,ind=0;
MAKE_VECTOR(eivec,p*p);
MAKE_VECTOR(eival,p);
i=eigens(LTsigma,eivec,eival,p);
if (eival[0]==0) { /* only possible if LTsigma is all zero, which means
that the distribution is degenerate at mu */
for(i=0;((i<p) && (!ind));i++) if (x[i]!=mu[i]) ind =1;
if (ind) value=-Inf;
else value=0;
}
else {
int j,dmin;
double *y,*z,sum=0,sump=0;
for(i=0;i<p;i++) sum+=eival[i];
for(i=0;((i<p) && (sump<0.99));i++) {
sump+=eival[i]/sum;
value-=0.5*log(eival[i]);
}
dmin=i;
MAKE_VECTOR(y,p);
for(i=0;i<p;i++) y[i]=x[i]-mu[i];
MAKE_VECTOR(z,dmin);
for(i=0;i<dmin;i++) z[i]=0;
for(i=0;i<dmin;i++) {
for(j=0;j<p;j++) z[i]+=eivec[j*p+i]*y[j];
}
FREE_VECTOR(y);
for(i=0;i<dmin;i++) value-=0.5*z[i]*z[i]/eival[i];
FREE_VECTOR(z);
value-=0.5*dmin*log(2*PI);
}
FREE_VECTOR(eival);
FREE_VECTOR(eivec);
return value;
}
/* Front end to LP_sym_eigvecs
*
* Calculates the eigenvalues and eigenvectors of the nxn symmetric matrix A.
* The eigenvalues are returned in the vector w.
* The (orthonormal) eigenvectors are returned in the matrix z.
* The ith column of z holds the eigenvector associated with w[i].
* Written by xxxxx
* Note that one major task done here is to reverse the order of the
* eigenvalues (to something that makes more sense) and to put them in
* decreasing order and the corresponding eigenvectors
* */
int symeigens(double *a, int n, double *w, double *z)
{
double *eval,*evec;
int i,j,info;
MAKE_VECTOR(eval,n);
MAKE_VECTOR(evec,n*n);
info=LP_sym_eigvecs(a,n,eval,evec);
if (info==0) {
for(i=0;i<n;i++) {
w[i]=eval[n-1-i];
for (j=0;j<n;j++) {
z[j*n+i]=evec[(n-1-j)*n+i];
}
}
}
FREE_VECTOR(eval);
FREE_VECTOR(evec);
return info;
}
int polaroid(int p, double *x, double *R, double *theta)
/* This function calculates the polar coordinates of a p-variate vector x and
returns its norm, R and the (p-1)-dimensional angular coordinates theta. The
function returns the index of the elements in x, after which all the
coordinates are zero. This means that the theta's from that index are
undefined.
Written by xxxxxxxxxxxxx. */
{
int i;
double sum = 0.;
for (i = 0; i < p; i++) sum += x[i]*x[i];
(*R) = sqrt(sum);
for (i = 0; i < (p - 1); i++) theta[i] = 0.;
if (sum == 0) return 0;
else {
int k;
double *y;
MAKE_VECTOR(y, p - 1);
y[0] = sum;
for (i = 1; i < (p - 1); i++) y[i] = y[i-1] - x[i-1]*x[i-1];
for (k = 1; (k <= (p - 1)) && (y[k - 1] > 0); k++);
for (i = 0; i < (k - 1); i++) {
theta[i] = acos( x[i] / sqrt(y[i]));
}
if (k == p) {
/* if (SIGN(sin(theta[p - 2])) != SIGN(x[p - 1])) {*/
if (NEG(x[p - 1])) {
/* printf("\n\nhere we are %d %d %d\n\n", NEG(sin(theta[p - 2] / x[p - 1])), k, p);
printf("x[%d] = %f, y[%d] = %f\n", p-1, x[p-1], p-2, sqrt(y[p-2]));
printf("\n cos = %e sin = %e x/r = %e\n",
cos(theta[p-2]), sin(theta[p - 2]), x[p - 1] / sqrt(y[p - 2]));
*/
theta[p - 2] = 2*PI - theta[p - 2];
/* printf("\n cos = %e sin = %e x/r = %e\n",
cos(theta[p-2]), sin(theta[p - 2]), x[p - 1] / sqrt(y[p - 2]));
*/ }
}
FREE_VECTOR(y);
return k;
}
}
void cut_sub(double **X, int n, int p, int G, int min_n, double lambda,
double *prob, double **Mu, double **LTSigma){
int i, index_center, size_nb, *index_prob;
int tmp_G = G - 1, tmp_min_n;
double new_pi[1] = {1.0}, **new_Mu, **new_LTSigma, **new_X;
double tmp_center;
/* Get the seed state from R. */
GetRNGstate();
/* Use inverse CDF to sample a new center according to the given prob. */
for(i = 1; i < n; i++) prob[i] = prob[i] + prob[i - 1];
tmp_center = runif(0, prob[n - 1]);
if(tmp_center <= prob[0]){
index_center = 0;
} else{
for(index_center = 1; index_center < n; index_center++){
if(tmp_center > prob[index_center - 1] &&
tmp_center <= prob[index_center]) break;
}
}
/* Based on the new center to estimate the new ltsigma. */
new_Mu = allocate_double_array(1);
new_LTSigma = allocate_double_array(1);
new_Mu[0] = Mu[tmp_G];
new_LTSigma[0] = LTSigma[tmp_G];
for(i = 0; i < p; i++) new_Mu[0][i] = X[index_center][i];
est_ltsigma_mle_given_mu(X, n, p, new_Mu[0], new_LTSigma[0]);
/* Compute prob based on the new center and ltsigma, and according
to the prob to find the neighbors with size min.n + rpois(1, lambda). */
for(i = 0; i < n; i++){
prob[i] = mixllhd(p, 1, X[i], new_pi, new_Mu, new_LTSigma);
}
index_prob = (int *) orderDouble(prob, n); /* This is an increasing order. */
size_nb = min_n + (int) rpois(lambda);
/* Based on the neighbors to estimate Mu and LTSigma. */
new_X = allocate_double_array(size_nb);
tmp_min_n = n - size_nb;
for(i = 0; i < size_nb; i++) new_X[i] = X[index_prob[tmp_min_n + i]];
meandispersion_MLE(new_X, size_nb, p, new_Mu[0], new_LTSigma[0]);
/* Release memory and set new seed state to R. */
PutRNGstate();
free(new_X);
free(new_Mu);
free(new_LTSigma);
FREE_VECTOR(index_prob);
} /* End of cut_sub(). */
int ss_shortems(int n, int p, int nclass, double *pi, double **X, double **Mu,
double **LTSigma, int maxshortiter, double shorteps, int *lab, int labK){
/*initializing as per Beiernacki, Celeaux, Govaert~(2003) */
int i, j, iter, totiter = 0, n_par = p * (p + 1) / 2;
int nonlab_total = 0, lab_index[n];
double *oldpi, **oldMu, **oldLTSigma, oldllh = -Inf, llhval;
double **labMu;
MAKE_VECTOR(oldpi, nclass);
MAKE_MATRIX(oldMu, nclass, p);
MAKE_MATRIX(oldLTSigma, nclass, n_par);
MAKE_MATRIX(labMu, labK, p);
for(i = 0; i < n; i++){
if(lab[i] == -1) lab_index[nonlab_total++] = i;
}
labInitMus(n, p, labK, X, lab, labMu);
do{
for(i = 0; i < labK; i++){
for(j = 0; j < p; j++) oldMu[i][j] = labMu[i][j];
}
iter = maxshortiter - totiter;
/* Modified by Wei-Chen Chen on 2009/03/08.
ss_randomEMinit(X, n, p, nclass, oldpi, oldMu, oldLTSigma,
lab, labK, nonlab_total, lab_index);
ss_mb_randomEMinit(X, n, p, nclass, oldpi, oldMu, oldLTSigma,
lab, labK, nonlab_total, lab_index);
*/
ss_randomEMinit(X, n, p, nclass, oldpi, oldMu, oldLTSigma,
lab, labK, nonlab_total, lab_index);
iter = ss_shortemcluster(n, p, nclass, oldpi, X, oldMu, oldLTSigma, iter,
shorteps, &llhval, lab);
if(llhval >= oldllh){
int i;
oldllh = llhval;
cpy(oldMu, nclass, p, Mu);
cpy(oldLTSigma, nclass, n_par, LTSigma);
for(i = 0; i < nclass; i++) pi[i] = oldpi[i];
}
totiter += iter;
} while(totiter < maxshortiter);
FREE_MATRIX(oldMu);
FREE_MATRIX(oldLTSigma);
FREE_VECTOR(oldpi);
FREE_MATRIX(labMu);
return totiter;
} /* End of ss_shortems(). */
/* This function is called by ss_shortems().
Mu[0, ..., labK-1] should be assigned before calling this function.
*/
void ss_randomEMinit(double **x, int n, int p, int nclass, double *pi,
double **Mu, double **LTSigma,
int *lab, int labK, int nonlab_total, int *lab_index){
int *ordr, i, j, *clas, *nc;
int new_nclass = nclass - labK;
double labMu[labK][p];
for(i = 0; i < labK; i++){
for(j = 0; j < p; j++) labMu[i][j] = Mu[i][j];
}
/* Initial centers for all other unknown clusters. */
MAKE_VECTOR(ordr, new_nclass);
MAKE_VECTOR(clas, n);
MAKE_VECTOR(nc, nclass);
do{
for(i = 0; i < labK; i++){
for(j = 0; j < p; j++) Mu[i][j] = labMu[i][j];
}
i = srswor(nonlab_total, new_nclass, ordr);
for(i = labK; i < nclass; i++){
for(j = 0; j < p; j++) Mu[i][j] = x[lab_index[ordr[i - labK]]][j];
}
for(i = 0; i < n; i++){
if(lab[i] == -1){
clas[i] = assign_closest(x[i], p, nclass, Mu);
} else{
clas[i] = lab[i];
}
}
j = initials(x, n, p, nclass, nc, Mu, LTSigma, clas);
} while(j == 0);
for(i = 0; i < nclass; i++) pi[i] = 1. * nc[i] / n;
FREE_VECTOR(nc);
FREE_VECTOR(clas);
FREE_VECTOR(ordr);
} /* End of ss_randomEMinit(). */
int shortemcluster(int n, int p, int k, double *pi, double **X,
double **Mu, double **LTSigma, int maxiter, double eps, double *llhdval,
int *conv_iter, double *conv_eps){
int iter, i, n_par = p * (p + 1) / 2;
double *backup_pi, **backup_Mu, **backup_LTSigma;
double **gamm, llhd, oldllhd, llh0;
MAKE_VECTOR(backup_pi, k);
MAKE_MATRIX(backup_Mu, k, p);
MAKE_MATRIX(backup_LTSigma, k, n_par);
MAKE_MATRIX(gamm, n, k);
estep_gamma(n, p, k, X, gamm, Mu, LTSigma);
llhd = lnlikelihood_gamma(n, k, gamm, pi);
llh0 = llhd;
iter = 0;
do{
oldllhd = llhd;
norm_gamma(n, k, gamm, pi);
for(i = 0; i < k; i++) backup_pi[i] = pi[i];
cpy(Mu, k, p, backup_Mu);
cpy(LTSigma, k, n_par, backup_LTSigma);
mstep(X, n, p, k, pi, Mu, LTSigma, gamm);
estep_gamma(n, p, k, X, gamm, Mu, LTSigma);
llhd = lnlikelihood_gamma(n, k, gamm, pi);
if(oldllhd > llhd){
for(i = 0; i < k; i++) pi[i] = backup_pi[i];
cpy(backup_Mu, k, p, Mu);
cpy(backup_LTSigma, k, n_par, LTSigma);
llhd = oldllhd;
iter--;
break;
}
iter++;
*conv_eps = fabs((oldllhd - llhd) / (llh0 - llhd));
} while((*conv_eps > eps) && (iter < maxiter));
*llhdval = llhd;
*conv_iter = iter;
FREE_VECTOR(backup_pi);
FREE_MATRIX(backup_Mu);
FREE_MATRIX(backup_LTSigma);
FREE_MATRIX(gamm);
return iter;
}
int eigens(double *A, double *EVec, double *EVal, int n)
{
double *a;
int i,j;
MAKE_VECTOR(a,n*n);
for(i=0;i<n;i++) {
for(j=0;j<i;j++) {
a[i*n+j]=A[i*(i+1)/2+j];
a[j*n+i]=A[i*(i+1)/2+j];
}
a[i*n+i]=A[i*(i+1)/2+i];
}
i=symeigens(a,n,EVal,EVec);
FREE_VECTOR(a);
return i;
}
double determinant(double *LTSigma,int n)
{
double dum;
/* Bugs: pposymatinv() and posymatinv() in "inverse.c" will modify LTSigma.
Make a copy before call pposymatinv().
Modified: Wei-Chen Chen on 2008/12/03.
pposymatinv(n,LTSigma,'U',&dum);
*/
double *a;
int i;
MAKE_VECTOR(a,n*(n+1)/2);
for (i=0;i<n*(n+1)/2;i++) a[i]=LTSigma[i];
pposymatinv(n,a,'U',&dum);
FREE_VECTOR(a);
return dum;
}
int matinv(int sizeA,double **A,double (*determinant))
{
int i, j , *pivot,N=sizeA*sizeA,size=sizeA;
double *AT,*work; /* AT=transpose vectorized matrix (to accomodate
Fortran)
work=workspace vector */
int INFO,ipiv=1;
MAKE_VECTOR(AT,size*size);
MAKE_VECTOR(work,size*size);
MAKE_VECTOR(pivot,size);
for (i=0; i<size; i++) /* to call a Fortran routine from C */
{ /* have to transform the matrix */
for(j=0; j<size; j++) AT[j+size*i]=A[j][i];
}
dgetrf_(&size,&size,AT,&size,pivot,&INFO);
/* LAPACK routine DGETRF computes an LU factorization of a general
m x n matrix A using partial pivoting with row interchanges. The
factorization has the form A = P * L * U where P is a permutation
matrix, L is lower triangular with unit diagonal elements (lower
trapezoidal if m > n), and U is upper triangular (upper trapezoidal
if m < n). Note that because of the permutation, the determinant
needs to be multiplied by -1 for every interchange that has occurred.
Parameters in the order as they appear in the function call:
number of rows of the matrix A, number of columns of the
matrix A, the matrix A, the leading dimension of A, the
array that records pivoting, and the flag for the
result. On exit, A contains the factors of L and U (with the
diagonals of L not stored).*/
if (INFO==0) {
for(i=0; i<size; i++) {
if (i!=(pivot[i]-1)) ipiv*=-1; /* PIVOT assumes indices are from 1
through N*/
}
(*determinant)=(double)ipiv;
for (i=0; i<size; i++) {
(*determinant)*=AT[i+i*size];
}
dgetri_(&size,AT,&size,pivot,work,&N,&INFO);
/* LAPACK routine DGETRI computes the inverse of a matrix A
using the output of DGETRF. This method inverts U and then
computes A^(-1) by solving A^(-1)L = U^(-1) for A^(-1).
parameters in the order as they appear in the function call:
order of the matrix A, the matrix A, the leading dimension of
A, the array that records pivoting, workspace, the
dimension of the workspace array, and the flag for the
result. On exit, A contains the inverted matrix. */
if (INFO!=0) {
/* Marked by Wei-Chen Chen on 2009/06/07.
* printf("Problem in matinv: dgetri error %d\n",INFO);
*/
}
}
else {
/* Marked by Wei-Chen Chen on 2009/06/07.
* printf("Problem in matinv: dgetrf error %d\n",INFO);
*/
}
for (i=0; i<size; i++) /* to call a Fortran routine from C */
{ /* have to transform the matrix */
for(j=0; j<size; j++) {
A[j][i]=AT[j+size*i];
}
}
FREE_VECTOR(AT);
FREE_VECTOR(pivot);
FREE_VECTOR(work);
return 0;
}
void conv_2d_y_asym_odd_opt
(
/******************************************************/
int masksize, /* in : size of convolution mask */
float *mask, /* in : convolution mask */
int nx, /* in : data dimension in x direction */
int ny, /* in : data dimension in y direction */
int bx, /* in : boundary in x direction */
int by, /* in : boundary in y direction */
float **f, /* in : original data */
float **v /* out : processed data */
/******************************************************/
)
/* convolution in y-direction with odd antisymmetric convolution mask */
{
/*************************************************/
int i, j, k,p; /* loop variables */
float sum; /* for summing up */
float *help; /* array for one column with suitable boundary */
int tmp1,tmp2,tmp3,tmp4; /* time saver */
/*************************************************/
/* allocate storage for a sigle row */
ALLOC_VECTOR (1, ny+masksize+masksize, &help);
/* time saver indices */
tmp1=masksize-1;
tmp2=tmp1+ny;
tmp3=tmp2+1;
tmp4=tmp1-(by-1);
/* for each column */
for (i=bx; i<nx+bx; i++)
{
/* copy current column in this column vector */
for (j=by; j<ny+by; j++)
help[j+tmp4] = f[i][j];
/* mirror boundary of the colum vector */
for (p=1; p<=masksize; p++)
{
help[masksize-p] = help[tmp1+p];
help[tmp2+p] = help[tmp3-p];
}
/* convolution step for the column vector*/
for (j=masksize; j<=tmp2; j++)
{
/* calculate convolution */
sum = mask[0] * help[j];
for (p=1; p<=masksize; p++)
sum += mask[p] * (help[j+p] - help[j-p]);
/* write back result for the current colum */
v[i][j-tmp4] = sum;
}
} /* for i */
/* disallocate storage for a single row */
FREE_VECTOR (1, ny+masksize+masksize, help);
return;
}
void conv_2d_x_sym_odd_opt
(
/******************************************************/
int masksize, /* in : size of convolution mask */
float *mask, /* in : convolution mask */
int nx, /* in : data dimension in x direction */
int ny, /* in : data dimension in y direction */
int bx, /* in : boundary in x direction */
int by, /* in : boundary in y direction */
float **f, /* in : original data */
float **v /* out : processed data */
/******************************************************/
)
/* convolution in x-direction with odd symmetric convolution mask */
/* since the values are stored in y-direction in the cache, a loop unrolling */
/* scheme is applied */
{
/*************************************************/
int i, j, k,p; /* loop variables */
float *sum; /* for summing up */
float **help; /* array of rows with suitable boundary size */
int tmp1,tmp2,tmp3,tmp4; /* time saver */
int UNROLL; /* number of rows that are convolved in parallel */
int inner_loop_max; /* number of loops for parrallel computation */
int inner_loop_rest; /* number of remaining rows */
/*************************************************/
/* set number of rows convolved in parallel */
UNROLL=32;
/* allocate storage for that many rows */
ALLOC_MATRIX (1, nx+masksize+masksize,UNROLL, &help);
/* allocate storagy for that many results */
ALLOC_VECTOR (1, UNROLL, &sum);
/* compute number of loops required if the desired number of rows is */
/* convolved in parallel */
inner_loop_max=ny/UNROLL;
/* compute number of remaining rows that have to be convolved thereafter */
inner_loop_rest=ny-(inner_loop_max*UNROLL);
/* time saver indices */
tmp1=masksize-1;
tmp2=tmp1+nx;
tmp3=tmp2+1;
tmp4=tmp1-(bx-1);
/*****************************************************************************/
/* (1/2) As long as the desired number of rows can be convolved in parallel */
/* use loop unrolling scheme that respects cache direction */
/*****************************************************************************/
for (j=0; j<inner_loop_max; j++)
{
/* copy rows in vector array */
for (i=bx; i<nx+bx; i++)
for (k=0; k<UNROLL; k++)
{
help[i+tmp4][k] = f[i][j*UNROLL+k+by];
}
/* mirror boundaries of each of these rows */
for (p=1; p<=masksize; p++)
for (k=0; k<UNROLL; k++)
{
help[masksize-p][k] = help[tmp1+p][k];
help[tmp2 +p][k] = help[tmp3-p][k];
}
/* convolution step for each of these rows */
for (i=masksize; i<=tmp2; i++)
{
/* convolve different rows in parallel */
for (k=0; k<UNROLL; k++)
{
sum[k] = mask[0] * help[i][k];
}
for (p=1; p<=masksize; p++)
for (k=0; k<UNROLL; k++)
{
sum[k] += mask[p] * (help[i+p][k] + help[i-p][k]);
}
/* write back results in parallel */
for (k=0; k<UNROLL; k++)
{
v[i-tmp4][j*UNROLL+k+by] = sum[k];
}
}
} /* for j */
/*****************************************************************************/
/* (2/2) Convolve the remaining number of rows in parallel using the same */
/* loop unrolling scheme */
/*****************************************************************************/
if (inner_loop_rest>0)
{
/* copy rows in vector array */
for (i=bx; i<nx+bx; i++)
for (k=0; k<inner_loop_rest; k++)
{
help[i+tmp4][k] = f[i][j*UNROLL+k+by];
}
/* mirror boundaries for each of these rows */
for (p=1; p<=masksize; p++)
for (k=0; k<inner_loop_rest; k++)
{
help[masksize-p][k] = help[tmp1+p][k];
help[tmp2+p][k] = help[tmp3-p][k];
}
/* convolution step for each of these rows */
for (i=masksize; i<=tmp2; i++)
{
/* convolve different rows in parallel */
for (k=0; k<inner_loop_rest; k++)
{
sum[k] = mask[0] * help[i][k];
}
for (p=1; p<=masksize; p++)
for (k=0; k<inner_loop_rest; k++)
{
sum[k] += mask[p] * (help[i+p][k] + help[i-p][k]);
}
/* write back results in parallel */
for (k=0; k<inner_loop_rest; k++)
{
v[i-tmp4][j*UNROLL+k+by] = sum[k];
}
}
}
/* disallocate storage for the rows */
FREE_MATRIX (1, nx+masksize+masksize,UNROLL, help);
/* disallocate storage for the results */
FREE_VECTOR (1, UNROLL, sum);
return;
}
void AllPerms(int size,int **perms){
int sch, i, j, v, w, finish, flag, ind;
double **pat;
int *cn;
sch = 0;
i = 0;
j = -1;
flag = 0;
finish = 0;
ind = 0;
MAKE_MATRIX(pat, size, size);
for (v=0; v<size; v++){
for (w=0; w<size; w++){
pat[v][w] = 0;
}
}
MAKE_VECTOR(cn, size);
for (v=0; v<size; v++){
cn[v] = 0;
}
while (finish == 0){
if (j != (size-1)){
j = j+1;
} else {
if (flag == 1){
j = 0;
i = i+1;
flag = 0;
}
}
if (pat[i][j] == 0){
for (v=0; v<size; v++){
pat[i][v]=1;
pat[v][j]=1;
}
sch = sch + 1;
cn[sch-1] = j;
flag = 1;
}
if ((sch == size) & (flag == 1)){
for (v=0; v<size; v++){
perms[ind][v] = cn[v];
}
ind++;
flag = 0;
sch = sch - 1;
i = i - 1;
j = cn[sch-1];
sch = sch-1;
for (v=0; v<size; v++){
for (w=0; w<size; w++){
pat[v][w] = 0;
}
}
for (v=0; v<sch; v++){
for (w=0; w<size; w++){
pat[v][w] = 1;
pat[w][cn[v]] = 1;
}
}
}
if ((j == size - 1) & (flag == 0)){
i = i - 1;
sch = sch-1;
if (sch >= 0){
j = cn[sch];
for (v=0; v<size; v++){
for (w=0; w<size; w++){
pat[v][w] = 0;
}
}
if (sch > 0){
for (v=0; v<sch; v++){
for (w=0; w<size; w++){
pat[v][w] = 1;
pat[w][cn[v]] = 1;
}
}
}
}
if (i >= 0){
pat[i][j] = 1;
}
}
if (sch == -1){
finish = 1;
}
}
FREE_MATRIX(pat);
FREE_VECTOR(cn);
}
