void gaussj(float **a, int n, float **b, int m)
{
int *indxc,*indxr,*ipiv;
int i,icol=0,irow=0,j,k,l,ll;
float big,dum,pivinv,temp;
indxc=ivector(1,n);
indxr=ivector(1,n);
ipiv=ivector(1,n);
for (j=1;j<=n;j++) ipiv[j]=0;
for (i=1;i<=n;i++) {
big=0.0;
for (j=1;j<=n;j++)
if (ipiv[j] != 1)
for (k=1;k<=n;k++) {
if (ipiv[k] == 0) {
if (fabs(a[j][k]) >= big) {
big=fabs(a[j][k]);
irow=j;
icol=k;
}
} else if (ipiv[k] > 1) {
printf("gaussj: Singular Matrix-1");
exit(1);
}
}
++(ipiv[icol]);
if (irow != icol) {
for (l=1;l<=n;l++) SWAP(a[irow][l],a[icol][l])
for (l=1;l<=m;l++) SWAP(b[irow][l],b[icol][l])
}
indxr[i]=irow;
indxc[i]=icol;
if (a[icol][icol] == 0.0) {
printf("gaussj: Singular Matrix-2");
exit(1);
}
pivinv=1.0/a[icol][icol];
a[icol][icol]=1.0;
for (l=1;l<=n;l++) a[icol][l] *= pivinv;
for (l=1;l<=m;l++) b[icol][l] *= pivinv;
for (ll=1;ll<=n;ll++)
if (ll != icol) {
dum=a[ll][icol];
a[ll][icol]=0.0;
for (l=1;l<=n;l++) a[ll][l] -= a[icol][l]*dum;
for (l=1;l<=m;l++) b[ll][l] -= b[icol][l]*dum;
}
}
for (l=n;l>=1;l--) {
if (indxr[l] != indxc[l])
for (k=1;k<=n;k++)
SWAP(a[k][indxr[l]],a[k][indxc[l]]);
}
free_ivector(ipiv,1,n);
free_ivector(indxr,1,n);
free_ivector(indxc,1,n);
}
/* "bless_from_tensor" transfers the block Hessian
from the tensor HT into the array HB */
int bless_from_tensor(double **HB,double ***HT,int **CT,int nblx)
{
int *I1,*I2,i,j,p,sb,ii,jj,max,a,b,imx;
max=6*nblx;
I1=ivector(1,max);
I2=ivector(1,max);
/* I1[i]==i iff there is a non-zero element in column i
(removes zeroes that are caused by single-node blocks) */
for(i=1;i<=max;i++){
I1[i]=0;
for(j=i;j<=max;j++)
HB[i][j]=HB[j][i]=0.0;
}
for(ii=1;ii<=nblx;ii++){
for(i=1;i<=6;i++){
for(jj=ii;jj<=nblx;jj++){
sb=CT[ii][jj];
if(sb!=0){
p = jj==ii ? i : 1;
for(j=p;j<=6;j++)
if(HT[sb][i][j]!=0)
I1[6*(jj-1)+j]=6*(jj-1)+j;
}
}
}
}
/* If I1[i]!=0, then I2[i] is a sequential index */
imx=0;
for(i=1;i<=max;i++){
if(I1[i]!=0) imx++;
I2[i]=imx;
}
for(ii=1;ii<=nblx;ii++){
for(i=1;i<=6;i++){
for(jj=ii;jj<=nblx;jj++){
sb=CT[ii][jj];
if(sb!=0){
p = jj==ii ? i : 1;
for(j=p;j<=6;j++)
if(HT[sb][i][j]!=0){
a=I2[6*(ii-1)+i];
b=I2[6*(jj-1)+j];
HB[a][b]=HB[b][a]=HT[sb][i][j];
}
}
}
}
}
free_ivector(I1,1,max);
free_ivector(I2,1,max);
return imx;
}
/* This function frees all memory previously allocated by this program. */
void cleanup()
{
free_matrix(x, 1, rs[nr], 1, nfit);
free_vector(mse, 1, nr);
free_ivector(ipiv, 1, nfit);
free_ivector(indxr, 1, nfit);
free_ivector(indxc, 1, nfit);
free_matrix(covar0, 1, nfit, 1, nfit);
free_matrix(covar, 1, nfit, 1, nfit);
free_vector(beta, 1, nfit);
free_lvector(rs, 1, rslen); /* allocated by rscale() */
free(seq); /* allocated by input() */
}
int
test(
int n, /* Dimensionality */
double **a, /* A[][] input matrix, returns LU decimposition of A */
double *b /* B[] input array, returns solution X[] */
) {
int i, j;
double rip; /* Row interchange parity */
int *pivx;
int rv = 0;
double **sa; /* save input matrix values */
double *sb; /* save input vector values */
pivx = ivector(0, n-1);
sa = dmatrix(0, n-1, 0, n-1);
sb = dvector(0, n-1);
/* Copy input matrix and vector values */
for (i = 0; i < n; i++) {
sb[i] = b[i];
for (j = 0; j < n; j++)
sa[i][j] = a[i][j];
}
if (lu_decomp(a, n, pivx, &rip)) {
free_dvector(sb, 0, n-1);
free_dmatrix(sa, 0, n-1, 0, n-1);
free_ivector(pivx, 0, n-1);
return 1;
}
lu_backsub(a, n, pivx, b);
/* Check that the solution is correct */
for (i = 0; i < n; i++) {
double sum, temp;
sum = 0.0;
for (j = 0; j < n; j++)
sum += sa[i][j] * b[j];
//printf("~~ check %d = %f, against %f\n",i,sum,sb[i]);
temp = fabs(sum - sb[i]);
if (temp > 1e-6)
rv = 2;
}
free_dvector(sb, 0, n-1);
free_dmatrix(sa, 0, n-1, 0, n-1);
free_ivector(pivx, 0, n-1);
return rv;
}
void destroy_parameters(parameters *p) {
if (strcmp(p->datafilename,"dummy"))
free_imatrix(p->genetic_data,1,1);
if (p->npopulations>1)
free_ivector(p->location,1);
p->samplesize=0;
}
void LP_free_space(){
free_matrix(LP_A);
free_matrix(LP_Q);
free_matrix(LP_R);
free_vector(LP_B);
free_vector(LP_C);
free_vector(LP_X);
free_ivector(LP_Basis);
free_ivector(LP_NonBasis);
free_vector(LP_t1);
free_vector(LP_t2);
LP_M=LP_MAX_M=LP_N=0;
LP_A=LP_Q=LP_R=0;
LP_B =LP_C=LP_X=LP_t1=LP_t2=0;
LP_Basis=LP_NonBasis = 0;
}
/* ==========================================================================
get_score
========================================================================== */
float get_score(int w_x[],int w_y[],int nwhisker_points,TMatrix2D I_Conv)
{
float **conv_dat;
float score = 0;
int min_x,max_x;
int *yy, x;
int ncols, nrows;
conv_dat = Mat2D_getDataFloat(I_Conv);
ncols = Mat2D_getnCols(I_Conv);
nrows = Mat2D_getnRows(I_Conv);
min_x = IMAX(w_x[0],0);
max_x = IMIN(w_x[nwhisker_points-1],nrows-1);
get_spline(w_x,w_y,nwhisker_points,min_x, max_x, &yy);
for (x=min_x;x<=max_x;x++)
if (yy[x]>=0 && yy[x]<ncols)
score += conv_dat[x][yy[x]];
free_ivector(yy,min_x,max_x);
return(score);
}
/////////////// MATRIX INVERSE!!
int
inverse(float **ainv, float **a, int n)
{
float d;
int j,i,*indx;
float *colum;
colum=vector(1,n);
indx=ivector(1,n);
// ainv=matrix(1,n,1,n);
if( ludcmp(a,n,indx,&d) ) return 1;
for(j=1;j<=n;j++)
{
for(i=1;i<=n;i++) colum[i]=0.0;
colum[j]=1.0;
lubksb(a,n,indx,colum);
for(i=1;i<=n;i++) ainv[i][j]=colum[i];
}
free_vector(colum,1,n);
free_ivector(indx,1,n);
return 0;
}
/* Invert a double matrix, 1-indexed of size dim
* from Numerical Recipes. Input matrix is destroyed.
*/
int
invert_matrix(double **in, double **out,
int dim)
{
extern void ludcmp(double **a, int n, int *indx, double *d);
extern void ludcmp(double **a, int n, int *indx, double *d);
int *indx,i,j;
double *tvec,det;
tvec = dvector(1,dim);
indx = ivector(1,dim);
ludcmp(in,dim,indx,&det);
for (j=1; j<=dim; j++) {
for (i=1; i<=dim; i++) tvec[i]=0.;
tvec[j] = 1.0;
lubksb(in,dim,indx,tvec);
for (i=1; i<=dim; i++) out[i][j]=tvec[i];
}
free_ivector(indx,1,6);
free_dvector(tvec,1,6);
return(0);
}
double determinant(double *A[],int n)
/*
compute determinant of a n x n matrix A.
Return value: the determinant
*/
{
double d, **tmpA;
int i,j,*indx;
tmpA=dmatrix(n,n);
for (j=0;j<n;j++)
for (i=0;i<n;i++)
tmpA[j][i]=A[j][i];
indx=ivector(n);
ludcmp(tmpA,n,indx,&d);
for (j=0;j<n;j++)
d *= tmpA[j][j];
free_ivector(indx);
free_dmatrix(tmpA,n,n);
return(d);
}
void trnspt(int iorder[], int ncity, int n[])
{
int m1,m2,m3,nn,j,jj,*jorder;
jorder=ivector(1,ncity);
m1=1 + ((n[2]-n[1]+ncity) % ncity);
m2=1 + ((n[5]-n[4]+ncity) % ncity);
m3=1 + ((n[3]-n[6]+ncity) % ncity);
nn=1;
for (j=1;j<=m1;j++) {
jj=1 + ((j+n[1]-2) % ncity);
jorder[nn++]=iorder[jj];
}
for (j=1;j<=m2;j++) {
jj=1+((j+n[4]-2) % ncity);
jorder[nn++]=iorder[jj];
}
for (j=1;j<=m3;j++) {
jj=1 + ((j+n[6]-2) % ncity);
jorder[nn++]=iorder[jj];
}
for (j=1;j<=ncity;j++)
iorder[j]=jorder[j];
free_ivector(jorder,1,ncity);
}
/* "num_clusters" RETURNS THE NUMBER OF CLUSTERS IN THE
NETWORK DESCRIBED BY THE CONNECTIVITY MATRIX CT */
int num_clusters(int **CT,int n)
{
int *ID,dun,nc,fp,i,j,ii;
ID=ivector(1,n);
for(i=1;i<=n;i++) ID[i]=i;
nc=0;
for(ii=1;ii<=n;ii++){
fp=1;
dun=0;
while(dun==0){
dun=1;
for(i=1;i<=n;i++){
if(ID[i]==ii){
if(fp==1){
fp=0;
nc++;
}
for(j=1;j<=n;j++){
if(CT[i][j]==1 && ID[j]!=ii){
dun=0;
ID[j]=ii;
}
}
}
}
}
}
free_ivector(ID,1,n);
return nc;
}
void Matrix_Inverse( double **invMat, double **Mat, int nn)
{
int i, j;
double ger;
int *p= ivector( 1, nn);
double **LU = dmatrix( 1, nn, 1, nn);
for( i=0; i<=nn-1; i++)
for( j=0; j<=nn-1; j++)
LU[i+1][j+1] = Mat[i][j];
double *col = dvector( 1, nn);
ludcmp( LU, nn, p, &ger);
for( j=1; j<=nn; j++) {
for( i=1; i<=nn; i++) col[i] = 0.0;
col[j] = 1.0;
lubksb( LU, nn, p, col );
for( i=1; i<=nn; i++) invMat[i-1][j-1] = (double) col[i];
};
free_dvector( col, 1, nn);
free_ivector( p, 1, nn);
free_dmatrix( LU, 1, nn, 1, nn);
}
int
regress(float *b, float **x, float *y, float *w, int n, int dim)
{
float d;
float **xt, **xx;
int *indx,i,j;
xt = matrix(1,dim,1,n);
transpose(xt,x,n,dim); // X'
for(i=1;i<=dim;i++)
for(j=1;j<=n;j++)
xt[i][j] *= w[j]; // X'*W
xx = matrix(1,dim,1,dim);
multiply(xx,xt,x,dim,n,dim); // X'*W*X
// b = vector(1,dim);
multiply(b,xt,y,dim,n); // X'*W*Y
// Here we have (X'*W*X) b = (X'*W*Y)
// where W is diagonal matrix with diagonal elements w
indx=ivector(1,n);
if( ludcmp(xx,dim,indx,&d) ) return 1;
lubksb(xx,dim,indx,b);
free_matrix(xt,1,dim,1,n);
free_matrix(xx,1,dim,1,dim);
free_ivector(indx,1,n);
return 0;
}
NUMERICS_EXPORT BOOL inverse(double **a, int n)
{
double d;
int i, j;
BOOL ret = FALSE;
double** ai = dmatrix(0, n - 1, 0, n - 1);
double* col = dvector(0, n - 1);
int* indx = ivector(0, n - 1);
if(ludcmp(a, n, indx, &d)){
for(j = 0; j < n; j++){
for(i = 0; i < n; i++) col[i] = 0.0;
col[j] = 1.0;
lubksb(a, n, indx, col);
for(i = 0; i < n; i++) ai[i][j] = col[i];
}
for(i = 0; i < n; i++){
for(j = 0; j < n; j++){
a[i][j] = ai[i][j];
}
}
ret = TRUE;
}
free_dmatrix(ai, 0, n - 1, 0);
free_dvector(col, 0);
free_ivector(indx, 0);
return ret;
}
void Ctest_stream_power_model::indexx(int n, float *arr, int *indx)
{
unsigned long i,indxt,ir=n,itemp,j,k,l=1;
int jstack=0,*istack;
float a;
istack=ivector(1,NSTACK);
for (j=1;j<=n;j++) indx[j]=j;
for (;;) {
if (ir-l < M) {
for (j=l+1;j<=ir;j++) {
indxt=indx[j];
a=arr[indxt];
for (i=j-1;i>=1;i--) {
if (arr[indx[i]] <= a) break;
indx[i+1]=indx[i];
}
indx[i+1]=indxt;
}
if (jstack == 0) break;
ir=istack[jstack--];
l=istack[jstack--];
} else {
k=(l+ir) >> 1;
SWAP(indx[k],indx[l+1]);
if (arr[indx[l+1]] > arr[indx[ir]]) {
SWAP(indx[l+1],indx[ir])
}
if (arr[indx[l]] > arr[indx[ir]]) {
SWAP(indx[l],indx[ir])
}
if (arr[indx[l+1]] > arr[indx[l]]) {
SWAP(indx[l+1],indx[l])
}
i=l+1;
j=ir;
indxt=indx[l];
a=arr[indxt];
for (;;) {
do i++; while (arr[indx[i]] < a);
do j--; while (arr[indx[j]] > a);
if (j < i) break;
SWAP(indx[i],indx[j])
}
indx[l]=indx[j];
indx[j]=indxt;
jstack += 2;
if (ir-i+1 >= j-l) {
istack[jstack]=ir;
istack[jstack-1]=i;
ir=j-1;
} else {
istack[jstack]=j-1;
istack[jstack-1]=l;
l=i;
}
}
}
free_ivector(istack,1,NSTACK);
}
void savgol(float c[], int np, int nl, int nr, int ld, int m)
{
void lubksb(float **a, int n, int *indx, float b[]);
void ludcmp(float **a, int n, int *indx, float *d);
int imj,ipj,j,k,kk,mm,*indx;
float d,fac,sum,**a,*b;
if (np < nl+nr+1 || nl < 0 || nr < 0 || ld > m || nl+nr < m)
nrerror("bad args in savgol");
indx=ivector(1,m+1);
a=matrix(1,m+1,1,m+1);
b=vector(1,m+1);
for (ipj=0;ipj<=(m << 1);ipj++) {
sum=(ipj ? 0.0 : 1.0);
for (k=1;k<=nr;k++) sum += pow((double)k,(double)ipj);
for (k=1;k<=nl;k++) sum += pow((double)-k,(double)ipj);
mm=FMIN(ipj,2*m-ipj);
for (imj = -mm;imj<=mm;imj+=2) a[1+(ipj+imj)/2][1+(ipj-imj)/2]=sum;
}
ludcmp(a,m+1,indx,&d);
for (j=1;j<=m+1;j++) b[j]=0.0;
b[ld+1]=1.0;
lubksb(a,m+1,indx,b);
for (kk=1;kk<=np;kk++) c[kk]=0.0;
for (k = -nl;k<=nr;k++) {
sum=b[1];
fac=1.0;
for (mm=1;mm<=m;mm++) sum += b[mm+1]*(fac *= k);
kk=((np-k) % np)+1;
c[kk]=sum;
}
free_vector(b,1,m+1);
free_matrix(a,1,m+1,1,m+1);
free_ivector(indx,1,m+1);
}
void sort_flt(unsigned long n, float arr[])
{
unsigned long i,ir=n,j,k,l=1;
int jstack=0,*istack;
float a,temp;
printf("sorting.\n");
istack=ivector(1,NSTACK);
for (;;) {
if (ir-l < M) {
for (j=l+1;j<=ir;j++) {
a=arr[j];
for (i=j-1;i>=l;i--) {
if (arr[i] <= a) break;
arr[i+1]=arr[i];
}
arr[i+1]=a;
}
if (jstack == 0) break;
ir=istack[jstack--];
l=istack[jstack--];
} else {
k=(l+ir) >> 1;
SWAP(arr[k],arr[l+1])
if (arr[l] > arr[ir]) {
SWAP(arr[l],arr[ir])
}
if (arr[l+1] > arr[ir]) {
SWAP(arr[l+1],arr[ir])
}
if (arr[l] > arr[l+1]) {
SWAP(arr[l],arr[l+1])
}
i=l+1;
j=ir;
a=arr[l+1];
for (;;) {
do i++; while (arr[i] < a);
do j--; while (arr[j] > a);
if (j < i) break;
SWAP(arr[i],arr[j]);
}
arr[l+1]=arr[j];
arr[j]=a;
jstack += 2;
if (jstack > NSTACK) nrerror("NSTACK too small in sort.");
if (ir-i+1 >= j-l) {
istack[jstack]=ir;
istack[jstack-1]=i;
ir=j-1;
} else {
istack[jstack]=j-1;
istack[jstack-1]=l;
l=i;
}
}
}
free_ivector(istack,1,NSTACK);
}
int main(void)
{
long idum=(-911);
int i,j,mfit=MA,*ia;
float chisq,*beta,*x,*y,*sig,**covar,**alpha;
static float a[MA+1]=
{0.0,5.0,2.0,3.0,2.0,5.0,3.0};
static float gues[MA+1]=
{0.0,4.9,2.1,2.9,2.1,4.9,3.1};
ia=ivector(1,MA);
beta=vector(1,MA);
x=vector(1,NPT);
y=vector(1,NPT);
sig=vector(1,NPT);
covar=matrix(1,MA,1,MA);
alpha=matrix(1,MA,1,MA);
/* First try sum of two gaussians */
for (i=1;i<=NPT;i++) {
x[i]=0.1*i;
y[i]=0.0;
y[i] += a[1]*exp(-SQR((x[i]-a[2])/a[3]));
y[i] += a[4]*exp(-SQR((x[i]-a[5])/a[6]));
y[i] *= (1.0+SPREAD*gasdev(&idum));
sig[i]=SPREAD*y[i];
}
for (i=1;i<=mfit;i++) ia[i]=1;
for (i=1;i<=mfit;i++) a[i]=gues[i];
mrqcof(x,y,sig,NPT,a,ia,MA,alpha,beta,&chisq,fgauss);
printf("\nmatrix alpha\n");
for (i=1;i<=MA;i++) {
for (j=1;j<=MA;j++) printf("%12.4f",alpha[i][j]);
printf("\n");
}
printf("vector beta\n");
for (i=1;i<=MA;i++) printf("%12.4f",beta[i]);
printf("\nchi-squared: %12.4f\n\n",chisq);
/* Next fix one line and improve the other */
mfit=3;
for (i=1;i<=mfit;i++) ia[i]=0;
for (i=1;i<=MA;i++) a[i]=gues[i];
mrqcof(x,y,sig,NPT,a,ia,MA,alpha,beta,&chisq,fgauss);
printf("matrix alpha\n");
for (i=1;i<=mfit;i++) {
for (j=1;j<=mfit;j++) printf("%12.4f",alpha[i][j]);
printf("\n");
}
printf("vector beta\n");
for (i=1;i<=mfit;i++) printf("%12.4f",beta[i]);
printf("\nchi-squared: %12.4f\n\n",chisq);
free_matrix(alpha,1,MA,1,MA);
free_matrix(covar,1,MA,1,MA);
free_vector(sig,1,NPT);
free_vector(y,1,NPT);
free_vector(x,1,NPT);
free_vector(beta,1,MA);
free_ivector(ia,1,MA);
return 0;
}
void free_results( RESULTS *strct )
/* free a RESULTS struct allocated with alloc_results() */
{
free_ivector(strct->res_serr);
free_ivector(strct->res_nskypix);
free_dvector(strct->res_skyperpix);
free_dvector(strct->res_skystddev);
free_imatrix(strct->res_npix);
free_dmatrix(strct->res_totalflux);
free_dmatrix(strct->res_error);
free_dvector(strct->res_radii);
free_dmatrix(strct->res_apstddev);
free_dmatrix(strct->res_fluxsec);
free_dmatrix(strct->res_mag);
free_dmatrix(strct->res_merr);
return;
}
int main(void)
{
int i,icase,j,*izrov,*iposv;
static float c[MP][NP]=
{0.0,1.0,1.0,3.0,-0.5,
740.0,-1.0,0.0,-2.0,0.0,
0.0,0.0,-2.0,0.0,7.0,
0.5,0.0,-1.0,1.0,-2.0,
9.0,-1.0,-1.0,-1.0,-1.0,
0.0,0.0,0.0,0.0,0.0};
float **a;
static char *txt[NM1M2+1]=
{" ","x1","x2","x3","x4","y1","y2","y3"};
izrov=ivector(1,N);
iposv=ivector(1,M);
a=convert_matrix(&c[0][0],1,MP,1,NP);
simplx(a,M,N,M1,M2,M3,&icase,izrov,iposv);
if (icase == 1)
printf("\nunbounded objective function\n");
else if (icase == -1)
printf("\nno solutions satisfy constraints given\n");
else {
printf("\n%11s"," ");
for (i=1;i<=N;i++)
if (izrov[i] <= NM1M2) printf("%10s",txt[izrov[i]]);
printf("\n");
for (i=1;i<=M+1;i++) {
if (i == 1 || iposv[i-1] <= NM1M2) {
if (i > 1)
printf("%s",txt[iposv[i-1]]);
else
printf(" ");
printf("%10.2f",a[i][1]);
for (j=2;j<=N+1;j++)
if (izrov[j-1] <= NM1M2)
printf("%10.2f",a[i][j]);
printf("\n");
}
}
}
free_convert_matrix(a,1,MP,1,NP);
free_ivector(iposv,1,M);
free_ivector(izrov,1,N);
return 0;
}
int main(void)
{
long idum=(-911);
int i,j,*ia;
float chisq,*a,*x,*y,*sig,**covar;
ia=ivector(1,NTERM);
a=vector(1,NTERM);
x=vector(1,NPT);
y=vector(1,NPT);
sig=vector(1,NPT);
covar=matrix(1,NTERM,1,NTERM);
for (i=1;i<=NPT;i++) {
x[i]=0.1*i;
funcs(x[i],a,NTERM);
y[i]=0.0;
for (j=1;j<=NTERM;j++) y[i] += j*a[j];
y[i] += SPREAD*gasdev(&idum);
sig[i]=SPREAD;
}
for (i=1;i<=NTERM;i++) ia[i]=1;
lfit(x,y,sig,NPT,a,ia,NTERM,covar,&chisq,funcs);
printf("\n%11s %21s\n","parameter","uncertainty");
for (i=1;i<=NTERM;i++)
printf(" a[%1d] = %8.6f %12.6f\n",
i,a[i],sqrt(covar[i][i]));
printf("chi-squared = %12f\n",chisq);
printf("full covariance matrix\n");
for (i=1;i<=NTERM;i++) {
for (j=1;j<=NTERM;j++) printf("%12f",covar[i][j]);
printf("\n");
}
printf("\npress RETURN to continue...\n");
(void) getchar();
/* Now check results of restricting fit parameters */
for (i=2;i<=NTERM;i+=2) ia[i]=0;
lfit(x,y,sig,NPT,a,ia,NTERM,covar,&chisq,funcs);
printf("\n%11s %21s\n","parameter","uncertainty");
for (i=1;i<=NTERM;i++)
printf(" a[%1d] = %8.6f %12.6f\n",
i,a[i],sqrt(covar[i][i]));
printf("chi-squared = %12f\n",chisq);
printf("full covariance matrix\n");
for (i=1;i<=NTERM;i++) {
for (j=1;j<=NTERM;j++) printf("%12f",covar[i][j]);
printf("\n");
}
printf("\n");
free_matrix(covar,1,NTERM,1,NTERM);
free_vector(sig,1,NPT);
free_vector(y,1,NPT);
free_vector(x,1,NPT);
free_vector(a,1,NTERM);
free_ivector(ia,1,NTERM);
return 0;
}
int main (int argc, char **argv)
{
int t, T;
HMM hmm;
int *O; /* observation sequence O[1..T] */
double **alpha;
double *scale;
double proba, logproba;
FILE *fp;
if (argc != 3) {
printf("Usage error \n");
printf("Usage: testfor <model.hmm> <obs.seq> \n");
exit (1);
}
fp = fopen(argv[1], "r");
if (fp == NULL) {
fprintf(stderr, "Error: File %s not found\n", argv[1]);
exit (1);
}
ReadHMM(fp, &hmm);
fclose(fp);
fp = fopen(argv[2], "r");
if (fp == NULL) {
fprintf(stderr, "Error: File %s not found\n", argv[2]);
exit (1);
}
ReadSequence(fp, &T, &O);
fclose(fp);
alpha = dmatrix(1, T, 1, hmm.N);
scale = dvector(1, T);
printf("------------------------------------\n");
printf("Forward without scaling \n");
Forward(&hmm, T, O, alpha, &proba);
fprintf(stdout, "log prob(O| model) = %E\n", log(proba));
printf("------------------------------------\n");
printf("Forward with scaling \n");
ForwardWithScale(&hmm, T, O, alpha, scale, &logproba);
fprintf(stdout, "log prob(O| model) = %E\n", logproba);
printf("------------------------------------\n");
printf("The two log probabilites should identical \n");
printf("(within numerical precision). When observation\n");
printf("sequence is very large, use scaling. \n");
free_ivector(O, 1, T);
free_dmatrix(alpha, 1, T, 1, hmm.N);
free_dvector(scale, 1, T);
FreeHMM(&hmm);
}
/* ==========================================================================
get_I_Conv
Convulve I_Conv with oriented filter according to the whisker angle
========================================================================== */
void get_I_Conv(int *w0_x,int *w0_y,int nwhisker_points,
TMatrix2D image, int min_y, int max_y,
TMatrix2D filters[], TMatrix2D *I_Conv_p)
{
int i,x_val;
int *yy;
int *angle_vec;
int spline_len;
int filt_size;
int min_x, max_x;
int nrows;
nrows = Mat2D_getnRows(image);
/* calculate spline of w0 */
min_x = IMAX(w0_x[0],0);
max_x = IMIN(w0_x[nwhisker_points-1],nrows-1);
filt_size = (Mat2D_getnRows(filters[0])-1)/2;
get_spline(w0_x,w0_y,nwhisker_points,min_x-COL_WIDTH, max_x+COL_WIDTH, &yy);
get_angle_vec(yy,min_x,max_x,COL_WIDTH,&angle_vec);
/* for (i=0;i<nwhisker_points;i++) */
/* mexPrintf("w0[%d]: %d %d\n",i,w0_x[i],w0_y[i]); */
/* mexPrintf("\n"); */
/* for (x_val=min_x;x_val<=max_x;x_val++) */
/* mexPrintf("spline[%d]: %d angle = %d\n",x_val,yy[x_val],angle_vec[x_val]); */
/* mexPrintf("\n"); */
/* convolve each column of I_Conv with correct filter (according to angle) */
convolve_image_by_angle(image,filters,filt_size,angle_vec,
min_x,max_x,min_y,max_y,I_Conv_p);
free_ivector(yy,min_x-COL_WIDTH, max_x+COL_WIDTH);
free_ivector(angle_vec,min_x,max_x);
/* Mat2D_display(*I_Conv_p); */
}
/* "copy_prj_ofst" copies the projection matrix to the Python object,
offsetting the column elements if there are blocks with fewer than
six degrees of freedom.
PP[i].X = proj[6*nblx*(PP[i].IDX[1]-1)+PP[i].IDX[2]-1
*/
void copy_prj_ofst(dSparse_Matrix *PP,double *proj,int elm,int bdim)
{
int *I1,*I2,max=0,i,j=0;
for(i=1;i<=elm;i++)
if(PP->IDX[i][2]>max)
max=PP->IDX[i][2];
I1=ivector(1,max);
I2=ivector(1,max);
for(i=1;i<=max;i++) I1[i]=0;
for(i=1;i<=elm;i++)
I1[PP->IDX[i][2]]=PP->IDX[i][2];
for(i=1;i<=max;i++){
if(I1[i]!=0) j++;
I2[i]=j;
}
for(i=1;i<=elm;i++)
if(PP->X[i]!=0.0)
proj[bdim*(PP->IDX[i][1]-1) + I2[PP->IDX[i][2]] - 1] = PP->X[i];
free_ivector(I1,1,max);
free_ivector(I2,1,max);
}
int main(int argc, char** argv) {
char* filename;
FILE *fp;
int m, n, i, info;
double **a;
double det;
int *ipiv;
if (argc < 2) {
fprintf(stderr, "Usage: %s inputfile\n", argv[0]);
exit(1);
}
filename = argv[1];
/* read matrix A from a file */
fp = fopen(filename, "r");
if (fp == NULL) {
fprintf(stderr, "Error: file can not open\n");
exit(1);
}
read_dmatrix(fp, &m, &n, &a);
if (m != n) {
fprintf(stderr, "Error: non-square matrix\n");
exit(1);
}
printf("Matrix A:\n");
fprint_dmatrix(stdout, n, n, a);
/* perform LU decomposition */
ipiv = alloc_ivector(n);
dgetrf_(&n, &n, mat_ptr(a), &n, vec_ptr(ipiv), &info);
if (info != 0) {
fprintf(stderr, "Error: LAPACK::dgetrf failed\n");
exit(1);
}
printf("Result of LU decomposition:\n");
fprint_dmatrix(stdout, n, n, a);
printf("Pivot for LU decomposition:\n");
fprint_ivector(stdout, n, ipiv);
/* calculate determinant */
det = 1.0;
for (i = 0; i < n; ++i) {
det *= mat_elem(a, i, i);
if (ipiv[i] != i+1) det = -det;
}
printf("Determinant of A = %lf\n", det);
free_dmatrix(a);
free_ivector(ipiv);
}
int sa_lu_invert(double **a, int n) {
int i, j;
double rip;
int *pivx, PIVX[10];
double **y;
if (n <= 10)
pivx = PIVX;
else
pivx = ivector(0, n-1);
if (sa_lu_decomp(a, n, pivx, &rip)) {
if (pivx != PIVX)
free_ivector(pivx, 0, n-1);
return 1;
}
y = dmatrix(0, n-1, 0, n-1);
for (i = 0; i < n; i++) {
for (j = 0; j < n; j++) {
y[i][j] = a[i][j];
}
}
for (i = 0; i < n; i++) {
for (j = 0; j < n; j++)
a[i][j] = 0.0;
a[i][i] = 1.0;
sa_lu_backsub(y, n, pivx, a[i]);
}
free_dmatrix(y, 0, n-1, 0, n-1);
if (pivx != PIVX)
free_ivector(pivx, 0, n-1);
return 0;
}
void pade(double cof[], int n, float *resid)
{
void lubksb(float **a, int n, int *indx, float b[]);
void ludcmp(float **a, int n, int *indx, float *d);
void mprove(float **a, float **alud, int n, int indx[], float b[],
float x[]);
int j,k,*indx;
float d,rr,rrold,sum,**q,**qlu,*x,*y,*z;
indx=ivector(1,n);
q=matrix(1,n,1,n);
qlu=matrix(1,n,1,n);
x=vector(1,n);
y=vector(1,n);
z=vector(1,n);
for (j=1;j<=n;j++) {
y[j]=x[j]=cof[n+j];
for (k=1;k<=n;k++) {
q[j][k]=cof[j-k+n];
qlu[j][k]=q[j][k];
}
}
ludcmp(qlu,n,indx,&d);
lubksb(qlu,n,indx,x);
rr=BIG;
do {
rrold=rr;
for (j=1;j<=n;j++) z[j]=x[j];
mprove(q,qlu,n,indx,y,x);
for (rr=0.0,j=1;j<=n;j++)
rr += SQR(z[j]-x[j]);
} while (rr < rrold);
*resid=sqrt(rrold);
for (k=1;k<=n;k++) {
for (sum=cof[k],j=1;j<=k;j++) sum -= z[j]*cof[k-j];
y[k]=sum;
}
for (j=1;j<=n;j++) {
cof[j]=y[j];
cof[j+n] = -z[j];
}
free_vector(z,1,n);
free_vector(y,1,n);
free_vector(x,1,n);
free_matrix(qlu,1,n,1,n);
free_matrix(q,1,n,1,n);
free_ivector(indx,1,n);
}
void mx_inv_det(double **matrix, double **inv_matrix, double *det,
int dimension)
{
double *col, **source;
int i, j, *indx;
/* printf("\nInside mx_inv_det(1).\n"); */
/* printf("dimension = %d.\n", dimension); */
col = dvector(1, dimension);
indx = ivector(1, dimension);
/* printf("\nInside mx_inv_det(2).\n"); */
source = dmatrix(1, dimension, 1, dimension);
/* printf("\nInside mx_inv_det(3).\n"); */
for (i=1; i<=dimension; i++)
for (j=1; j<=dimension; j++)
source[i][j] = matrix[i][j];
/* source = matrix; */
/* for (i=1; i<=dimension; i++)
for (j=1; j<=dimension; j++)
printf("source[%d][%d] = %f.\n", i, j, source[i][j]); */
ludcmp(source, dimension, indx, det);
for(j=1; j<=dimension; j++) {
for(i=1; i<=dimension; i++) col[i]=0.0;
col[j]=1.0;
lubksb(source, dimension, indx, col);
for(i=1; i<=dimension; i++) inv_matrix[i][j]=col[i];
}
for(j=1; j<=dimension; j++)
(*det) *= source[j][j];
free_dvector(col, 1, dimension);
free_ivector(indx, 1, dimension);
free_dmatrix(source, 1, dimension, 1, dimension);
/* printf("Leaving mx_inv_det\n"); */
}
NUMERICS_EXPORT BOOL linsolve(double **m, double *b, int n, int method)
{
int* indx;
double d;
BOOL ret = FALSE;
if(method | LINSOLVE_LU){
indx = ivector(0, n - 1);
ret = ludcmp(m, n, indx, &d);
if(ret){
lubksb(m, n, indx, b);
}
free_ivector(indx, 0);
}
return ret;
}
