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; }