Grid::Grid(Grid *Orig){
int i;
domainname = strdup(Orig->domainname);
domainfile = Orig->domainfile;
totverts = Orig->totverts;
xcoords = dvector(0, totverts-1);
ycoords = dvector(0, totverts-1);
zcoords = dvector(0, totverts-1);
dcopy(totverts, Orig->xcoords, 1, xcoords, 1);
dcopy(totverts, Orig->ycoords, 1, ycoords, 1);
dcopy(totverts, Orig->zcoords, 1, zcoords, 1);
nel = Orig->nel;
nverts = ivector(0, nel-1);
icopy(nel, Orig->nverts, 1, nverts, 1);
vertids = imatrix(0, nel-1, 0, Max_Nverts-1);
icopy(nel*Max_Nverts, Orig->vertids[0], 1, vertids[0], 1);
elmtids = ivector(0, nel-1);
icopy(nel, Orig->elmtids, 1, elmtids, 1);
vertexmap = imatrix(0, nel-1, 0, Max_Nverts-1);
icopy(nel*Max_Nverts, Orig->vertexmap[0], 1, vertexmap[0], 1);
}
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);
}
void gaussj(complex_dble **a, int n,complex_dble **b,int m)
{
int *indxc,*indxr,*ipiv;
int i,icol,irow,j,k,l,ll;
double big;
complex_dble dum,pivinv,c;
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 (cabs(a[j][k]) >= big) {
big=cabs(a[j][k]);
irow=j;
icol=k;
}
} else if (ipiv[k] > 1) nrerror("GAUSSJ: Singular Matrix-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].re == 0.0)&&(a[icol][icol].im == 0.0))
nrerror("GAUSSJ: Singular Matrix-2");
pivinv.re=cinv(a[icol][icol]);
a[icol][icol].re=1.0;
a[icol][icol].im=0.0;
for (l=1;l<=n;l++) a[icol][l] = cmul(a[icol][l],pivinv);
for (l=1;l<=m;l++) b[icol][l] = cmul(b[icol][l],pivinv);
for (ll=1;ll<=n;ll++)
if (ll != icol) {
dum.re=a[ll][icol].re;
dum.im=a[ll][icol].im;
a[ll][icol].re=0.0;
a[ll][icol].im=0.0;
for (l=1;l<=n;l++) {
c.re=a[ll][icol].re;
c.im=a[ll][icol].im;
a[ll][l].re = c.re-cmul(c,dum);
a[ll][l].im = c.im-cmul(c,dum);
}
for (l=1;l<=m;l++)
c.re=b[ll][icol].re;
c.im=b[ll][icol].im;
b[ll][l].re = c.re-cmul(c,dum);
b[ll][l].im = c.im-cmul(c,dum);
}
}
}
static Fctcon *FacetConnect(Bsystem *B, Element *E, char trip){
register int i,k;
int nel = B->nel,*pts, n;
Fctcon *connect;
Element *F;
if(trip == 'v'){
const int nvs = B->nv_solve;
pts = ivector(0,Max_Nverts-1);
connect = (Fctcon *)calloc(nvs,sizeof(Fctcon));
for(F=E;F;F=F->next){
/* find all facets that are unknowns */
n = 0;
for(i = 0; i < F->Nverts; ++i)
if(F->vert[i].gid < nvs)
pts[n++] = F->vert[i].gid;
addfct(connect,pts,n);
}
}
else{
int nvs = B->nv_solve, nes = B->ne_solve, nfs = B->nf_solve;
int nsols = nvs + nes;
if(E->dim() == 3)
nsols += nfs;
pts = ivector(0,Max_Nverts + Max_Nedges + Max_Nfaces - 1);
connect = (Fctcon *)calloc(nsols,sizeof(Fctcon));
for(F=E;F;F=F->next){
/* find all facets that are unknowns */
n = 0;
for(i = 0; i < F->Nverts; ++i)
if(F->vert[i].gid < nvs)
pts[n++] = F->vert[i].gid;
for(i = 0; i < F->Nedges; ++i)
if(F->edge[i].gid < nes)
pts[n++] = F->edge[i].gid + nvs;
if(F->dim() == 3)
for(i = 0; i < F->Nfaces; ++i)
if(F->face[i].gid < nfs)
pts[n++] = F->face[i].gid + nvs + nes;
addfct(connect,pts,n);
}
}
free(pts);
return connect;
}
/* "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;
}
void Grid::FixPrismOrientation(){
int i, j, k, tmp;
int *lid = ivector(0, 6-1);
int *gid = ivector(0, 6-1);
for(i=0;i<nel;++i){
if(nverts[i] == 6){
icopy(6, vertids[i], 1, gid, 1);
for(j=0;j<6;++j)
lid[j] = j;
// order the local ids (maximum global id first)
for(k=1;k<6;++k){
if(gid[0]<gid[k]){
tmp = gid[k];
gid[k] = gid[0];
gid[0] = tmp;
tmp = lid[k];
lid[k] = lid[0];
lid[0] = tmp;
}
}
// we now know that the local id of the maximum global id is in lid[0]
if(lid[0] == 4 || lid[0] == 5){
// nothing to do
}
else if(lid[0] == 1 || lid[0] == 2){
// must rotate around clockwise
vertexmap[i][0] = 4;
vertexmap[i][1] = 0;
vertexmap[i][2] = 3;
vertexmap[i][3] = 5;
vertexmap[i][4] = 1;
vertexmap[i][5] = 2;
}
else if(lid[0] == 0 || lid[0] == 3){
// must rotate around clockwise
vertexmap[i][0] = 1;
vertexmap[i][1] = 4;
vertexmap[i][2] = 5;
vertexmap[i][3] = 2;
vertexmap[i][4] = 0;
vertexmap[i][5] = 3;
}
}
}
free(lid);
free(gid);
}
void blacs_pdgetri_nektar(int *BLACS_PARAMS, int *DESCA, int *ipvt, double **inva_LOC){
int row_start = 1, col_start = 1;
int lwork,liwork,info = 0;
double *work;
int *iwork;
int M;
M = BLACS_PARAMS[7] + ((row_start-1) % BLACS_PARAMS[10]);
lwork = BLACS_PARAMS[9]*numroc_( M, BLACS_PARAMS[10], BLACS_PARAMS[5], row_start, BLACS_PARAMS[3]);
liwork = BLACS_PARAMS[7];
work = dvector(0,lwork-1);
iwork = ivector(0,liwork-1);
int i = -1, j = -1;
pdgetri_(BLACS_PARAMS[7],*inva_LOC,
row_start,col_start,DESCA,ipvt,
work,i,
iwork,j,
info);
if (info != 0)
fprintf(stderr,"blacs_pdgetri_nektar: ERROR - info = %d \n",info);
if ( ((int) work[0]) > lwork){
lwork = (int) work[0];
free(work);
work = dvector(0,lwork);
}
if ( iwork[0] > lwork){
liwork = iwork[0];
free(iwork);
iwork = ivector(0,liwork);
}
pdgetri_(BLACS_PARAMS[7],*inva_LOC,
row_start,col_start,DESCA,ipvt,
work,lwork,
iwork,liwork,
info);
if (info != 0)
fprintf(stderr,"blacs_pdgetri_nektar: ERROR - info = %d \n",info);
free(work);
free(iwork);
}
void Project_Recur(int oldid, int n, double *a, int *bmap, int lev,
Bsystem *Bsys){
register int i,j;
int alen,clen,ptchid,cstart,*map,cnt;
int *linka, *linkc;
double *A,*B,*C;
Recur *rdata = Bsys->rslv->rdata+lev;
if(!n) return;
linka = ivector(0,n-1);
linkc = ivector(0,n-1);
ifill(n,-1,linka,1);
ifill(n,-1,linkc,1);
cstart = rdata->cstart;
ptchid = rdata->pmap[oldid];
A = Bsys->rslv->A.a[ptchid];
B = rdata->binvc[ptchid];
C = rdata->invc [ptchid];
map = rdata->map[ptchid];
alen = rdata->patchlen_a[ptchid];
clen = rdata->patchlen_c[ptchid];
cnt = cstart + isum(ptchid,rdata->patchlen_c,1);
/* set up local mappings for matrix a to next system */
for(i = 0; i < n; ++i){
if(bmap[i] < Bsys->nsolve){
if(bmap[i] < cstart){
for(j = 0; j < alen; ++j)
if(bmap[i] == map[j]) linka[i] = j;
}
else
linkc[i] = bmap[i] - cnt;
}
}
/* project a to new local storage */
for(i = 0; i < n; ++i)
for(j = 0; j < n; ++j)
if((linka[i]+1)&&(linka[j]+1))
A[alen*linka[i] + linka[j]] += a[i*n + j];
else if((linka[i]+1)&&(linkc[j]+1))
B[clen*linka[i] + linkc[j]] += a[i*n + j];
else if((linkc[i]+1)&&(linkc[j]+1))
C[clen*linkc[i] + linkc[j]] += a[i*n + j];
free(linka); free(linkc);
}
void AllocPlait(PlaitWS *pws){
fprintf(stderr, "memory allocation...\n");
ws = pws;
ws->maxc = (int) (log(ws->lmax) + 20);
ws->maxseg = (int) ws->lmax*0.1;
// alloc Viterbi
AllocViterbi(&ws->vit, ws->maxseg, ws->lmax, MAXK);
AllocViterbi(&ws->vit2, ws->maxseg, ws->lmax, MAXK);
ws->q = (int*) ivector(0, ws->lmax);
AllocCPS(&ws->cps, MAXK, ws->lmax);
// alloc Baum
int n = ws->maxseg;
if(n > MAXBAUMN) n = MAXBAUMN;
ws->x_tmp = (Input*)malloc(sizeof(Input)*n);
AllocBaum(&ws->baum, n, ws->lmax, MAXK, ws->d);
int i;
// alloc segbox
ws->s = (SegBox*)malloc(sizeof(SegBox)*ws->maxc);
for(i=0;i<ws->maxc;i++)
_allocSegBox(&ws->s[i], ws->maxseg);
/// candidate stack C
ws->C.s =(SegBox**)malloc(sizeof(SegBox*)*ws->maxc);
ws->C.idx = 0;
ws->Opt.s =(SegBox**)malloc(sizeof(SegBox*)*ws->maxc);
ws->Opt.idx = 0;
/// segment set storage
ws->S.s =(SegBox**)malloc(sizeof(SegBox*)*ws->maxc);
ws->S.idx = 0;
for(i=0;i<ws->maxc;i++)
Push(&ws->s[i], &ws->S);
/// for uniform sampling
_allocSegBox(&ws->U, NSAMPLE);
}
void
regress(float *b, float **x, float *y, int n, int dim)
{
float d;
float **xt, **xx;
int *indx;
xt = matrix(1,dim,1,n);
transpose(xt,x,n,dim); // X'
xx = matrix(1,dim,1,dim);
multiply(xx,xt,x,dim,n,dim); // X'*X
// b = vector(1,dim);
multiply(b,xt,y,dim,n); // X'*Y
// From NR:
// "To summarize, this is the preferred way to solve the linear set of equations A . x = b:
// float **a,*b,d;
// int n,*indx;
// ...
// ludcmp(a,n,indx,&d);
// lubksb(a,n,indx,b);
//
// The answer x will be given back in b. Your original matrix A will have been destroyed."
//
// In our case, we have (X'X) b = (X'Y)
indx=ivector(1,n);
ludcmp(xx,dim,indx,&d);
lubksb(xx,dim,indx,b);
}
void bandwidthopt(Element *E, Bsystem *Bsys, char trip){
int nsols, *newmap;
Fctcon *ptcon;
if(trip == 'v') /* just do vertex space */
nsols = Bsys->nv_solve;
else {
if(E->dim() == 2)
nsols = Bsys->nv_solve + Bsys->ne_solve;
else
nsols = Bsys->nv_solve + Bsys->ne_solve + Bsys->nf_solve;
}
if(nsols < 2) return;
newmap = ivector(0,nsols-1);
/* Initially set up "point" to "point" connections (a point/facet is
a vertex, edge or face) */
ptcon = FacetConnect(Bsys,E,trip);
/* Given a list of "nsols" points whose interconnectivity is given in
ptcon this routine returns a new mapping in newmap which contains
the order in which the unknowns should be stored */
MinOrdering(nsols,ptcon,newmap);
/* Sort out the numbering according to new ordering in newmap */
RenumberElmts(E, Bsys, newmap, trip);
free_Fctcon(ptcon,nsols);
free(newmap);
}
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);
}
int *Runpack_ivectors(int *va, unsigned int n, int *a, unsigned int sample_size){
if(!a) a=ivector(n);
unsigned int i;
for(i=0;i<n;i++)
a[i]=va[sample_size*i];
return a;
}
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;
}
/* 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);
}
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);
}
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);
}
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;
}
/* "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);
}
void Newton_Solver( double * x1, double ** A, double * b, int vn)
{
int i, j;
double ger;
int *p = ivector( 1, vn);
double **LU = dmatrix( 1, vn, 1, vn);
for( i=0; i<=vn-1; i++)
for( j=0; j<=vn-1; j++)
LU[i+1][j+1] = A[i][j];
double *X = dvector( 1, vn);
for( i=0; i<=vn-1; i++)
X[i+1] = b[i];
ludcmp( LU, vn, p, &ger);
lubksb( LU, vn, p, X );
for( i=0; i<=vn-1; i++)
x1[i] = X[i+1];
}
/////////////// 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;
}
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;
}
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;
}
static Field *sortHeaders(Field *fld, int nfld){
register int i;
Field *fout;
int cnt,*size,*emap,*nfacet;
fout = (Field *)calloc(1,sizeof(Field));
memcpy(fout,fld,sizeof(Field));
cnt = 0;
for(i = 0; i < nfld; ++i)
if((fld+i != ((Field* ) NULL)))
// if(fld[i])
cnt += fld[i].nel;
fout->nel = cnt;
emap = fout->emap = ivector(0,fout->nel-1);
nfacet = fout->nfacet = ivector(0,fout->nel-1);
for(i = 0,cnt = 0; i < nfld; ++i){
if((fld+i != ((Field* ) NULL))){
icopy(fld[i].nel,fld[i].nfacet,1,nfacet,1);
icopy(fld[i].nel,fld[i].emap, 1,emap,1);
emap += fld[i].nel;
nfacet += fld[i].nel;
cnt += isum(fld[i].nel,fld[i].nfacet,1);
}
}
size = fout->size = ivector(0,cnt-1);
for(i = 0,cnt = 0; i < nfld; ++i){
if((fld+i != ((Field* ) NULL))){
cnt = isum(fld[i].nel,fld[i].nfacet,1);
icopy(cnt,fld[i].size,1,size,1);
size += cnt;
}
}
for(i = 0,cnt = 0; i < nfld; ++i){
if((fld+i != ((Field* ) NULL)))
cnt += fld[i].nel;
}
return fout;
}
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;
}
/**
Overload the allocate function to use a data_matrix object.
\author Steve Martell
*/
void param_init_bounded_number_vector::allocate(const data_matrix &m,
const char *s)
{
int min1 = m.rowmin();
int max1 = m.rowmax();
double_index_type bmin = column(m,1);
double_index_type bmax = column(m,2);
index_type phz1 = ivector(column(m,3));
allocate(min1,max1,bmin,bmax,phz1,s);
}
/*** NOTE - THIS DOES NOT AVOID ROUNDING ERROR - USE OctaveRichnes2 FOR THAT
****************************************************************************/
int *OctaveRichness(int R, double *NormA, int num_stdev, int oct_per_stdev) {
int a, mode;
int c = 0;
int length = oct_per_stdev * num_stdev;
int *Rich, *round;
double *deviat;
double w=0.0f, x=0.0f, y=R, z=0.0f;
Rich=ivector(length);
deviat=dvector(length);
for (a=length-1; a>=0; --a) {
/* do not round yet - we will do that later */
Rich[a]=x=NormA[a]*y;
deviat[a]=x-Rich[a];
c+=Rich[a];
}
if (c<R) {
/* find modal octave */
if (NormA[0]>NormA[1])
mode=0;
else {
for (a=1; a<length; ++a) {
if (NormA[a]>NormA[a-1] && NormA[a]>NormA[a+1]) {
mode=a;
a=length;
}
}
}
/* modal octave found */
round=ivector(length);
round=sort_decintbydouble(round,deviat,length);
for (a=0; a<(R-c); ++a) {
++Rich[round[a]];
}
free_ivector(round);
}
free_dvector(deviat);
return Rich;
}
