yenru0/2025-02-Numerical
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add numerical recipes library

Browse Source
This commit is contained in:
yenru0
2025-09-12 18:55:25 +09:00
parent d4dff245bd
commit 2c75620ec9
1344 changed files with 63869 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
lib/nr/k_and_r/other/bccbug.c Normal file
View File

@@ -0,0 +1,10 @@
/* The following function is recommended by Borland Technical Support to
"fix" the error "Floating Point Formats Not Linked". To use this file,
compile it along with your own files on the compiler command line. You
do not need to call it, just compile it along with your files. */
void LinkFloat(void)
{
float a=0, *b=&a;
a=*b;
}

250
lib/nr/k_and_r/other/complex.c Normal file
View File

@@ -0,0 +1,250 @@
#include <math.h>
typedef struct FCOMPLEX {float r,i;} fcomplex;
#if defined(__STDC__) || defined(ANSI) || defined(NRANSI) /* ANSI */
fcomplex Cadd(fcomplex a, fcomplex b)
{
fcomplex c;
c.r=a.r+b.r;
c.i=a.i+b.i;
return c;
}
fcomplex Csub(fcomplex a, fcomplex b)
{
fcomplex c;
c.r=a.r-b.r;
c.i=a.i-b.i;
return c;
}
fcomplex Cmul(fcomplex a, fcomplex b)
{
fcomplex c;
c.r=a.r*b.r-a.i*b.i;
c.i=a.i*b.r+a.r*b.i;
return c;
}
fcomplex Complex(float re, float im)
{
fcomplex c;
c.r=re;
c.i=im;
return c;
}
fcomplex Conjg(fcomplex z)
{
fcomplex c;
c.r=z.r;
c.i = -z.i;
return c;
}
fcomplex Cdiv(fcomplex a, fcomplex b)
{
fcomplex c;
float r,den;
if (fabs(b.r) >= fabs(b.i)) {
r=b.i/b.r;
den=b.r+r*b.i;
c.r=(a.r+r*a.i)/den;
c.i=(a.i-r*a.r)/den;
} else {
r=b.r/b.i;
den=b.i+r*b.r;
c.r=(a.r*r+a.i)/den;
c.i=(a.i*r-a.r)/den;
}
return c;
}
float Cabs(fcomplex z)
{
float x,y,ans,temp;
x=fabs(z.r);
y=fabs(z.i);
if (x == 0.0)
ans=y;
else if (y == 0.0)
ans=x;
else if (x > y) {
temp=y/x;
ans=x*sqrt(1.0+temp*temp);
} else {
temp=x/y;
ans=y*sqrt(1.0+temp*temp);
}
return ans;
}
fcomplex Csqrt(fcomplex z)
{
fcomplex c;
float x,y,w,r;
if ((z.r == 0.0) && (z.i == 0.0)) {
c.r=0.0;
c.i=0.0;
return c;
} else {
x=fabs(z.r);
y=fabs(z.i);
if (x >= y) {
r=y/x;
w=sqrt(x)*sqrt(0.5*(1.0+sqrt(1.0+r*r)));
} else {
r=x/y;
w=sqrt(y)*sqrt(0.5*(r+sqrt(1.0+r*r)));
}
if (z.r >= 0.0) {
c.r=w;
c.i=z.i/(2.0*w);
} else {
c.i=(z.i >= 0) ? w : -w;
c.r=z.i/(2.0*c.i);
}
return c;
}
}
fcomplex RCmul(float x, fcomplex a)
{
fcomplex c;
c.r=x*a.r;
c.i=x*a.i;
return c;
}
#else /* ANSI */
/* traditional - K&R */
fcomplex Cadd(a,b)
fcomplex a,b;
{
fcomplex c;
c.r=a.r+b.r;
c.i=a.i+b.i;
return c;
}
fcomplex Csub(a,b)
fcomplex a,b;
{
fcomplex c;
c.r=a.r-b.r;
c.i=a.i-b.i;
return c;
}
fcomplex Cmul(a,b)
fcomplex a,b;
{
fcomplex c;
c.r=a.r*b.r-a.i*b.i;
c.i=a.i*b.r+a.r*b.i;
return c;
}
fcomplex Complex(re,im)
float im,re;
{
fcomplex c;
c.r=re;
c.i=im;
return c;
}
fcomplex Conjg(z)
fcomplex z;
{
fcomplex c;
c.r=z.r;
c.i = -z.i;
return c;
}
fcomplex Cdiv(a,b)
fcomplex a,b;
{
fcomplex c;
float r,den;
if (fabs(b.r) >= fabs(b.i)) {
r=b.i/b.r;
den=b.r+r*b.i;
c.r=(a.r+r*a.i)/den;
c.i=(a.i-r*a.r)/den;
} else {
r=b.r/b.i;
den=b.i+r*b.r;
c.r=(a.r*r+a.i)/den;
c.i=(a.i*r-a.r)/den;
}
return c;
}
float Cabs(z)
fcomplex z;
{
float x,y,ans,temp;
x=fabs(z.r);
y=fabs(z.i);
if (x == 0.0)
ans=y;
else if (y == 0.0)
ans=x;
else if (x > y) {
temp=y/x;
ans=x*sqrt(1.0+temp*temp);
} else {
temp=x/y;
ans=y*sqrt(1.0+temp*temp);
}
return ans;
}
fcomplex Csqrt(z)
fcomplex z;
{
fcomplex c;
float x,y,w,r;
if ((z.r == 0.0) && (z.i == 0.0)) {
c.r=0.0;
c.i=0.0;
return c;
} else {
x=fabs(z.r);
y=fabs(z.i);
if (x >= y) {
r=y/x;
w=sqrt(x)*sqrt(0.5*(1.0+sqrt(1.0+r*r)));
} else {
r=x/y;
w=sqrt(y)*sqrt(0.5*(r+sqrt(1.0+r*r)));
}
if (z.r >= 0.0) {
c.r=w;
c.i=z.i/(2.0*w);
} else {
c.i=(z.i >= 0) ? w : -w;
c.r=z.i/(2.0*c.i);
}
return c;
}
}
fcomplex RCmul(x,a)
fcomplex a;
float x;
{
fcomplex c;
c.r=x*a.r;
c.i=x*a.i;
return c;
}
#endif /* ANSI */

614
lib/nr/k_and_r/other/nrutil.c Normal file
View File

@@ -0,0 +1,614 @@
#if defined(__STDC__) || defined(ANSI) || defined(NRANSI) /* ANSI */
#include <stdio.h>
#include <stddef.h>
#include <stdlib.h>
#define NR_END 1
#define FREE_ARG char*
void nrerror(char error_text[])
/* Numerical Recipes standard error handler */
{
fprintf(stderr,"Numerical Recipes run-time error...\n");
fprintf(stderr,"%s\n",error_text);
fprintf(stderr,"...now exiting to system...\n");
exit(1);
}
float *vector(long nl, long nh)
/* allocate a float vector with subscript range v[nl..nh] */
{
float *v;
v=(float *)malloc((size_t) ((nh-nl+1+NR_END)*sizeof(float)));
if (!v) nrerror("allocation failure in vector()");
return v-nl+NR_END;
}
int *ivector(long nl, long nh)
/* allocate an int vector with subscript range v[nl..nh] */
{
int *v;
v=(int *)malloc((size_t) ((nh-nl+1+NR_END)*sizeof(int)));
if (!v) nrerror("allocation failure in ivector()");
return v-nl+NR_END;
}
unsigned char *cvector(long nl, long nh)
/* allocate an unsigned char vector with subscript range v[nl..nh] */
{
unsigned char *v;
v=(unsigned char *)malloc((size_t) ((nh-nl+1+NR_END)*sizeof(unsigned char)));
if (!v) nrerror("allocation failure in cvector()");
return v-nl+NR_END;
}
unsigned long *lvector(long nl, long nh)
/* allocate an unsigned long vector with subscript range v[nl..nh] */
{
unsigned long *v;
v=(unsigned long *)malloc((size_t) ((nh-nl+1+NR_END)*sizeof(long)));
if (!v) nrerror("allocation failure in lvector()");
return v-nl+NR_END;
}
double *dvector(long nl, long nh)
/* allocate a double vector with subscript range v[nl..nh] */
{
double *v;
v=(double *)malloc((size_t) ((nh-nl+1+NR_END)*sizeof(double)));
if (!v) nrerror("allocation failure in dvector()");
return v-nl+NR_END;
}
float **matrix(long nrl, long nrh, long ncl, long nch)
/* allocate a float matrix with subscript range m[nrl..nrh][ncl..nch] */
{
long i, nrow=nrh-nrl+1,ncol=nch-ncl+1;
float **m;
/* allocate pointers to rows */
m=(float **) malloc((size_t)((nrow+NR_END)*sizeof(float*)));
if (!m) nrerror("allocation failure 1 in matrix()");
m += NR_END;
m -= nrl;
/* allocate rows and set pointers to them */
m[nrl]=(float *) malloc((size_t)((nrow*ncol+NR_END)*sizeof(float)));
if (!m[nrl]) nrerror("allocation failure 2 in matrix()");
m[nrl] += NR_END;
m[nrl] -= ncl;
for(i=nrl+1;i<=nrh;i++) m[i]=m[i-1]+ncol;
/* return pointer to array of pointers to rows */
return m;
}
double **dmatrix(long nrl, long nrh, long ncl, long nch)
/* allocate a double matrix with subscript range m[nrl..nrh][ncl..nch] */
{
long i, nrow=nrh-nrl+1,ncol=nch-ncl+1;
double **m;
/* allocate pointers to rows */
m=(double **) malloc((size_t)((nrow+NR_END)*sizeof(double*)));
if (!m) nrerror("allocation failure 1 in matrix()");
m += NR_END;
m -= nrl;
/* allocate rows and set pointers to them */
m[nrl]=(double *) malloc((size_t)((nrow*ncol+NR_END)*sizeof(double)));
if (!m[nrl]) nrerror("allocation failure 2 in matrix()");
m[nrl] += NR_END;
m[nrl] -= ncl;
for(i=nrl+1;i<=nrh;i++) m[i]=m[i-1]+ncol;
/* return pointer to array of pointers to rows */
return m;
}
int **imatrix(long nrl, long nrh, long ncl, long nch)
/* allocate a int matrix with subscript range m[nrl..nrh][ncl..nch] */
{
long i, nrow=nrh-nrl+1,ncol=nch-ncl+1;
int **m;
/* allocate pointers to rows */
m=(int **) malloc((size_t)((nrow+NR_END)*sizeof(int*)));
if (!m) nrerror("allocation failure 1 in matrix()");
m += NR_END;
m -= nrl;
/* allocate rows and set pointers to them */
m[nrl]=(int *) malloc((size_t)((nrow*ncol+NR_END)*sizeof(int)));
if (!m[nrl]) nrerror("allocation failure 2 in matrix()");
m[nrl] += NR_END;
m[nrl] -= ncl;
for(i=nrl+1;i<=nrh;i++) m[i]=m[i-1]+ncol;
/* return pointer to array of pointers to rows */
return m;
}
float **submatrix(float **a, long oldrl, long oldrh, long oldcl, long oldch,
long newrl, long newcl)
/* point a submatrix [newrl..][newcl..] to a[oldrl..oldrh][oldcl..oldch] */
{
long i,j,nrow=oldrh-oldrl+1,ncol=oldcl-newcl;
float **m;
/* allocate array of pointers to rows */
m=(float **) malloc((size_t) ((nrow+NR_END)*sizeof(float*)));
if (!m) nrerror("allocation failure in submatrix()");
m += NR_END;
m -= newrl;
/* set pointers to rows */
for(i=oldrl,j=newrl;i<=oldrh;i++,j++) m[j]=a[i]+ncol;
/* return pointer to array of pointers to rows */
return m;
}
float **convert_matrix(float *a, long nrl, long nrh, long ncl, long nch)
/* allocate a float matrix m[nrl..nrh][ncl..nch] that points to the matrix
declared in the standard C manner as a[nrow][ncol], where nrow=nrh-nrl+1
and ncol=nch-ncl+1. The routine should be called with the address
&a[0][0] as the first argument. */
{
long i,j,nrow=nrh-nrl+1,ncol=nch-ncl+1;
float **m;
/* allocate pointers to rows */
m=(float **) malloc((size_t) ((nrow+NR_END)*sizeof(float*)));
if (!m) nrerror("allocation failure in convert_matrix()");
m += NR_END;
m -= nrl;
/* set pointers to rows */
m[nrl]=a-ncl;
for(i=1,j=nrl+1;i<nrow;i++,j++) m[j]=m[j-1]+ncol;
/* return pointer to array of pointers to rows */
return m;
}
float ***f3tensor(long nrl, long nrh, long ncl, long nch, long ndl, long ndh)
/* allocate a float 3tensor with range t[nrl..nrh][ncl..nch][ndl..ndh] */
{
long i,j,nrow=nrh-nrl+1,ncol=nch-ncl+1,ndep=ndh-ndl+1;
float ***t;
/* allocate pointers to pointers to rows */
t=(float ***) malloc((size_t)((nrow+NR_END)*sizeof(float**)));
if (!t) nrerror("allocation failure 1 in f3tensor()");
t += NR_END;
t -= nrl;
/* allocate pointers to rows and set pointers to them */
t[nrl]=(float **) malloc((size_t)((nrow*ncol+NR_END)*sizeof(float*)));
if (!t[nrl]) nrerror("allocation failure 2 in f3tensor()");
t[nrl] += NR_END;
t[nrl] -= ncl;
/* allocate rows and set pointers to them */
t[nrl][ncl]=(float *) malloc((size_t)((nrow*ncol*ndep+NR_END)*sizeof(float)));
if (!t[nrl][ncl]) nrerror("allocation failure 3 in f3tensor()");
t[nrl][ncl] += NR_END;
t[nrl][ncl] -= ndl;
for(j=ncl+1;j<=nch;j++) t[nrl][j]=t[nrl][j-1]+ndep;
for(i=nrl+1;i<=nrh;i++) {
t[i]=t[i-1]+ncol;
t[i][ncl]=t[i-1][ncl]+ncol*ndep;
for(j=ncl+1;j<=nch;j++) t[i][j]=t[i][j-1]+ndep;
}
/* return pointer to array of pointers to rows */
return t;
}
void free_vector(float *v, long nl, long nh)
/* free a float vector allocated with vector() */
{
free((FREE_ARG) (v+nl-NR_END));
}
void free_ivector(int *v, long nl, long nh)
/* free an int vector allocated with ivector() */
{
free((FREE_ARG) (v+nl-NR_END));
}
void free_cvector(unsigned char *v, long nl, long nh)
/* free an unsigned char vector allocated with cvector() */
{
free((FREE_ARG) (v+nl-NR_END));
}
void free_lvector(unsigned long *v, long nl, long nh)
/* free an unsigned long vector allocated with lvector() */
{
free((FREE_ARG) (v+nl-NR_END));
}
void free_dvector(double *v, long nl, long nh)
/* free a double vector allocated with dvector() */
{
free((FREE_ARG) (v+nl-NR_END));
}
void free_matrix(float **m, long nrl, long nrh, long ncl, long nch)
/* free a float matrix allocated by matrix() */
{
free((FREE_ARG) (m[nrl]+ncl-NR_END));
free((FREE_ARG) (m+nrl-NR_END));
}
void free_dmatrix(double **m, long nrl, long nrh, long ncl, long nch)
/* free a double matrix allocated by dmatrix() */
{
free((FREE_ARG) (m[nrl]+ncl-NR_END));
free((FREE_ARG) (m+nrl-NR_END));
}
void free_imatrix(int **m, long nrl, long nrh, long ncl, long nch)
/* free an int matrix allocated by imatrix() */
{
free((FREE_ARG) (m[nrl]+ncl-NR_END));
free((FREE_ARG) (m+nrl-NR_END));
}
void free_submatrix(float **b, long nrl, long nrh, long ncl, long nch)
/* free a submatrix allocated by submatrix() */
{
free((FREE_ARG) (b+nrl-NR_END));
}
void free_convert_matrix(float **b, long nrl, long nrh, long ncl, long nch)
/* free a matrix allocated by convert_matrix() */
{
free((FREE_ARG) (b+nrl-NR_END));
}
void free_f3tensor(float ***t, long nrl, long nrh, long ncl, long nch,
long ndl, long ndh)
/* free a float f3tensor allocated by f3tensor() */
{
free((FREE_ARG) (t[nrl][ncl]+ndl-NR_END));
free((FREE_ARG) (t[nrl]+ncl-NR_END));
free((FREE_ARG) (t+nrl-NR_END));
}
#else /* ANSI */
/* traditional - K&R */
#include <stdio.h>
#define NR_END 1
#define FREE_ARG char*
void nrerror(error_text)
char error_text[];
/* Numerical Recipes standard error handler */
{
void exit();
fprintf(stderr,"Numerical Recipes run-time error...\n");
fprintf(stderr,"%s\n",error_text);
fprintf(stderr,"...now exiting to system...\n");
exit(1);
}
float *vector(nl,nh)
long nh,nl;
/* allocate a float vector with subscript range v[nl..nh] */
{
float *v;
v=(float *)malloc((unsigned int) ((nh-nl+1+NR_END)*sizeof(float)));
if (!v) nrerror("allocation failure in vector()");
return v-nl+NR_END;
}
int *ivector(nl,nh)
long nh,nl;
/* allocate an int vector with subscript range v[nl..nh] */
{
int *v;
v=(int *)malloc((unsigned int) ((nh-nl+1+NR_END)*sizeof(int)));
if (!v) nrerror("allocation failure in ivector()");
return v-nl+NR_END;
}
unsigned char *cvector(nl,nh)
long nh,nl;
/* allocate an unsigned char vector with subscript range v[nl..nh] */
{
unsigned char *v;
v=(unsigned char *)malloc((unsigned int) ((nh-nl+1+NR_END)*sizeof(unsigned char)));
if (!v) nrerror("allocation failure in cvector()");
return v-nl+NR_END;
}
unsigned long *lvector(nl,nh)
long nh,nl;
/* allocate an unsigned long vector with subscript range v[nl..nh] */
{
unsigned long *v;
v=(unsigned long *)malloc((unsigned int) ((nh-nl+1+NR_END)*sizeof(long)));
if (!v) nrerror("allocation failure in lvector()");
return v-nl+NR_END;
}
double *dvector(nl,nh)
long nh,nl;
/* allocate a double vector with subscript range v[nl..nh] */
{
double *v;
v=(double *)malloc((unsigned int) ((nh-nl+1+NR_END)*sizeof(double)));
if (!v) nrerror("allocation failure in dvector()");
return v-nl+NR_END;
}
float **matrix(nrl,nrh,ncl,nch)
long nch,ncl,nrh,nrl;
/* allocate a float matrix with subscript range m[nrl..nrh][ncl..nch] */
{
long i, nrow=nrh-nrl+1,ncol=nch-ncl+1;
float **m;
/* allocate pointers to rows */
m=(float **) malloc((unsigned int)((nrow+NR_END)*sizeof(float*)));
if (!m) nrerror("allocation failure 1 in matrix()");
m += NR_END;
m -= nrl;
/* allocate rows and set pointers to them */
m[nrl]=(float *) malloc((unsigned int)((nrow*ncol+NR_END)*sizeof(float)));
if (!m[nrl]) nrerror("allocation failure 2 in matrix()");
m[nrl] += NR_END;
m[nrl] -= ncl;
for(i=nrl+1;i<=nrh;i++) m[i]=m[i-1]+ncol;
/* return pointer to array of pointers to rows */
return m;
}
double **dmatrix(nrl,nrh,ncl,nch)
long nch,ncl,nrh,nrl;
/* allocate a double matrix with subscript range m[nrl..nrh][ncl..nch] */
{
long i, nrow=nrh-nrl+1,ncol=nch-ncl+1;
double **m;
/* allocate pointers to rows */
m=(double **) malloc((unsigned int)((nrow+NR_END)*sizeof(double*)));
if (!m) nrerror("allocation failure 1 in matrix()");
m += NR_END;
m -= nrl;
/* allocate rows and set pointers to them */
m[nrl]=(double *) malloc((unsigned int)((nrow*ncol+NR_END)*sizeof(double)));
if (!m[nrl]) nrerror("allocation failure 2 in matrix()");
m[nrl] += NR_END;
m[nrl] -= ncl;
for(i=nrl+1;i<=nrh;i++) m[i]=m[i-1]+ncol;
/* return pointer to array of pointers to rows */
return m;
}
int **imatrix(nrl,nrh,ncl,nch)
long nch,ncl,nrh,nrl;
/* allocate a int matrix with subscript range m[nrl..nrh][ncl..nch] */
{
long i, nrow=nrh-nrl+1,ncol=nch-ncl+1;
int **m;
/* allocate pointers to rows */
m=(int **) malloc((unsigned int)((nrow+NR_END)*sizeof(int*)));
if (!m) nrerror("allocation failure 1 in matrix()");
m += NR_END;
m -= nrl;
/* allocate rows and set pointers to them */
m[nrl]=(int *) malloc((unsigned int)((nrow*ncol+NR_END)*sizeof(int)));
if (!m[nrl]) nrerror("allocation failure 2 in matrix()");
m[nrl] += NR_END;
m[nrl] -= ncl;
for(i=nrl+1;i<=nrh;i++) m[i]=m[i-1]+ncol;
/* return pointer to array of pointers to rows */
return m;
}
float **submatrix(a,oldrl,oldrh,oldcl,oldch,newrl,newcl)
float **a;
long newcl,newrl,oldch,oldcl,oldrh,oldrl;
/* point a submatrix [newrl..][newcl..] to a[oldrl..oldrh][oldcl..oldch] */
{
long i,j,nrow=oldrh-oldrl+1,ncol=oldcl-newcl;
float **m;
/* allocate array of pointers to rows */
m=(float **) malloc((unsigned int) ((nrow+NR_END)*sizeof(float*)));
if (!m) nrerror("allocation failure in submatrix()");
m += NR_END;
m -= newrl;
/* set pointers to rows */
for(i=oldrl,j=newrl;i<=oldrh;i++,j++) m[j]=a[i]+ncol;
/* return pointer to array of pointers to rows */
return m;
}
float **convert_matrix(a,nrl,nrh,ncl,nch)
float *a;
long nch,ncl,nrh,nrl;
/* allocate a float matrix m[nrl..nrh][ncl..nch] that points to the matrix
declared in the standard C manner as a[nrow][ncol], where nrow=nrh-nrl+1
and ncol=nch-ncl+1. The routine should be called with the address
&a[0][0] as the first argument. */
{
long i,j,nrow=nrh-nrl+1,ncol=nch-ncl+1;
float **m;
/* allocate pointers to rows */
m=(float **) malloc((unsigned int) ((nrow+NR_END)*sizeof(float*)));
if (!m) nrerror("allocation failure in convert_matrix()");
m += NR_END;
m -= nrl;
/* set pointers to rows */
m[nrl]=a-ncl;
for(i=1,j=nrl+1;i<nrow;i++,j++) m[j]=m[j-1]+ncol;
/* return pointer to array of pointers to rows */
return m;
}
float ***f3tensor(nrl,nrh,ncl,nch,ndl,ndh)
long nch,ncl,ndh,ndl,nrh,nrl;
/* allocate a float 3tensor with range t[nrl..nrh][ncl..nch][ndl..ndh] */
{
long i,j,nrow=nrh-nrl+1,ncol=nch-ncl+1,ndep=ndh-ndl+1;
float ***t;
/* allocate pointers to pointers to rows */
t=(float ***) malloc((unsigned int)((nrow+NR_END)*sizeof(float**)));
if (!t) nrerror("allocation failure 1 in f3tensor()");
t += NR_END;
t -= nrl;
/* allocate pointers to rows and set pointers to them */
t[nrl]=(float **) malloc((unsigned int)((nrow*ncol+NR_END)*sizeof(float*)));
if (!t[nrl]) nrerror("allocation failure 2 in f3tensor()");
t[nrl] += NR_END;
t[nrl] -= ncl;
/* allocate rows and set pointers to them */
t[nrl][ncl]=(float *) malloc((unsigned int)((nrow*ncol*ndep+NR_END)*sizeof(float)));
if (!t[nrl][ncl]) nrerror("allocation failure 3 in f3tensor()");
t[nrl][ncl] += NR_END;
t[nrl][ncl] -= ndl;
for(j=ncl+1;j<=nch;j++) t[nrl][j]=t[nrl][j-1]+ndep;
for(i=nrl+1;i<=nrh;i++) {
t[i]=t[i-1]+ncol;
t[i][ncl]=t[i-1][ncl]+ncol*ndep;
for(j=ncl+1;j<=nch;j++) t[i][j]=t[i][j-1]+ndep;
}
/* return pointer to array of pointers to rows */
return t;
}
void free_vector(v,nl,nh)
float *v;
long nh,nl;
/* free a float vector allocated with vector() */
{
free((FREE_ARG) (v+nl-NR_END));
}
void free_ivector(v,nl,nh)
int *v;
long nh,nl;
/* free an int vector allocated with ivector() */
{
free((FREE_ARG) (v+nl-NR_END));
}
void free_cvector(v,nl,nh)
long nh,nl;
unsigned char *v;
/* free an unsigned char vector allocated with cvector() */
{
free((FREE_ARG) (v+nl-NR_END));
}
void free_lvector(v,nl,nh)
long nh,nl;
unsigned long *v;
/* free an unsigned long vector allocated with lvector() */
{
free((FREE_ARG) (v+nl-NR_END));
}
void free_dvector(v,nl,nh)
double *v;
long nh,nl;
/* free a double vector allocated with dvector() */
{
free((FREE_ARG) (v+nl-NR_END));
}
void free_matrix(m,nrl,nrh,ncl,nch)
float **m;
long nch,ncl,nrh,nrl;
/* free a float matrix allocated by matrix() */
{
free((FREE_ARG) (m[nrl]+ncl-NR_END));
free((FREE_ARG) (m+nrl-NR_END));
}
void free_dmatrix(m,nrl,nrh,ncl,nch)
double **m;
long nch,ncl,nrh,nrl;
/* free a double matrix allocated by dmatrix() */
{
free((FREE_ARG) (m[nrl]+ncl-NR_END));
free((FREE_ARG) (m+nrl-NR_END));
}
void free_imatrix(m,nrl,nrh,ncl,nch)
int **m;
long nch,ncl,nrh,nrl;
/* free an int matrix allocated by imatrix() */
{
free((FREE_ARG) (m[nrl]+ncl-NR_END));
free((FREE_ARG) (m+nrl-NR_END));
}
void free_submatrix(b,nrl,nrh,ncl,nch)
float **b;
long nch,ncl,nrh,nrl;
/* free a submatrix allocated by submatrix() */
{
free((FREE_ARG) (b+nrl-NR_END));
}
void free_convert_matrix(b,nrl,nrh,ncl,nch)
float **b;
long nch,ncl,nrh,nrl;
/* free a matrix allocated by convert_matrix() */
{
free((FREE_ARG) (b+nrl-NR_END));
}
void free_f3tensor(t,nrl,nrh,ncl,nch,ndl,ndh)
float ***t;
long nch,ncl,ndh,ndl,nrh,nrl;
/* free a float f3tensor allocated by f3tensor() */
{
free((FREE_ARG) (t[nrl][ncl]+ndl-NR_END));
free((FREE_ARG) (t[nrl]+ncl-NR_END));
free((FREE_ARG) (t+nrl-NR_END));
}
#endif /* ANSI */

13
lib/nr/k_and_r/recipes/addint.c Normal file
View File

@@ -0,0 +1,13 @@
void addint(uf,uc,res,nf)
double **res,**uc,**uf;
int nf;
{
void interp();
int i,j;
interp(res,uc,nf);
for (j=1;j<=nf;j++)
for (i=1;i<=nf;i++)
uf[i][j] += res[i][j];
}

41
lib/nr/k_and_r/recipes/airy.c Normal file
View File

@@ -0,0 +1,41 @@
#include <math.h>
#define PI 3.1415927
#define THIRD (1.0/3.0)
#define TWOTHR (2.0*THIRD)
#define ONOVRT 0.57735027
void airy(x,ai,bi,aip,bip)
float *ai,*aip,*bi,*bip,x;
{
void bessik(),bessjy();
float absx,ri,rip,rj,rjp,rk,rkp,rootx,ry,ryp,z;
absx=fabs(x);
rootx=sqrt(absx);
z=TWOTHR*absx*rootx;
if (x > 0.0) {
bessik(z,THIRD,&ri,&rk,&rip,&rkp);
*ai=rootx*ONOVRT*rk/PI;
*bi=rootx*(rk/PI+2.0*ONOVRT*ri);
bessik(z,TWOTHR,&ri,&rk,&rip,&rkp);
*aip = -x*ONOVRT*rk/PI;
*bip=x*(rk/PI+2.0*ONOVRT*ri);
} else if (x < 0.0) {
bessjy(z,THIRD,&rj,&ry,&rjp,&ryp);
*ai=0.5*rootx*(rj-ONOVRT*ry);
*bi = -0.5*rootx*(ry+ONOVRT*rj);
bessjy(z,TWOTHR,&rj,&ry,&rjp,&ryp);
*aip=0.5*absx*(ONOVRT*ry+rj);
*bip=0.5*absx*(ONOVRT*rj-ry);
} else {
*ai=0.35502805;
*bi=(*ai)/ONOVRT;
*aip = -0.25881940;
*bip = -(*aip)/ONOVRT;
}
}
#undef PI
#undef THIRD
#undef TWOTHR
#undef ONOVRT

84
lib/nr/k_and_r/recipes/amebsa.c Normal file
View File

@@ -0,0 +1,84 @@
#include <math.h>
#include "nrutil.h"
#define GET_PSUM \
for (n=1;n<=ndim;n++) {\
for (sum=0.0,m=1;m<=mpts;m++) sum += p[m][n];\
psum[n]=sum;}
extern long idum;
float tt;
void amebsa(p,y,ndim,pb,yb,ftol,funk,iter,temptr)
float (*funk)(),**p,*yb,ftol,pb[],temptr,y[];
int *iter,ndim;
{
float amotsa(),ran1();
int i,ihi,ilo,j,m,n,mpts=ndim+1;
float rtol,sum,swap,yhi,ylo,ynhi,ysave,yt,ytry,*psum;
psum=vector(1,ndim);
tt = -temptr;
GET_PSUM
for (;;) {
ilo=1;
ihi=2;
ynhi=ylo=y[1]+tt*log(ran1(&idum));
yhi=y[2]+tt*log(ran1(&idum));
if (ylo > yhi) {
ihi=1;
ilo=2;
ynhi=yhi;
yhi=ylo;
ylo=ynhi;
}
for (i=3;i<=mpts;i++) {
yt=y[i]+tt*log(ran1(&idum));
if (yt <= ylo) {
ilo=i;
ylo=yt;
}
if (yt > yhi) {
ynhi=yhi;
ihi=i;
yhi=yt;
} else if (yt > ynhi) {
ynhi=yt;
}
}
rtol=2.0*fabs(yhi-ylo)/(fabs(yhi)+fabs(ylo));
if (rtol < ftol || *iter < 0) {
swap=y[1];
y[1]=y[ilo];
y[ilo]=swap;
for (n=1;n<=ndim;n++) {
swap=p[1][n];
p[1][n]=p[ilo][n];
p[ilo][n]=swap;
}
break;
}
*iter -= 2;
ytry=amotsa(p,y,psum,ndim,pb,yb,funk,ihi,&yhi,-1.0);
if (ytry <= ylo) {
ytry=amotsa(p,y,psum,ndim,pb,yb,funk,ihi,&yhi,2.0);
} else if (ytry >= ynhi) {
ysave=yhi;
ytry=amotsa(p,y,psum,ndim,pb,yb,funk,ihi,&yhi,0.5);
if (ytry >= ysave) {
for (i=1;i<=mpts;i++) {
if (i != ilo) {
for (j=1;j<=ndim;j++) {
psum[j]=0.5*(p[i][j]+p[ilo][j]);
p[i][j]=psum[j];
}
y[i]=(*funk)(psum);
}
}
*iter -= ndim;
GET_PSUM
}
} else ++(*iter);
}
free_vector(psum,1,ndim);
}
#undef GET_PSUM

64
lib/nr/k_and_r/recipes/amoeba.c Normal file
View File

@@ -0,0 +1,64 @@
#include <math.h>
#include "nrutil.h"
#define TINY 1.0e-10
#define NMAX 5000
#define GET_PSUM \
for (j=1;j<=ndim;j++) {\
for (sum=0.0,i=1;i<=mpts;i++) sum += p[i][j];\
psum[j]=sum;}
#define SWAP(a,b) {swap=(a);(a)=(b);(b)=swap;}
void amoeba(p,y,ndim,ftol,funk,nfunk)
float (*funk)(),**p,ftol,y[];
int *nfunk,ndim;
{
float amotry();
int i,ihi,ilo,inhi,j,mpts=ndim+1;
float rtol,sum,swap,ysave,ytry,*psum;
psum=vector(1,ndim);
*nfunk=0;
GET_PSUM
for (;;) {
ilo=1;
ihi = y[1]>y[2] ? (inhi=2,1) : (inhi=1,2);
for (i=1;i<=mpts;i++) {
if (y[i] <= y[ilo]) ilo=i;
if (y[i] > y[ihi]) {
inhi=ihi;
ihi=i;
} else if (y[i] > y[inhi] && i != ihi) inhi=i;
}
rtol=2.0*fabs(y[ihi]-y[ilo])/(fabs(y[ihi])+fabs(y[ilo])+TINY);
if (rtol < ftol) {
SWAP(y[1],y[ilo])
for (i=1;i<=ndim;i++) SWAP(p[1][i],p[ilo][i])
break;
}
if (*nfunk >= NMAX) nrerror("NMAX exceeded");
*nfunk += 2;
ytry=amotry(p,y,psum,ndim,funk,ihi,-1.0);
if (ytry <= y[ilo])
ytry=amotry(p,y,psum,ndim,funk,ihi,2.0);
else if (ytry >= y[inhi]) {
ysave=y[ihi];
ytry=amotry(p,y,psum,ndim,funk,ihi,0.5);
if (ytry >= ysave) {
for (i=1;i<=mpts;i++) {
if (i != ilo) {
for (j=1;j<=ndim;j++)
p[i][j]=psum[j]=0.5*(p[i][j]+p[ilo][j]);
y[i]=(*funk)(psum);
}
}
*nfunk += ndim;
GET_PSUM
}
} else --(*nfunk);
}
free_vector(psum,1,ndim);
}
#undef SWAP
#undef GET_PSUM
#undef NMAX

25
lib/nr/k_and_r/recipes/amotry.c Normal file
View File

@@ -0,0 +1,25 @@
#include "nrutil.h"
float amotry(p,y,psum,ndim,funk,ihi,fac)
float (*funk)(),**p,fac,psum[],y[];
int ihi,ndim;
{
int j;
float fac1,fac2,ytry,*ptry;
ptry=vector(1,ndim);
fac1=(1.0-fac)/ndim;
fac2=fac1-fac;
for (j=1;j<=ndim;j++) ptry[j]=psum[j]*fac1-p[ihi][j]*fac2;
ytry=(*funk)(ptry);
if (ytry < y[ihi]) {
y[ihi]=ytry;
for (j=1;j<=ndim;j++) {
psum[j] += ptry[j]-p[ihi][j];
p[ihi][j]=ptry[j];
}
}
free_vector(ptry,1,ndim);
return ytry;
}

37
lib/nr/k_and_r/recipes/amotsa.c Normal file
View File

@@ -0,0 +1,37 @@
#include <math.h>
#include "nrutil.h"
extern long idum;
extern float tt;
float amotsa(p,y,psum,ndim,pb,yb,funk,ihi,yhi,fac)
float (*funk)(),**p,*yb,*yhi,fac,pb[],psum[],y[];
int ihi,ndim;
{
float ran1();
int j;
float fac1,fac2,yflu,ytry,*ptry;
ptry=vector(1,ndim);
fac1=(1.0-fac)/ndim;
fac2=fac1-fac;
for (j=1;j<=ndim;j++)
ptry[j]=psum[j]*fac1-p[ihi][j]*fac2;
ytry=(*funk)(ptry);
if (ytry <= *yb) {
for (j=1;j<=ndim;j++) pb[j]=ptry[j];
*yb=ytry;
}
yflu=ytry-tt*log(ran1(&idum));
if (yflu < *yhi) {
y[ihi]=ytry;
*yhi=yflu;
for (j=1;j<=ndim;j++) {
psum[j] += ptry[j]-p[ihi][j];
p[ihi][j]=ptry[j];
}
}
free_vector(ptry,1,ndim);
return yflu;
}

74
lib/nr/k_and_r/recipes/anneal.c Normal file
View File

@@ -0,0 +1,74 @@
#include <stdio.h>
#include <math.h>
#define TFACTR 0.9
#define ALEN(a,b,c,d) sqrt(((b)-(a))*((b)-(a))+((d)-(c))*((d)-(c)))
void anneal(x,y,iorder,ncity)
float x[],y[];
int iorder[],ncity;
{
float ran3(),revcst(),trncst();
int irbit1(),metrop();
void reverse(),trnspt();
int ans,nover,nlimit,i1,i2;
int i,j,k,nsucc,nn,idec;
static int n[7];
long idum;
unsigned long iseed;
float path,de,t;
nover=100*ncity;
nlimit=10*ncity;
path=0.0;
t=0.5;
for (i=1;i<ncity;i++) {
i1=iorder[i];
i2=iorder[i+1];
path += ALEN(x[i1],x[i2],y[i1],y[i2]);
}
i1=iorder[ncity];
i2=iorder[1];
path += ALEN(x[i1],x[i2],y[i1],y[i2]);
idum = -1;
iseed=111;
for (j=1;j<=100;j++) {
nsucc=0;
for (k=1;k<=nover;k++) {
do {
n[1]=1+(int) (ncity*ran3(&idum));
n[2]=1+(int) ((ncity-1)*ran3(&idum));
if (n[2] >= n[1]) ++n[2];
nn=1+((n[1]-n[2]+ncity-1) % ncity);
} while (nn<3);
idec=irbit1(&iseed);
if (idec == 0) {
n[3]=n[2]+(int) (abs(nn-2)*ran3(&idum))+1;
n[3]=1+((n[3]-1) % ncity);
de=trncst(x,y,iorder,ncity,n);
ans=metrop(de,t);
if (ans) {
++nsucc;
path += de;
trnspt(iorder,ncity,n);
}
} else {
de=revcst(x,y,iorder,ncity,n);
ans=metrop(de,t);
if (ans) {
++nsucc;
path += de;
reverse(iorder,ncity,n);
}
}
if (nsucc >= nlimit) break;
}
printf("\n %s %10.6f %s %12.6f \n","T =",t,
" Path Length =",path);
printf("Successful Moves: %6d\n",nsucc);
t *= TFACTR;
if (nsucc == 0) return;
}
}
#undef TFACTR
#undef ALEN

15
lib/nr/k_and_r/recipes/anorm2.c Normal file
View File

@@ -0,0 +1,15 @@
#include <math.h>
double anorm2(a,n)
double **a;
int n;
{
int i,j;
double sum=0.0;
for (j=1;j<=n;j++)
for (i=1;i<=n;i++)
sum += a[i][j]*a[i][j];
return sqrt(sum)/n;
}

32
lib/nr/k_and_r/recipes/arcmak.c Normal file
View File

@@ -0,0 +1,32 @@
#include "nrutil.h"
#define MC 512
#ifdef ULONG_MAX
#define MAXINT (ULONG_MAX >> 1)
#else
#define MAXINT 2147483647
#endif
typedef struct {
unsigned long *ilob,*iupb,*ncumfq,jdif,nc,minint,nch,ncum,nrad;
} arithcode;
void arcmak(nfreq,nchh,nradd,acode)
arithcode *acode;
unsigned long nchh,nfreq[],nradd;
{
unsigned long j;
if (nchh > MC) nrerror("input radix may not exceed MC in arcmak.");
if (nradd > 256) nrerror("output radix may not exceed 256 in arcmak.");
acode->minint=MAXINT/nradd;
acode->nch=nchh;
acode->nrad=nradd;
acode->ncumfq[1]=0;
for (j=2;j<=acode->nch+1;j++)
acode->ncumfq[j]=acode->ncumfq[j-1]+IMAX(nfreq[j-1],1);
acode->ncum=acode->ncumfq[acode->nch+2]=acode->ncumfq[acode->nch+1]+1;
}
#undef MC
#undef MAXINT

88
lib/nr/k_and_r/recipes/arcode.c Normal file
View File

@@ -0,0 +1,88 @@
#include <stdio.h>
#define NWK 20
#define JTRY(j,k,m) ((long)((((double)(k))*((double)(j)))/((double)(m))))
typedef struct {
unsigned long *ilob,*iupb,*ncumfq,jdif,nc,minint,nch,ncum,nrad;
} arithcode;
void arcode(ich,codep,lcode,lcd,isign,acode)
arithcode *acode;
int isign;
unsigned char **codep;
unsigned long *ich,*lcd,*lcode;
{
char *realloc();
void arcsum();
void nrerror();
int j,k;
unsigned long ihi,ja,jh,jl,m;
if (!isign) {
acode->jdif=acode->nrad-1;
for (j=NWK;j>=1;j--) {
acode->iupb[j]=acode->nrad-1;
acode->ilob[j]=0;
acode->nc=j;
if (acode->jdif > acode->minint) return;
acode->jdif=(acode->jdif+1)*acode->nrad-1;
}
nrerror("NWK too small in arcode.");
} else {
if (isign > 0) {
if (*ich > acode->nch) nrerror("bad ich in arcode.");
}
else {
ja=(*codep)[*lcd]-acode->ilob[acode->nc];
for (j=acode->nc+1;j<=NWK;j++) {
ja *= acode->nrad;
ja += ((*codep)[*lcd+j-acode->nc]-acode->ilob[j]);
}
ihi=acode->nch+1;
*ich=0;
while (ihi-(*ich) > 1) {
m=(*ich+ihi)>>1;
if (ja >= JTRY(acode->jdif,acode->ncumfq[m+1],acode->ncum))
*ich=m;
else ihi=m;
}
if (*ich == acode->nch) return;
}
jh=JTRY(acode->jdif,acode->ncumfq[*ich+2],acode->ncum);
jl=JTRY(acode->jdif,acode->ncumfq[*ich+1],acode->ncum);
acode->jdif=jh-jl;
arcsum(acode->ilob,acode->iupb,jh,NWK,acode->nrad,acode->nc);
arcsum(acode->ilob,acode->ilob,jl,NWK,acode->nrad,acode->nc);
for (j=acode->nc;j<=NWK;j++) {
if (*ich != acode->nch && acode->iupb[j] != acode->ilob[j]) break;
if (*lcd > *lcode) {
fprintf(stderr,"Reached the end of the 'code' array.\n");
fprintf(stderr,"Attempting to expand its size.\n");
*lcode += *lcode/2;
if ((*codep=(unsigned char *)realloc(*codep,
(unsigned)(*lcode*sizeof(unsigned char)))) == NULL) {
nrerror("Size expansion failed");
}
}
if (isign > 0) (*codep)[*lcd]=(unsigned char)acode->ilob[j];
++(*lcd);
}
if (j > NWK) return;
acode->nc=j;
for(j=0;acode->jdif<acode->minint;j++)
acode->jdif *= acode->nrad;
if (acode->nc-j < 1) nrerror("NWK too small in arcode.");
if (j) {
for (k=acode->nc;k<=NWK;k++) {
acode->iupb[k-j]=acode->iupb[k];
acode->ilob[k-j]=acode->ilob[k];
}
}
acode->nc -= j;
for (k=NWK-j+1;k<=NWK;k++) acode->iupb[k]=acode->ilob[k]=0;
}
return;
}
#undef NWK
#undef JTRY

19
lib/nr/k_and_r/recipes/arcsum.c Normal file
View File

@@ -0,0 +1,19 @@
void arcsum(iin,iout,ja,nwk,nrad,nc)
int nwk;
unsigned long iin[],iout[],ja,nc,nrad;
{
int j,karry=0;
unsigned long jtmp;
for (j=nwk;j>nc;j--) {
jtmp=ja;
ja /= nrad;
iout[j]=iin[j]+(jtmp-ja*nrad)+karry;
if (iout[j] >= nrad) {
iout[j] -= nrad;
karry=1;
} else karry=0;
}
iout[nc]=iin[nc]+ja+karry;
}

13
lib/nr/k_and_r/recipes/asolve.c Normal file
View File

@@ -0,0 +1,13 @@
extern unsigned long ija[];
extern double sa[];
void asolve(n,b,x,itrnsp)
double b[],x[];
int itrnsp;
unsigned long n;
{
unsigned long i;
for(i=1;i<=n;i++) x[i]=(sa[i] != 0.0 ? b[i]/sa[i] : b[i]);
}

14
lib/nr/k_and_r/recipes/atimes.c Normal file
View File

@@ -0,0 +1,14 @@
extern unsigned long ija[];
extern double sa[];
void atimes(n,x,r,itrnsp)
double r[],x[];
int itrnsp;
unsigned long n;
{
void dsprsax(),dsprstx();
if (itrnsp) dsprstx(sa,ija,x,r,n);
else dsprsax(sa,ija,x,r,n);
}

18
lib/nr/k_and_r/recipes/avevar.c Normal file
View File

@@ -0,0 +1,18 @@
void avevar(data,n,ave,var)
float *ave,*var,data[];
unsigned long n;
{
unsigned long j;
float s,ep;
for (*ave=0.0,j=1;j<=n;j++) *ave += data[j];
*ave /= n;
*var=ep=0.0;
for (j=1;j<=n;j++) {
s=data[j]-(*ave);
ep += s;
*var += s*s;
}
*var=(*var-ep*ep/n)/(n-1);
}

52
lib/nr/k_and_r/recipes/badluk.c Normal file
View File

@@ -0,0 +1,52 @@
#include <stdio.h>
#include <math.h>
#define ZON -5.0
#define IYBEG 1900
#define IYEND 2000
main() /* Program badluk */
{
long julday();
void flmoon();
int ic,icon,idwk,im,iyyy,n;
float timzon = ZON/24.0,frac;
long jd,jday;
printf("\nFull moons on Friday the 13th from %5d to %5d\n",IYBEG,IYEND);
for (iyyy=IYBEG;iyyy<=IYEND;iyyy++) {
for (im=1;im<=12;im++) {
jday=julday(im,13,iyyy);
idwk=(int) ((jday+1) % 7);
if (idwk == 5) {
n=(int)(12.37*(iyyy-1900+(im-0.5)/12.0));
icon=0;
for (;;) {
flmoon(n,2,&jd,&frac);
frac=24.0*(frac+timzon);
if (frac < 0.0) {
--jd;
frac += 24.0;
}
if (frac > 12.0) {
++jd;
frac -= 12.0;
} else
frac += 12.0;
if (jd == jday) {
printf("\n%2d/13/%4d\n",im,iyyy);
printf("%s %5.1f %s\n","Full moon",frac,
" hrs after midnight (EST)");
break;
} else {
ic=(jday >= jd ? 1 : -1);
if (ic == (-icon)) break;
icon=ic;
n += ic;
}
}
}
}
}
return 0;
}

46
lib/nr/k_and_r/recipes/balanc.c Normal file
View File

@@ -0,0 +1,46 @@
#include <math.h>
#define RADIX 2.0
void balanc(a,n)
float **a;
int n;
{
int last,j,i;
float s,r,g,f,c,sqrdx;
sqrdx=RADIX*RADIX;
last=0;
while (last == 0) {
last=1;
for (i=1;i<=n;i++) {
r=c=0.0;
for (j=1;j<=n;j++)
if (j != i) {
c += fabs(a[j][i]);
r += fabs(a[i][j]);
}
if (c && r) {
g=r/RADIX;
f=1.0;
s=c+r;
while (c<g) {
f *= RADIX;
c *= sqrdx;
}
g=r*RADIX;
while (c>g) {
f /= RADIX;
c /= sqrdx;
}
if ((c+r)/f < 0.95*s) {
last=0;
g=1.0/f;
for (j=1;j<=n;j++) a[i][j] *= g;
for (j=1;j<=n;j++) a[j][i] *= f;
}
}
}
}
}
#undef RADIX

29
lib/nr/k_and_r/recipes/banbks.c Normal file
View File

@@ -0,0 +1,29 @@
#define SWAP(a,b) {dum=(a);(a)=(b);(b)=dum;}
void banbks(a,n,m1,m2,al,indx,b)
float **a,**al,b[];
int m1,m2;
unsigned long indx[],n;
{
unsigned long i,k,l;
int mm;
float dum;
mm=m1+m2+1;
l=m1;
for (k=1;k<=n;k++) {
i=indx[k];
if (i != k) SWAP(b[k],b[i])
if (l < n) l++;
for (i=k+1;i<=l;i++) b[i] -= al[k][i-k]*b[k];
}
l=1;
for (i=n;i>=1;i--) {
dum=b[i];
for (k=2;k<=l;k++) dum -= a[i][k]*b[k+i-1];
b[i]=dum/a[i][1];
if (l < mm) l++;
}
}
#undef SWAP

49
lib/nr/k_and_r/recipes/bandec.c Normal file
View File

@@ -0,0 +1,49 @@
#include <math.h>
#define SWAP(a,b) {dum=(a);(a)=(b);(b)=dum;}
#define TINY 1.0e-20
void bandec(a,n,m1,m2,al,indx,d)
float **a,**al,*d;
int m1,m2;
unsigned long indx[],n;
{
unsigned long i,j,k,l;
int mm;
float dum;
mm=m1+m2+1;
l=m1;
for (i=1;i<=m1;i++) {
for (j=m1+2-i;j<=mm;j++) a[i][j-l]=a[i][j];
l--;
for (j=mm-l;j<=mm;j++) a[i][j]=0.0;
}
*d=1.0;
l=m1;
for (k=1;k<=n;k++) {
dum=a[k][1];
i=k;
if (l < n) l++;
for (j=k+1;j<=l;j++) {
if (fabs(a[j][1]) > fabs(dum)) {
dum=a[j][1];
i=j;
}
}
indx[k]=i;
if (dum == 0.0) a[k][1]=TINY;
if (i != k) {
*d = -(*d);
for (j=1;j<=mm;j++) SWAP(a[k][j],a[i][j])
}
for (i=k+1;i<=l;i++) {
dum=a[i][1]/a[k][1];
al[k][i-k]=dum;
for (j=2;j<=mm;j++) a[i][j-1]=a[i][j]-dum*a[k][j];
a[i][mm]=0.0;
}
}
}
#undef SWAP
#undef TINY

17
lib/nr/k_and_r/recipes/banmul.c Normal file
View File

@@ -0,0 +1,17 @@
#include "nrutil.h"
void banmul(a,n,m1,m2,x,b)
float **a,b[],x[];
int m1,m2;
unsigned long n;
{
unsigned long i,j,k,tmploop;
for (i=1;i<=n;i++) {
k=i-m1-1;
tmploop=LMIN(m1+m2+1,n-k);
b[i]=0.0;
for (j=LMAX(1,1-k);j<=tmploop;j++) b[i] += a[i][j]*x[j+k];
}
}

40
lib/nr/k_and_r/recipes/bcucof.c Normal file
View File

@@ -0,0 +1,40 @@
void bcucof(y,y1,y2,y12,d1,d2,c)
float **c,d1,d2,y12[],y1[],y2[],y[];
{
static int wt[16][16]=
{ 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,
-3,0,0,3,0,0,0,0,-2,0,0,-1,0,0,0,0,
2,0,0,-2,0,0,0,0,1,0,0,1,0,0,0,0,
0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,
0,0,0,0,-3,0,0,3,0,0,0,0,-2,0,0,-1,
0,0,0,0,2,0,0,-2,0,0,0,0,1,0,0,1,
-3,3,0,0,-2,-1,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,-3,3,0,0,-2,-1,0,0,
9,-9,9,-9,6,3,-3,-6,6,-6,-3,3,4,2,1,2,
-6,6,-6,6,-4,-2,2,4,-3,3,3,-3,-2,-1,-1,-2,
2,-2,0,0,1,1,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,2,-2,0,0,1,1,0,0,
-6,6,-6,6,-3,-3,3,3,-4,4,2,-2,-2,-2,-1,-1,
4,-4,4,-4,2,2,-2,-2,2,-2,-2,2,1,1,1,1};
int l,k,j,i;
float xx,d1d2,cl[16],x[16];
d1d2=d1*d2;
for (i=1;i<=4;i++) {
x[i-1]=y[i];
x[i+3]=y1[i]*d1;
x[i+7]=y2[i]*d2;
x[i+11]=y12[i]*d1d2;
}
for (i=0;i<=15;i++) {
xx=0.0;
for (k=0;k<=15;k++) xx += wt[i][k]*x[k];
cl[i]=xx;
}
l=0;
for (i=1;i<=4;i++)
for (j=1;j<=4;j++) c[i][j]=cl[l++];
}

27
lib/nr/k_and_r/recipes/bcuint.c Normal file
View File

@@ -0,0 +1,27 @@
#include "nrutil.h"
void bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy,ansy1,ansy2)
float *ansy,*ansy1,*ansy2,x1,x1l,x1u,x2,x2l,x2u,y12[],y1[],y2[],y[];
{
void bcucof();
int i;
float t,u,d1,d2,**c;
c=matrix(1,4,1,4);
d1=x1u-x1l;
d2=x2u-x2l;
bcucof(y,y1,y2,y12,d1,d2,c);
if (x1u == x1l || x2u == x2l) nrerror("Bad input in routine bcuint");
t=(x1-x1l)/d1;
u=(x2-x2l)/d2;
*ansy=(*ansy2)=(*ansy1)=0.0;
for (i=4;i>=1;i--) {
*ansy=t*(*ansy)+((c[i][4]*u+c[i][3])*u+c[i][2])*u+c[i][1];
*ansy2=t*(*ansy2)+(3.0*c[i][4]*u+2.0*c[i][3])*u+c[i][2];
*ansy1=u*(*ansy1)+(3.0*c[4][i]*t+2.0*c[3][i])*t+c[2][i];
}
*ansy1 /= d1;
*ansy2 /= d2;
free_matrix(c,1,4,1,4);
}

26
lib/nr/k_and_r/recipes/beschb.c Normal file
View File

@@ -0,0 +1,26 @@
#define NUSE1 5
#define NUSE2 5
void beschb(x,gam1,gam2,gampl,gammi)
double *gam1,*gam2,*gammi,*gampl,x;
{
float chebev();
float xx;
static float c1[] = {
-1.142022680371168e0,6.5165112670737e-3,
3.087090173086e-4,-3.4706269649e-6,6.9437664e-9,
3.67795e-11,-1.356e-13};
static float c2[] = {
1.843740587300905e0,-7.68528408447867e-2,
1.2719271366546e-3,-4.9717367042e-6,-3.31261198e-8,
2.423096e-10,-1.702e-13,-1.49e-15};
xx=8.0*x*x-1.0;
*gam1=chebev(-1.0,1.0,c1,NUSE1,xx);
*gam2=chebev(-1.0,1.0,c2,NUSE2,xx);
*gampl= *gam2-x*(*gam1);
*gammi= *gam2+x*(*gam1);
}
#undef NUSE1
#undef NUSE2

40
lib/nr/k_and_r/recipes/bessi.c Normal file
View File

@@ -0,0 +1,40 @@
#include <math.h>
#define ACC 40.0
#define BIGNO 1.0e10
#define BIGNI 1.0e-10
float bessi(n,x)
float x;
int n;
{
float bessi0();
void nrerror();
int j;
float bi,bim,bip,tox,ans;
if (n < 2) nrerror("Index n less than 2 in bessi");
if (x == 0.0)
return 0.0;
else {
tox=2.0/fabs(x);
bip=ans=0.0;
bi=1.0;
for (j=2*(n+(int) sqrt(ACC*n));j>0;j--) {
bim=bip+j*tox*bi;
bip=bi;
bi=bim;
if (fabs(bi) > BIGNO) {
ans *= BIGNI;
bi *= BIGNI;
bip *= BIGNI;
}
if (j == n) ans=bip;
}
ans *= bessi0(x)/bi;
return x < 0.0 && (n & 1) ? -ans : ans;
}
}
#undef ACC
#undef BIGNO
#undef BIGNI

23
lib/nr/k_and_r/recipes/bessi0.c Normal file
View File

@@ -0,0 +1,23 @@
#include <math.h>
float bessi0(x)
float x;
{
float ax,ans;
double y;
if ((ax=fabs(x)) < 3.75) {
y=x/3.75;
y*=y;
ans=1.0+y*(3.5156229+y*(3.0899424+y*(1.2067492
+y*(0.2659732+y*(0.360768e-1+y*0.45813e-2)))));
} else {
y=3.75/ax;
ans=(exp(ax)/sqrt(ax))*(0.39894228+y*(0.1328592e-1
+y*(0.225319e-2+y*(-0.157565e-2+y*(0.916281e-2
+y*(-0.2057706e-1+y*(0.2635537e-1+y*(-0.1647633e-1
+y*0.392377e-2))))))));
}
return ans;
}

24
lib/nr/k_and_r/recipes/bessi1.c Normal file
View File

@@ -0,0 +1,24 @@
#include <math.h>
float bessi1(x)
float x;
{
float ax,ans;
double y;
if ((ax=fabs(x)) < 3.75) {
y=x/3.75;
y*=y;
ans=ax*(0.5+y*(0.87890594+y*(0.51498869+y*(0.15084934
+y*(0.2658733e-1+y*(0.301532e-2+y*0.32411e-3))))));
} else {
y=3.75/ax;
ans=0.2282967e-1+y*(-0.2895312e-1+y*(0.1787654e-1
-y*0.420059e-2));
ans=0.39894228+y*(-0.3988024e-1+y*(-0.362018e-2
+y*(0.163801e-2+y*(-0.1031555e-1+y*ans))));
ans *= (exp(ax)/sqrt(ax));
}
return x < 0.0 ? -ans : ans;
}

127
lib/nr/k_and_r/recipes/bessik.c Normal file
View File

@@ -0,0 +1,127 @@
#include <math.h>
#define EPS 1.0e-10
#define FPMIN 1.0e-30
#define MAXIT 10000
#define XMIN 2.0
#define PI 3.141592653589793
void bessik(x,xnu,ri,rk,rip,rkp)
float *ri,*rip,*rk,*rkp,x,xnu;
{
void beschb();
void nrerror();
int i,l,nl;
double a,a1,b,c,d,del,del1,delh,dels,e,f,fact,fact2,ff,gam1,gam2,
gammi,gampl,h,p,pimu,q,q1,q2,qnew,ril,ril1,rimu,rip1,ripl,
ritemp,rk1,rkmu,rkmup,rktemp,s,sum,sum1,x2,xi,xi2,xmu,xmu2;
if (x <= 0.0 || xnu < 0.0) nrerror("bad arguments in bessik");
nl=(int)(xnu+0.5);
xmu=xnu-nl;
xmu2=xmu*xmu;
xi=1.0/x;
xi2=2.0*xi;
h=xnu*xi;
if (h < FPMIN) h=FPMIN;
b=xi2*xnu;
d=0.0;
c=h;
for (i=1;i<=MAXIT;i++) {
b += xi2;
d=1.0/(b+d);
c=b+1.0/c;
del=c*d;
h=del*h;
if (fabs(del-1.0) < EPS) break;
}
if (i > MAXIT) nrerror("x too large in bessik; try asymptotic expansion");
ril=FPMIN;
ripl=h*ril;
ril1=ril;
rip1=ripl;
fact=xnu*xi;
for (l=nl;l>=1;l--) {
ritemp=fact*ril+ripl;
fact -= xi;
ripl=fact*ritemp+ril;
ril=ritemp;
}
f=ripl/ril;
if (x < XMIN) {
x2=0.5*x;
pimu=PI*xmu;
fact = (fabs(pimu) < EPS ? 1.0 : pimu/sin(pimu));
d = -log(x2);
e=xmu*d;
fact2 = (fabs(e) < EPS ? 1.0 : sinh(e)/e);
beschb(xmu,&gam1,&gam2,&gampl,&gammi);
ff=fact*(gam1*cosh(e)+gam2*fact2*d);
sum=ff;
e=exp(e);
p=0.5*e/gampl;
q=0.5/(e*gammi);
c=1.0;
d=x2*x2;
sum1=p;
for (i=1;i<=MAXIT;i++) {
ff=(i*ff+p+q)/(i*i-xmu2);
c *= (d/i);
p /= (i-xmu);
q /= (i+xmu);
del=c*ff;
sum += del;
del1=c*(p-i*ff);
sum1 += del1;
if (fabs(del) < fabs(sum)*EPS) break;
}
if (i > MAXIT) nrerror("bessk series failed to converge");
rkmu=sum;
rk1=sum1*xi2;
} else {
b=2.0*(1.0+x);
d=1.0/b;
h=delh=d;
q1=0.0;
q2=1.0;
a1=0.25-xmu2;
q=c=a1;
a = -a1;
s=1.0+q*delh;
for (i=2;i<=MAXIT;i++) {
a -= 2*(i-1);
c = -a*c/i;
qnew=(q1-b*q2)/a;
q1=q2;
q2=qnew;
q += c*qnew;
b += 2.0;
d=1.0/(b+a*d);
delh=(b*d-1.0)*delh;
h += delh;
dels=q*delh;
s += dels;
if (fabs(dels/s) < EPS) break;
}
if (i > MAXIT) nrerror("bessik: failure to converge in cf2");
h=a1*h;
rkmu=sqrt(PI/(2.0*x))*exp(-x)/s;
rk1=rkmu*(xmu+x+0.5-h)*xi;
}
rkmup=xmu*xi*rkmu-rk1;
rimu=xi/(f*rkmu-rkmup);
*ri=(rimu*ril1)/ril;
*rip=(rimu*rip1)/ril;
for (i=1;i<=nl;i++) {
rktemp=(xmu+i)*xi2*rk1+rkmu;
rkmu=rk1;
rk1=rktemp;
}
*rk=rkmu;
*rkp=xnu*xi*rkmu-rk1;
}
#undef EPS
#undef FPMIN
#undef MAXIT
#undef XMIN
#undef PI

57
lib/nr/k_and_r/recipes/bessj.c Normal file
View File

@@ -0,0 +1,57 @@
#include <math.h>
#define ACC 40.0
#define BIGNO 1.0e10
#define BIGNI 1.0e-10
float bessj(n,x)
float x;
int n;
{
float bessj0(),bessj1();
void nrerror();
int j,jsum,m;
float ax,bj,bjm,bjp,sum,tox,ans;
if (n < 2) nrerror("Index n less than 2 in bessj");
ax=fabs(x);
if (ax == 0.0)
return 0.0;
else if (ax > (float) n) {
tox=2.0/ax;
bjm=bessj0(ax);
bj=bessj1(ax);
for (j=1;j<n;j++) {
bjp=j*tox*bj-bjm;
bjm=bj;
bj=bjp;
}
ans=bj;
} else {
tox=2.0/ax;
m=2*((n+(int) sqrt(ACC*n))/2);
jsum=0;
bjp=ans=sum=0.0;
bj=1.0;
for (j=m;j>0;j--) {
bjm=j*tox*bj-bjp;
bjp=bj;
bj=bjm;
if (fabs(bj) > BIGNO) {
bj *= BIGNI;
bjp *= BIGNI;
ans *= BIGNI;
sum *= BIGNI;
}
if (jsum) sum += bj;
jsum=!jsum;
if (j == n) ans=bjp;
}
sum=2.0*sum-bj;
ans /= sum;
}
return x < 0.0 && (n & 1) ? -ans : ans;
}
#undef ACC
#undef BIGNO
#undef BIGNI

29
lib/nr/k_and_r/recipes/bessj0.c Normal file
View File

@@ -0,0 +1,29 @@
#include <math.h>
float bessj0(x)
float x;
{
float ax,z;
double xx,y,ans,ans1,ans2;
if ((ax=fabs(x)) < 8.0) {
y=x*x;
ans1=57568490574.0+y*(-13362590354.0+y*(651619640.7
+y*(-11214424.18+y*(77392.33017+y*(-184.9052456)))));
ans2=57568490411.0+y*(1029532985.0+y*(9494680.718
+y*(59272.64853+y*(267.8532712+y*1.0))));
ans=ans1/ans2;
} else {
z=8.0/ax;
y=z*z;
xx=ax-0.785398164;
ans1=1.0+y*(-0.1098628627e-2+y*(0.2734510407e-4
+y*(-0.2073370639e-5+y*0.2093887211e-6)));
ans2 = -0.1562499995e-1+y*(0.1430488765e-3
+y*(-0.6911147651e-5+y*(0.7621095161e-6
-y*0.934945152e-7)));
ans=sqrt(0.636619772/ax)*(cos(xx)*ans1-z*sin(xx)*ans2);
}
return ans;
}

30
lib/nr/k_and_r/recipes/bessj1.c Normal file
View File

@@ -0,0 +1,30 @@
#include <math.h>
float bessj1(x)
float x;
{
float ax,z;
double xx,y,ans,ans1,ans2;
if ((ax=fabs(x)) < 8.0) {
y=x*x;
ans1=x*(72362614232.0+y*(-7895059235.0+y*(242396853.1
+y*(-2972611.439+y*(15704.48260+y*(-30.16036606))))));
ans2=144725228442.0+y*(2300535178.0+y*(18583304.74
+y*(99447.43394+y*(376.9991397+y*1.0))));
ans=ans1/ans2;
} else {
z=8.0/ax;
y=z*z;
xx=ax-2.356194491;
ans1=1.0+y*(0.183105e-2+y*(-0.3516396496e-4
+y*(0.2457520174e-5+y*(-0.240337019e-6))));
ans2=0.04687499995+y*(-0.2002690873e-3
+y*(0.8449199096e-5+y*(-0.88228987e-6
+y*0.105787412e-6)));
ans=sqrt(0.636619772/ax)*(cos(xx)*ans1-z*sin(xx)*ans2);
if (x < 0.0) ans = -ans;
}
return ans;
}

154
lib/nr/k_and_r/recipes/bessjy.c Normal file
View File

@@ -0,0 +1,154 @@
#include <math.h>
#include "nrutil.h"
#define EPS 1.0e-10
#define FPMIN 1.0e-30
#define MAXIT 10000
#define XMIN 2.0
#define PI 3.141592653589793
void bessjy(x,xnu,rj,ry,rjp,ryp)
float *rj,*rjp,*ry,*ryp,x,xnu;
{
void beschb();
int i,isign,l,nl;
double a,b,br,bi,c,cr,ci,d,del,del1,den,di,dlr,dli,dr,e,f,fact,fact2,
fact3,ff,gam,gam1,gam2,gammi,gampl,h,p,pimu,pimu2,q,r,rjl,
rjl1,rjmu,rjp1,rjpl,rjtemp,ry1,rymu,rymup,rytemp,sum,sum1,
temp,w,x2,xi,xi2,xmu,xmu2;
if (x <= 0.0 || xnu < 0.0) nrerror("bad arguments in bessjy");
nl=(x < XMIN ? (int)(xnu+0.5) : IMAX(0,(int)(xnu-x+1.5)));
xmu=xnu-nl;
xmu2=xmu*xmu;
xi=1.0/x;
xi2=2.0*xi;
w=xi2/PI;
isign=1;
h=xnu*xi;
if (h < FPMIN) h=FPMIN;
b=xi2*xnu;
d=0.0;
c=h;
for (i=1;i<=MAXIT;i++) {
b += xi2;
d=b-d;
if (fabs(d) < FPMIN) d=FPMIN;
c=b-1.0/c;
if (fabs(c) < FPMIN) c=FPMIN;
d=1.0/d;
del=c*d;
h=del*h;
if (d < 0.0) isign = -isign;
if (fabs(del-1.0) < EPS) break;
}
if (i > MAXIT) nrerror("x too large in bessjy; try asymptotic expansion");
rjl=isign*FPMIN;
rjpl=h*rjl;
rjl1=rjl;
rjp1=rjpl;
fact=xnu*xi;
for (l=nl;l>=1;l--) {
rjtemp=fact*rjl+rjpl;
fact -= xi;
rjpl=fact*rjtemp-rjl;
rjl=rjtemp;
}
if (rjl == 0.0) rjl=EPS;
f=rjpl/rjl;
if (x < XMIN) {
x2=0.5*x;
pimu=PI*xmu;
fact = (fabs(pimu) < EPS ? 1.0 : pimu/sin(pimu));
d = -log(x2);
e=xmu*d;
fact2 = (fabs(e) < EPS ? 1.0 : sinh(e)/e);
beschb(xmu,&gam1,&gam2,&gampl,&gammi);
ff=2.0/PI*fact*(gam1*cosh(e)+gam2*fact2*d);
e=exp(e);
p=e/(gampl*PI);
q=1.0/(e*PI*gammi);
pimu2=0.5*pimu;
fact3 = (fabs(pimu2) < EPS ? 1.0 : sin(pimu2)/pimu2);
r=PI*pimu2*fact3*fact3;
c=1.0;
d = -x2*x2;
sum=ff+r*q;
sum1=p;
for (i=1;i<=MAXIT;i++) {
ff=(i*ff+p+q)/(i*i-xmu2);
c *= (d/i);
p /= (i-xmu);
q /= (i+xmu);
del=c*(ff+r*q);
sum += del;
del1=c*p-i*del;
sum1 += del1;
if (fabs(del) < (1.0+fabs(sum))*EPS) break;
}
if (i > MAXIT) nrerror("bessy series failed to converge");
rymu = -sum;
ry1 = -sum1*xi2;
rymup=xmu*xi*rymu-ry1;
rjmu=w/(rymup-f*rymu);
} else {
a=0.25-xmu2;
p = -0.5*xi;
q=1.0;
br=2.0*x;
bi=2.0;
fact=a*xi/(p*p+q*q);
cr=br+q*fact;
ci=bi+p*fact;
den=br*br+bi*bi;
dr=br/den;
di = -bi/den;
dlr=cr*dr-ci*di;
dli=cr*di+ci*dr;
temp=p*dlr-q*dli;
q=p*dli+q*dlr;
p=temp;
for (i=2;i<=MAXIT;i++) {
a += 2*(i-1);
bi += 2.0;
dr=a*dr+br;
di=a*di+bi;
if (fabs(dr)+fabs(di) < FPMIN) dr=FPMIN;
fact=a/(cr*cr+ci*ci);
cr=br+cr*fact;
ci=bi-ci*fact;
if (fabs(cr)+fabs(ci) < FPMIN) cr=FPMIN;
den=dr*dr+di*di;
dr /= den;
di /= -den;
dlr=cr*dr-ci*di;
dli=cr*di+ci*dr;
temp=p*dlr-q*dli;
q=p*dli+q*dlr;
p=temp;
if (fabs(dlr-1.0)+fabs(dli) < EPS) break;
}
if (i > MAXIT) nrerror("cf2 failed in bessjy");
gam=(p-f)/q;
rjmu=sqrt(w/((p-f)*gam+q));
rjmu=SIGN(rjmu,rjl);
rymu=rjmu*gam;
rymup=rymu*(p+q/gam);
ry1=xmu*xi*rymu-rymup;
}
fact=rjmu/rjl;
*rj=rjl1*fact;
*rjp=rjp1*fact;
for (i=1;i<=nl;i++) {
rytemp=(xmu+i)*xi2*ry1-rymu;
rymu=ry1;
ry1=rytemp;
}
*ry=rymu;
*ryp=xnu*xi*rymu-ry1;
}
#undef EPS
#undef FPMIN
#undef MAXIT
#undef XMIN
#undef PI

21
lib/nr/k_and_r/recipes/bessk.c Normal file
View File

@@ -0,0 +1,21 @@
float bessk(n,x)
float x;
int n;
{
float bessk0(),bessk1();
void nrerror();
int j;
float bk,bkm,bkp,tox;
if (n < 2) nrerror("Index n less than 2 in bessk");
tox=2.0/x;
bkm=bessk0(x);
bk=bessk1(x);
for (j=1;j<n;j++) {
bkp=bkm+j*tox*bk;
bkm=bk;
bk=bkp;
}
return bk;
}

22
lib/nr/k_and_r/recipes/bessk0.c Normal file
View File

@@ -0,0 +1,22 @@
#include <math.h>
float bessk0(x)
float x;
{
float bessi0();
double y,ans;
if (x <= 2.0) {
y=x*x/4.0;
ans=(-log(x/2.0)*bessi0(x))+(-0.57721566+y*(0.42278420
+y*(0.23069756+y*(0.3488590e-1+y*(0.262698e-2
+y*(0.10750e-3+y*0.74e-5))))));
} else {
y=2.0/x;
ans=(exp(-x)/sqrt(x))*(1.25331414+y*(-0.7832358e-1
+y*(0.2189568e-1+y*(-0.1062446e-1+y*(0.587872e-2
+y*(-0.251540e-2+y*0.53208e-3))))));
}
return ans;
}

22
lib/nr/k_and_r/recipes/bessk1.c Normal file
View File

@@ -0,0 +1,22 @@
#include <math.h>
float bessk1(x)
float x;
{
float bessi1();
double y,ans;
if (x <= 2.0) {
y=x*x/4.0;
ans=(log(x/2.0)*bessi1(x))+(1.0/x)*(1.0+y*(0.15443144
+y*(-0.67278579+y*(-0.18156897+y*(-0.1919402e-1
+y*(-0.110404e-2+y*(-0.4686e-4)))))));
} else {
y=2.0/x;
ans=(exp(-x)/sqrt(x))*(1.25331414+y*(0.23498619
+y*(-0.3655620e-1+y*(0.1504268e-1+y*(-0.780353e-2
+y*(0.325614e-2+y*(-0.68245e-3)))))));
}
return ans;
}

21
lib/nr/k_and_r/recipes/bessy.c Normal file
View File

@@ -0,0 +1,21 @@
float bessy(n,x)
float x;
int n;
{
float bessy0(),bessy1();
void nrerror();
int j;
float by,bym,byp,tox;
if (n < 2) nrerror("Index n less than 2 in bessy");
tox=2.0/x;
by=bessy1(x);
bym=bessy0(x);
for (j=1;j<n;j++) {
byp=j*tox*by-bym;
bym=by;
by=byp;
}
return by;
}

30
lib/nr/k_and_r/recipes/bessy0.c Normal file
View File

@@ -0,0 +1,30 @@
#include <math.h>
float bessy0(x)
float x;
{
float bessj0();
float z;
double xx,y,ans,ans1,ans2;
if (x < 8.0) {
y=x*x;
ans1 = -2957821389.0+y*(7062834065.0+y*(-512359803.6
+y*(10879881.29+y*(-86327.92757+y*228.4622733))));
ans2=40076544269.0+y*(745249964.8+y*(7189466.438
+y*(47447.26470+y*(226.1030244+y*1.0))));
ans=(ans1/ans2)+0.636619772*bessj0(x)*log(x);
} else {
z=8.0/x;
y=z*z;
xx=x-0.785398164;
ans1=1.0+y*(-0.1098628627e-2+y*(0.2734510407e-4
+y*(-0.2073370639e-5+y*0.2093887211e-6)));
ans2 = -0.1562499995e-1+y*(0.1430488765e-3
+y*(-0.6911147651e-5+y*(0.7621095161e-6
+y*(-0.934945152e-7))));
ans=sqrt(0.636619772/x)*(sin(xx)*ans1+z*cos(xx)*ans2);
}
return ans;
}

32
lib/nr/k_and_r/recipes/bessy1.c Normal file
View File

@@ -0,0 +1,32 @@
#include <math.h>
float bessy1(x)
float x;
{
float bessj1();
float z;
double xx,y,ans,ans1,ans2;
if (x < 8.0) {
y=x*x;
ans1=x*(-0.4900604943e13+y*(0.1275274390e13
+y*(-0.5153438139e11+y*(0.7349264551e9
+y*(-0.4237922726e7+y*0.8511937935e4)))));
ans2=0.2499580570e14+y*(0.4244419664e12
+y*(0.3733650367e10+y*(0.2245904002e8
+y*(0.1020426050e6+y*(0.3549632885e3+y)))));
ans=(ans1/ans2)+0.636619772*(bessj1(x)*log(x)-1.0/x);
} else {
z=8.0/x;
y=z*z;
xx=x-2.356194491;
ans1=1.0+y*(0.183105e-2+y*(-0.3516396496e-4
+y*(0.2457520174e-5+y*(-0.240337019e-6))));
ans2=0.04687499995+y*(-0.2002690873e-3
+y*(0.8449199096e-5+y*(-0.88228987e-6
+y*0.105787412e-6)));
ans=sqrt(0.636619772/x)*(sin(xx)*ans1+z*cos(xx)*ans2);
}
return ans;
}

10
lib/nr/k_and_r/recipes/beta.c Normal file
View File

@@ -0,0 +1,10 @@
#include <math.h>
float beta(z,w)
float w,z;
{
float gammln();
return exp(gammln(z)+gammln(w)-gammln(z+w));
}

46
lib/nr/k_and_r/recipes/betacf.c Normal file
View File

@@ -0,0 +1,46 @@
#include <math.h>
#define MAXIT 100
#define EPS 3.0e-7
#define FPMIN 1.0e-30
float betacf(a,b,x)
float a,b,x;
{
void nrerror();
int m,m2;
float aa,c,d,del,h,qab,qam,qap;
qab=a+b;
qap=a+1.0;
qam=a-1.0;
c=1.0;
d=1.0-qab*x/qap;
if (fabs(d) < FPMIN) d=FPMIN;
d=1.0/d;
h=d;
for (m=1;m<=MAXIT;m++) {
m2=2*m;
aa=m*(b-m)*x/((qam+m2)*(a+m2));
d=1.0+aa*d;
if (fabs(d) < FPMIN) d=FPMIN;
c=1.0+aa/c;
if (fabs(c) < FPMIN) c=FPMIN;
d=1.0/d;
h *= d*c;
aa = -(a+m)*(qab+m)*x/((a+m2)*(qap+m2));
d=1.0+aa*d;
if (fabs(d) < FPMIN) d=FPMIN;
c=1.0+aa/c;
if (fabs(c) < FPMIN) c=FPMIN;
d=1.0/d;
del=d*c;
h *= del;
if (fabs(del-1.0) < EPS) break;
}
if (m > MAXIT) nrerror("a or b too big, or MAXIT too small in betacf");
return h;
}
#undef MAXIT
#undef EPS
#undef FPMIN

19
lib/nr/k_and_r/recipes/betai.c Normal file
View File

@@ -0,0 +1,19 @@
#include <math.h>
float betai(a,b,x)
float a,b,x;
{
float betacf(),gammln();
void nrerror();
float bt;
if (x < 0.0 || x > 1.0) nrerror("Bad x in routine betai");
if (x == 0.0 || x == 1.0) bt=0.0;
else
bt=exp(gammln(a+b)-gammln(a)-gammln(b)+a*log(x)+b*log(1.0-x));
if (x < (a+1.0)/(a+b+2.0))
return bt*betacf(a,b,x)/a;
else
return 1.0-bt*betacf(b,a,1.0-x)/b;
}

10
lib/nr/k_and_r/recipes/bico.c Normal file
View File

@@ -0,0 +1,10 @@
#include <math.h>
float bico(n,k)
int k,n;
{
float factln();
return floor(0.5+exp(factln(n)-factln(k)-factln(n-k)));
}

25
lib/nr/k_and_r/recipes/bksub.c Normal file
View File

@@ -0,0 +1,25 @@
void bksub(ne,nb,jf,k1,k2,c)
float ***c;
int jf,k1,k2,nb,ne;
{
int nbf,im,kp,k,j,i;
float xx;
nbf=ne-nb;
im=1;
for (k=k2;k>=k1;k--) {
if (k == k1) im=nbf+1;
kp=k+1;
for (j=1;j<=nbf;j++) {
xx=c[j][jf][kp];
for (i=im;i<=ne;i++)
c[i][jf][k] -= c[i][j][k]*xx;
}
}
for (k=k1;k<=k2;k++) {
kp=k+1;
for (i=1;i<=nb;i++) c[i][1][k]=c[i+nbf][jf][k];
for (i=1;i<=nbf;i++) c[i+nb][1][k]=c[i][jf][kp];
}
}

57
lib/nr/k_and_r/recipes/bnldev.c Normal file
View File

@@ -0,0 +1,57 @@
#include <math.h>
#define PI 3.141592654
float bnldev(pp,n,idum)
float pp;
int n;
long *idum;
{
float gammln(),ran1();
int j;
static int nold=(-1);
float am,em,g,angle,p,bnl,sq,t,y;
static float pold=(-1.0),pc,plog,pclog,en,oldg;
p=(pp <= 0.5 ? pp : 1.0-pp);
am=n*p;
if (n < 25) {
bnl=0.0;
for (j=1;j<=n;j++)
if (ran1(idum) < p) ++bnl;
} else if (am < 1.0) {
g=exp(-am);
t=1.0;
for (j=0;j<=n;j++) {
t *= ran1(idum);
if (t < g) break;
}
bnl=(j <= n ? j : n);
} else {
if (n != nold) {
en=n;
oldg=gammln(en+1.0);
nold=n;
} if (p != pold) {
pc=1.0-p;
plog=log(p);
pclog=log(pc);
pold=p;
}
sq=sqrt(2.0*am*pc);
do {
do {
angle=PI*ran1(idum);
y=tan(angle);
em=sq*y+am;
} while (em < 0.0 || em >= (en+1.0));
em=floor(em);
t=1.2*sq*(1.0+y*y)*exp(oldg-gammln(em+1.0)
-gammln(en-em+1.0)+em*plog+(en-em)*pclog);
} while (ran1(idum) > t);
bnl=em;
}
if (p != pp) bnl=n-bnl;
return bnl;
}
#undef PI

73
lib/nr/k_and_r/recipes/brent.c Normal file
View File

@@ -0,0 +1,73 @@
#include <math.h>
#include "nrutil.h"
#define ITMAX 100
#define CGOLD 0.3819660
#define ZEPS 1.0e-10
#define SHFT(a,b,c,d) (a)=(b);(b)=(c);(c)=(d);
float brent(ax,bx,cx,f,tol,xmin)
float (*f)(),*xmin,ax,bx,cx,tol;
{
int iter;
float a,b,d,etemp,fu,fv,fw,fx,p,q,r,tol1,tol2,u,v,w,x,xm;
float e=0.0;
a=(ax < cx ? ax : cx);
b=(ax > cx ? ax : cx);
x=w=v=bx;
fw=fv=fx=(*f)(x);
for (iter=1;iter<=ITMAX;iter++) {
xm=0.5*(a+b);
tol2=2.0*(tol1=tol*fabs(x)+ZEPS);
if (fabs(x-xm) <= (tol2-0.5*(b-a))) {
*xmin=x;
return fx;
}
if (fabs(e) > tol1) {
r=(x-w)*(fx-fv);
q=(x-v)*(fx-fw);
p=(x-v)*q-(x-w)*r;
q=2.0*(q-r);
if (q > 0.0) p = -p;
q=fabs(q);
etemp=e;
e=d;
if (fabs(p) >= fabs(0.5*q*etemp) || p <= q*(a-x) || p >= q*(b-x))
d=CGOLD*(e=(x >= xm ? a-x : b-x));
else {
d=p/q;
u=x+d;
if (u-a < tol2 || b-u < tol2)
d=SIGN(tol1,xm-x);
}
} else {
d=CGOLD*(e=(x >= xm ? a-x : b-x));
}
u=(fabs(d) >= tol1 ? x+d : x+SIGN(tol1,d));
fu=(*f)(u);
if (fu <= fx) {
if (u >= x) a=x; else b=x;
SHFT(v,w,x,u)
SHFT(fv,fw,fx,fu)
} else {
if (u < x) a=u; else b=u;
if (fu <= fw || w == x) {
v=w;
w=u;
fv=fw;
fw=fu;
} else if (fu <= fv || v == x || v == w) {
v=u;
fv=fu;
}
}
}
nrerror("Too many iterations in brent");
*xmin=x;
return fx;
}
#undef ITMAX
#undef CGOLD
#undef ZEPS
#undef SHFT

161
lib/nr/k_and_r/recipes/broydn.c Normal file
View File

@@ -0,0 +1,161 @@
#include <math.h>
#include "nrutil.h"
#define MAXITS 200
#define EPS 1.0e-7
#define TOLF 1.0e-4
#define TOLX EPS
#define STPMX 100.0
#define TOLMIN 1.0e-6
#define FREERETURN {free_vector(fvec,1,n);free_vector(xold,1,n);\
free_vector(w,1,n);free_vector(t,1,n);free_vector(s,1,n);\
free_matrix(r,1,n,1,n);free_matrix(qt,1,n,1,n);free_vector(p,1,n);\
free_vector(g,1,n);free_vector(fvcold,1,n);free_vector(d,1,n);\
free_vector(c,1,n);return;}
int nn;
float *fvec;
void (*nrfuncv)();
void broydn(x,n,check,vecfunc)
float x[];
int *check,n;
void (*vecfunc)();
{
float fmin();
void fdjac(),lnsrch(),qrdcmp(),qrupdt(),rsolv();
int i,its,j,k,restrt,sing,skip;
float den,f,fold,stpmax,sum,temp,test,*c,*d,*fvcold;
float *g,*p,**qt,**r,*s,*t,*w,*xold;
c=vector(1,n);
d=vector(1,n);
fvcold=vector(1,n);
g=vector(1,n);
p=vector(1,n);
qt=matrix(1,n,1,n);
r=matrix(1,n,1,n);
s=vector(1,n);
t=vector(1,n);
w=vector(1,n);
xold=vector(1,n);
fvec=vector(1,n);
nn=n;
nrfuncv=vecfunc;
f=fmin(x);
test=0.0;
for (i=1;i<=n;i++)
if (fabs(fvec[i]) > test)test=fabs(fvec[i]);
if (test < 0.01*TOLF) {
*check=0;
FREERETURN
}
for (sum=0.0,i=1;i<=n;i++) sum += SQR(x[i]);
stpmax=STPMX*FMAX(sqrt(sum),(float)n);
restrt=1;
for (its=1;its<=MAXITS;its++) {
if (restrt) {
fdjac(n,x,fvec,r,vecfunc);
qrdcmp(r,n,c,d,&sing);
if (sing) nrerror("singular Jacobian in broydn");
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) qt[i][j]=0.0;
qt[i][i]=1.0;
}
for (k=1;k<n;k++) {
if (c[k]) {
for (j=1;j<=n;j++) {
sum=0.0;
for (i=k;i<=n;i++)
sum += r[i][k]*qt[i][j];
sum /= c[k];
for (i=k;i<=n;i++)
qt[i][j] -= sum*r[i][k];
}
}
}
for (i=1;i<=n;i++) {
r[i][i]=d[i];
for (j=1;j<i;j++) r[i][j]=0.0;
}
} else {
for (i=1;i<=n;i++) s[i]=x[i]-xold[i];
for (i=1;i<=n;i++) {
for (sum=0.0,j=i;j<=n;j++) sum += r[i][j]*s[j];
t[i]=sum;
}
skip=1;
for (i=1;i<=n;i++) {
for (sum=0.0,j=1;j<=n;j++) sum += qt[j][i]*t[j];
w[i]=fvec[i]-fvcold[i]-sum;
if (fabs(w[i]) >= EPS*(fabs(fvec[i])+fabs(fvcold[i]))) skip=0;
else w[i]=0.0;
}
if (!skip) {
for (i=1;i<=n;i++) {
for (sum=0.0,j=1;j<=n;j++) sum += qt[i][j]*w[j];
t[i]=sum;
}
for (den=0.0,i=1;i<=n;i++) den += SQR(s[i]);
for (i=1;i<=n;i++) s[i] /= den;
qrupdt(r,qt,n,t,s);
for (i=1;i<=n;i++) {
if (r[i][i] == 0.0) nrerror("r singular in broydn");
d[i]=r[i][i];
}
}
}
for (i=1;i<=n;i++) {
for (sum=0.0,j=1;j<=n;j++) sum += qt[i][j]*fvec[j];
p[i] = -sum;
}
for (i=n;i>=1;i--) {
for (sum=0.0,j=1;j<=i;j++) sum -= r[j][i]*p[j];
g[i]=sum;
}
for (i=1;i<=n;i++) {
xold[i]=x[i];
fvcold[i]=fvec[i];
}
fold=f;
rsolv(r,n,d,p);
lnsrch(n,xold,fold,g,p,x,&f,stpmax,check,fmin);
test=0.0;
for (i=1;i<=n;i++)
if (fabs(fvec[i]) > test) test=fabs(fvec[i]);
if (test < TOLF) {
*check=0;
FREERETURN
}
if (*check) {
if (restrt) FREERETURN
else {
test=0.0;
den=FMAX(f,0.5*n);
for (i=1;i<=n;i++) {
temp=fabs(g[i])*FMAX(fabs(x[i]),1.0)/den;
if (temp > test) test=temp;
}
if (test < TOLMIN) FREERETURN
else restrt=1;
}
} else {
restrt=0;
test=0.0;
for (i=1;i<=n;i++) {
temp=(fabs(x[i]-xold[i]))/FMAX(fabs(x[i]),1.0);
if (temp > test) test=temp;
}
if (test < TOLX) FREERETURN
}
}
nrerror("MAXITS exceeded in broydn");
FREERETURN
}
#undef MAXITS
#undef EPS
#undef TOLF
#undef TOLMIN
#undef TOLX
#undef STPMX
#undef FREERETURN

137
lib/nr/k_and_r/recipes/bsstep.c Normal file
View File

@@ -0,0 +1,137 @@
#include <math.h>
#include "nrutil.h"
#define KMAXX 8
#define IMAXX (KMAXX+1)
#define SAFE1 0.25
#define SAFE2 0.7
#define REDMAX 1.0e-5
#define REDMIN 0.7
#define TINY 1.0e-30
#define SCALMX 0.1
float **d,*x;
void bsstep(y,dydx,nv,xx,htry,eps,yscal,hdid,hnext,derivs)
float *hdid,*hnext,*xx,dydx[],eps,htry,y[],yscal[];
int nv;
void (*derivs)();
{
void mmid(),pzextr();
int i,iq,k,kk,km;
static int first=1,kmax,kopt;
static float epsold = -1.0,xnew;
float eps1,errmax,fact,h,red,scale,work,wrkmin,xest;
float *err,*yerr,*ysav,*yseq;
static float a[IMAXX+1];
static float alf[KMAXX+1][KMAXX+1];
static int nseq[IMAXX+1]={0,2,4,6,8,10,12,14,16,18};
int reduct,exitflag=0;
d=matrix(1,nv,1,KMAXX);
err=vector(1,KMAXX);
x=vector(1,KMAXX);
yerr=vector(1,nv);
ysav=vector(1,nv);
yseq=vector(1,nv);
if (eps != epsold) {
*hnext = xnew = -1.0e29;
eps1=SAFE1*eps;
a[1]=nseq[1]+1;
for (k=1;k<=KMAXX;k++) a[k+1]=a[k]+nseq[k+1];
for (iq=2;iq<=KMAXX;iq++) {
for (k=1;k<iq;k++)
alf[k][iq]=pow(eps1,(a[k+1]-a[iq+1])/
((a[iq+1]-a[1]+1.0)*(2*k+1)));
}
epsold=eps;
for (kopt=2;kopt<KMAXX;kopt++)
if (a[kopt+1] > a[kopt]*alf[kopt-1][kopt]) break;
kmax=kopt;
}
h=htry;
for (i=1;i<=nv;i++) ysav[i]=y[i];
if (*xx != xnew || h != (*hnext)) {
first=1;
kopt=kmax;
}
reduct=0;
for (;;) {
for (k=1;k<=kmax;k++) {
xnew=(*xx)+h;
if (xnew == (*xx)) nrerror("step size underflow in bsstep");
mmid(ysav,dydx,nv,*xx,h,nseq[k],yseq,derivs);
xest=SQR(h/nseq[k]);
pzextr(k,xest,yseq,y,yerr,nv);
if (k != 1) {
errmax=TINY;
for (i=1;i<=nv;i++) errmax=FMAX(errmax,fabs(yerr[i]/yscal[i]));
errmax /= eps;
km=k-1;
err[km]=pow(errmax/SAFE1,1.0/(2*km+1));
}
if (k != 1 && (k >= kopt-1 || first)) {
if (errmax < 1.0) {
exitflag=1;
break;
}
if (k == kmax || k == kopt+1) {
red=SAFE2/err[km];
break;
}
else if (k == kopt && alf[kopt-1][kopt] < err[km]) {
red=1.0/err[km];
break;
}
else if (kopt == kmax && alf[km][kmax-1] < err[km]) {
red=alf[km][kmax-1]*SAFE2/err[km];
break;
}
else if (alf[km][kopt] < err[km]) {
red=alf[km][kopt-1]/err[km];
break;
}
}
}
if (exitflag) break;
red=FMIN(red,REDMIN);
red=FMAX(red,REDMAX);
h *= red;
reduct=1;
}
*xx=xnew;
*hdid=h;
first=0;
wrkmin=1.0e35;
for (kk=1;kk<=km;kk++) {
fact=FMAX(err[kk],SCALMX);
work=fact*a[kk+1];
if (work < wrkmin) {
scale=fact;
wrkmin=work;
kopt=kk+1;
}
}
*hnext=h/scale;
if (kopt >= k && kopt != kmax && !reduct) {
fact=FMAX(scale/alf[kopt-1][kopt],SCALMX);
if (a[kopt+1]*fact <= wrkmin) {
*hnext=h/fact;
kopt++;
}
}
free_vector(yseq,1,nv);
free_vector(ysav,1,nv);
free_vector(yerr,1,nv);
free_vector(x,1,KMAXX);
free_vector(err,1,KMAXX);
free_matrix(d,1,nv,1,KMAXX);
}
#undef KMAXX
#undef IMAXX
#undef SAFE1
#undef SAFE2
#undef REDMAX
#undef REDMIN
#undef TINY
#undef SCALMX

30
lib/nr/k_and_r/recipes/caldat.c Normal file
View File

@@ -0,0 +1,30 @@
#include <math.h>
#define IGREG 2299161
void caldat(julian,mm,id,iyyy)
int *id,*iyyy,*mm;
long julian;
{
long ja,jalpha,jb,jc,jd,je;
if (julian >= IGREG) {
jalpha=(long)(((double) (julian-1867216)-0.25)/36524.25);
ja=julian+1+jalpha-(long) (0.25*jalpha);
} else if (julian < 0) {
ja=julian+36525*(1-julian/36525);
} else
ja=julian;
jb=ja+1524;
jc=(long)(6680.0+((double) (jb-2439870)-122.1)/365.25);
jd=(long)(365*jc+(0.25*jc));
je=(long)((jb-jd)/30.6001);
*id=jb-jd-(long) (30.6001*je);
*mm=je-1;
if (*mm > 12) *mm -= 12;
*iyyy=jc-4715;
if (*mm > 2) --(*iyyy);
if (*iyyy <= 0) --(*iyyy);
if (julian < 0) *iyyy -= 100*(1-julian/36525);
}
#undef IGREG

16
lib/nr/k_and_r/recipes/chder.c Normal file
View File

@@ -0,0 +1,16 @@
void chder(a,b,c,cder,n)
float a,b,c[],cder[];
int n;
{
int j;
float con;
cder[n-1]=0.0;
cder[n-2]=2*(n-1)*c[n-1];
for (j=n-3;j>=0;j--)
cder[j]=cder[j+2]+2*(j+1)*c[j+1];
con=2.0/(b-a);
for (j=0;j<n;j++)
cder[j] *= con;
}

18
lib/nr/k_and_r/recipes/chebev.c Normal file
View File

@@ -0,0 +1,18 @@
float chebev(a,b,c,m,x)
float a,b,c[],x;
int m;
{
void nrerror();
float d=0.0,dd=0.0,sv,y,y2;
int j;
if ((x-a)*(x-b) > 0.0) nrerror("x not in range in routine chebev");
y2=2.0*(y=(2.0*x-a-b)/(b-a));
for (j=m-1;j>=1;j--) {
sv=d;
d=y2*d-dd+c[j];
dd=sv;
}
return y*d-dd+0.5*c[0];
}

29
lib/nr/k_and_r/recipes/chebft.c Normal file
View File

@@ -0,0 +1,29 @@
#include <math.h>
#include "nrutil.h"
#define PI 3.141592653589793
void chebft(a,b,c,n,func)
float (*func)(),a,b,c[];
int n;
{
int k,j;
float fac,bpa,bma,*f;
f=vector(0,n-1);
bma=0.5*(b-a);
bpa=0.5*(b+a);
for (k=0;k<n;k++) {
float y=cos(PI*(k+0.5)/n);
f[k]=(*func)(y*bma+bpa);
}
fac=2.0/n;
for (j=0;j<n;j++) {
double sum=0.0;
for (k=0;k<n;k++)
sum += f[k]*cos(PI*j*(k+0.5)/n);
c[j]=fac*sum;
}
free_vector(f,0,n-1);
}
#undef PI

28
lib/nr/k_and_r/recipes/chebpc.c Normal file
View File

@@ -0,0 +1,28 @@
#include "nrutil.h"
void chebpc(c,d,n)
float c[],d[];
int n;
{
int k,j;
float sv,*dd;
dd=vector(0,n-1);
for (j=0;j<n;j++) d[j]=dd[j]=0.0;
d[0]=c[n-1];
for (j=n-2;j>=1;j--) {
for (k=n-j;k>=1;k--) {
sv=d[k];
d[k]=2.0*d[k-1]-dd[k];
dd[k]=sv;
}
sv=d[0];
d[0] = -dd[0]+c[j];
dd[0]=sv;
}
for (j=n-1;j>=1;j--)
d[j]=d[j-1]-dd[j];
d[0] = -dd[0]+0.5*c[0];
free_vector(dd,0,n-1);
}

18
lib/nr/k_and_r/recipes/chint.c Normal file
View File

@@ -0,0 +1,18 @@
void chint(a,b,c,cint,n)
float a,b,c[],cint[];
int n;
{
int j;
float sum=0.0,fac=1.0,con;
con=0.25*(b-a);
for (j=1;j<=n-2;j++) {
cint[j]=con*(c[j-1]-c[j+1])/j;
sum += fac*cint[j];
fac = -fac;
}
cint[n-1]=con*c[n-2]/(n-1);
sum += fac*cint[n-1];
cint[0]=2.0*sum;
}

29
lib/nr/k_and_r/recipes/chixy.c Normal file
View File

@@ -0,0 +1,29 @@
#include <math.h>
#include "nrutil.h"
#define BIG 1.0e30
extern int nn;
extern float *xx,*yy,*sx,*sy,*ww,aa,offs;
float chixy(bang)
float bang;
{
int j;
float ans,avex=0.0,avey=0.0,sumw=0.0,b;
b=tan(bang);
for (j=1;j<=nn;j++) {
ww[j] = SQR(b*sx[j])+SQR(sy[j]);
sumw += (ww[j] = (ww[j] < 1.0/BIG ? BIG : 1.0/ww[j]));
avex += ww[j]*xx[j];
avey += ww[j]*yy[j];
}
avex /= sumw;
avey /= sumw;
aa=avey-b*avex;
for (ans = -offs,j=1;j<=nn;j++)
ans += ww[j]*SQR(yy[j]-aa-b*xx[j]);
return ans;
}
#undef BIG

22
lib/nr/k_and_r/recipes/choldc.c Normal file
View File

@@ -0,0 +1,22 @@
#include <math.h>
void choldc(a,n,p)
float **a,p[];
int n;
{
void nrerror();
int i,j,k;
float sum;
for (i=1;i<=n;i++) {
for (j=i;j<=n;j++) {
for (sum=a[i][j],k=i-1;k>=1;k--) sum -= a[i][k]*a[j][k];
if (i == j) {
if (sum <= 0.0)
nrerror("choldc failed");
p[i]=sqrt(sum);
} else a[j][i]=sum/p[i];
}
}
}

17
lib/nr/k_and_r/recipes/cholsl.c Normal file
View File

@@ -0,0 +1,17 @@
void cholsl(a,n,p,b,x)
float **a,b[],p[],x[];
int n;
{
int i,k;
float sum;
for (i=1;i<=n;i++) {
for (sum=b[i],k=i-1;k>=1;k--) sum -= a[i][k]*x[k];
x[i]=sum/p[i];
}
for (i=n;i>=1;i--) {
for (sum=x[i],k=i+1;k<=n;k++) sum -= a[k][i]*x[k];
x[i]=sum/p[i];
}
}

19
lib/nr/k_and_r/recipes/chsone.c Normal file
View File

@@ -0,0 +1,19 @@
void chsone(bins,ebins,nbins,knstrn,df,chsq,prob)
float *chsq,*df,*prob,bins[],ebins[];
int knstrn,nbins;
{
float gammq();
void nrerror();
int j;
float temp;
*df=nbins-knstrn;
*chsq=0.0;
for (j=1;j<=nbins;j++) {
if (ebins[j] <= 0.0) nrerror("Bad expected number in chsone");
temp=bins[j]-ebins[j];
*chsq += temp*temp/ebins[j];
}
*prob=gammq(0.5*(*df),0.5*(*chsq));
}

20
lib/nr/k_and_r/recipes/chstwo.c Normal file
View File

@@ -0,0 +1,20 @@
void chstwo(bins1,bins2,nbins,knstrn,df,chsq,prob)
float *chsq,*df,*prob,bins1[],bins2[];
int knstrn,nbins;
{
float gammq();
int j;
float temp;
*df=nbins-knstrn;
*chsq=0.0;
for (j=1;j<=nbins;j++)
if (bins1[j] == 0.0 && bins2[j] == 0.0)
--(*df);
else {
temp=bins1[j]-bins2[j];
*chsq += temp*temp/(bins1[j]+bins2[j]);
}
*prob=gammq(0.5*(*df),0.5*(*chsq));
}

82
lib/nr/k_and_r/recipes/cisi.c Normal file
View File

@@ -0,0 +1,82 @@
#include <math.h>
#include "complex.h"
#define EPS 6.0e-8
#define EULER 0.57721566
#define MAXIT 100
#define PIBY2 1.5707963
#define FPMIN 1.0e-30
#define TMIN 2.0
#define TRUE 1
#define ONE Complex(1.0,0.0)
void cisi(x,ci,si)
float *ci,*si,x;
{
void nrerror();
int i,k,odd;
float a,err,fact,sign,sum,sumc,sums,t,term;
fcomplex h,b,c,d,del;
t=fabs(x);
if (t == 0.0) {
*si=0.0;
*ci = -1.0/FPMIN;
return;
}
if (t > TMIN) {
b=Complex(1.0,t);
c=Complex(1.0/FPMIN,0.0);
d=h=Cdiv(ONE,b);
for (i=2;i<=MAXIT;i++) {
a = -(i-1)*(i-1);
b=Cadd(b,Complex(2.0,0.0));
d=Cdiv(ONE,Cadd(RCmul(a,d),b));
c=Cadd(b,Cdiv(Complex(a,0.0),c));
del=Cmul(c,d);
h=Cmul(h,del);
if (fabs(del.r-1.0)+fabs(del.i) < EPS) break;
}
if (i > MAXIT) nrerror("cf failed in cisi");
h=Cmul(Complex(cos(t),-sin(t)),h);
*ci = -h.r;
*si=PIBY2+h.i;
} else {
if (t < sqrt(FPMIN)) {
sumc=0.0;
sums=t;
} else {
sum=sums=sumc=0.0;
sign=fact=1.0;
odd=TRUE;
for (k=1;k<=MAXIT;k++) {
fact *= t/k;
term=fact/k;
sum += sign*term;
err=term/fabs(sum);
if (odd) {
sign = -sign;
sums=sum;
sum=sumc;
} else {
sumc=sum;
sum=sums;
}
if (err < EPS) break;
odd=!odd;
}
if (k > MAXIT) nrerror("maxits exceeded in cisi");
}
*si=sums;
*ci=sumc+log(t)+EULER;
}
if (x < 0.0) *si = -(*si);
}
#undef EPS
#undef EULER
#undef MAXIT
#undef PIBY2
#undef FPMIN
#undef TMIN
#undef TRUE
#undef ONE

47
lib/nr/k_and_r/recipes/cntab1.c Normal file
View File

@@ -0,0 +1,47 @@
#include <math.h>
#include "nrutil.h"
#define TINY 1.0e-30
void cntab1(nn,ni,nj,chisq,df,prob,cramrv,ccc)
float *ccc,*chisq,*cramrv,*df,*prob;
int **nn,ni,nj;
{
float gammq();
int nnj,nni,j,i,minij;
float sum=0.0,expctd,*sumi,*sumj,temp;
sumi=vector(1,ni);
sumj=vector(1,nj);
nni=ni;
nnj=nj;
for (i=1;i<=ni;i++) {
sumi[i]=0.0;
for (j=1;j<=nj;j++) {
sumi[i] += nn[i][j];
sum += nn[i][j];
}
if (sumi[i] == 0.0) --nni;
}
for (j=1;j<=nj;j++) {
sumj[j]=0.0;
for (i=1;i<=ni;i++) sumj[j] += nn[i][j];
if (sumj[j] == 0.0) --nnj;
}
*df=nni*nnj-nni-nnj+1;
*chisq=0.0;
for (i=1;i<=ni;i++) {
for (j=1;j<=nj;j++) {
expctd=sumj[j]*sumi[i]/sum;
temp=nn[i][j]-expctd;
*chisq += temp*temp/(expctd+TINY);
}
}
*prob=gammq(0.5*(*df),0.5*(*chisq));
minij = nni < nnj ? nni-1 : nnj-1;
*cramrv=sqrt(*chisq/(sum*minij));
*ccc=sqrt(*chisq/(*chisq+sum));
free_vector(sumj,1,nj);
free_vector(sumi,1,ni);
}
#undef TINY

54
lib/nr/k_and_r/recipes/cntab2.c Normal file
View File

@@ -0,0 +1,54 @@
#include <math.h>
#include "nrutil.h"
#define TINY 1.0e-30
void cntab2(nn,ni,nj,h,hx,hy,hygx,hxgy,uygx,uxgy,uxy)
float *h,*hx,*hxgy,*hy,*hygx,*uxgy,*uxy,*uygx;
int **nn,ni,nj;
{
int i,j;
float sum=0.0,p,*sumi,*sumj;
sumi=vector(1,ni);
sumj=vector(1,nj);
for (i=1;i<=ni;i++) {
sumi[i]=0.0;
for (j=1;j<=nj;j++) {
sumi[i] += nn[i][j];
sum += nn[i][j];
}
}
for (j=1;j<=nj;j++) {
sumj[j]=0.0;
for (i=1;i<=ni;i++)
sumj[j] += nn[i][j];
}
*hx=0.0;
for (i=1;i<=ni;i++)
if (sumi[i]) {
p=sumi[i]/sum;
*hx -= p*log(p);
}
*hy=0.0;
for (j=1;j<=nj;j++)
if (sumj[j]) {
p=sumj[j]/sum;
*hy -= p*log(p);
}
*h=0.0;
for (i=1;i<=ni;i++)
for (j=1;j<=nj;j++)
if (nn[i][j]) {
p=nn[i][j]/sum;
*h -= p*log(p);
}
*hygx=(*h)-(*hx);
*hxgy=(*h)-(*hy);
*uygx=(*hy-*hygx)/(*hy+TINY);
*uxgy=(*hx-*hxgy)/(*hx+TINY);
*uxy=2.0*(*hx+*hy-*h)/(*hx+*hy+TINY);
free_vector(sumj,1,nj);
free_vector(sumi,1,ni);
}
#undef TINY

135
lib/nr/k_and_r/recipes/complex.c Normal file
View File

@@ -0,0 +1,135 @@
/* CAUTION: This is the traditional K&R C (only) version of the Numerical
Recipes utility file complex.c. Do not confuse this file with the
same-named file complex.c that is supplied in the same subdirectory or
archive as the header file complex.h. *That* file contains both ANSI and
traditional K&R versions, along with #ifdef macros to select the
correct version. *This* file contains only traditional K&R. */
#include <math.h>
typedef struct FCOMPLEX {float r,i;} fcomplex;
fcomplex Cadd(a,b)
fcomplex a,b;
{
fcomplex c;
c.r=a.r+b.r;
c.i=a.i+b.i;
return c;
}
fcomplex Csub(a,b)
fcomplex a,b;
{
fcomplex c;
c.r=a.r-b.r;
c.i=a.i-b.i;
return c;
}
fcomplex Cmul(a,b)
fcomplex a,b;
{
fcomplex c;
c.r=a.r*b.r-a.i*b.i;
c.i=a.i*b.r+a.r*b.i;
return c;
}
fcomplex Complex(re,im)
float im,re;
{
fcomplex c;
c.r=re;
c.i=im;
return c;
}
fcomplex Conjg(z)
fcomplex z;
{
fcomplex c;
c.r=z.r;
c.i = -z.i;
return c;
}
fcomplex Cdiv(a,b)
fcomplex a,b;
{
fcomplex c;
float r,den;
if (fabs(b.r) >= fabs(b.i)) {
r=b.i/b.r;
den=b.r+r*b.i;
c.r=(a.r+r*a.i)/den;
c.i=(a.i-r*a.r)/den;
} else {
r=b.r/b.i;
den=b.i+r*b.r;
c.r=(a.r*r+a.i)/den;
c.i=(a.i*r-a.r)/den;
}
return c;
}
float Cabs(z)
fcomplex z;
{
float x,y,ans,temp;
x=fabs(z.r);
y=fabs(z.i);
if (x == 0.0)
ans=y;
else if (y == 0.0)
ans=x;
else if (x > y) {
temp=y/x;
ans=x*sqrt(1.0+temp*temp);
} else {
temp=x/y;
ans=y*sqrt(1.0+temp*temp);
}
return ans;
}
fcomplex Csqrt(z)
fcomplex z;
{
fcomplex c;
float x,y,w,r;
if ((z.r == 0.0) && (z.i == 0.0)) {
c.r=0.0;
c.i=0.0;
return c;
} else {
x=fabs(z.r);
y=fabs(z.i);
if (x >= y) {
r=y/x;
w=sqrt(x)*sqrt(0.5*(1.0+sqrt(1.0+r*r)));
} else {
r=x/y;
w=sqrt(y)*sqrt(0.5*(r+sqrt(1.0+r*r)));
}
if (z.r >= 0.0) {
c.r=w;
c.i=z.i/(2.0*w);
} else {
c.i=(z.i >= 0) ? w : -w;
c.r=z.i/(2.0*c.i);
}
return c;
}
}
fcomplex RCmul(x,a)
fcomplex a;
float x;
{
fcomplex c;
c.r=x*a.r;
c.i=x*a.i;
return c;
}

34
lib/nr/k_and_r/recipes/convlv.c Normal file
View File

@@ -0,0 +1,34 @@
#include "nrutil.h"
void convlv(data,n,respns,m,isign,ans)
float ans[],data[],respns[];
int isign;
unsigned long m,n;
{
void realft(),twofft();
unsigned long i,no2;
float dum,mag2,*fft;
fft=vector(1,n<<1);
for (i=1;i<=(m-1)/2;i++)
respns[n+1-i]=respns[m+1-i];
for (i=(m+3)/2;i<=n-(m-1)/2;i++)
respns[i]=0.0;
twofft(data,respns,fft,ans,n);
no2=n>>1;
for (i=2;i<=n+2;i+=2) {
if (isign == 1) {
ans[i-1]=(fft[i-1]*(dum=ans[i-1])-fft[i]*ans[i])/no2;
ans[i]=(fft[i]*dum+fft[i-1]*ans[i])/no2;
} else if (isign == -1) {
if ((mag2=SQR(ans[i-1])+SQR(ans[i])) == 0.0)
nrerror("Deconvolving at response zero in convlv");
ans[i-1]=(fft[i-1]*(dum=ans[i-1])+fft[i]*ans[i])/mag2/no2;
ans[i]=(fft[i]*dum-fft[i-1]*ans[i])/mag2/no2;
} else nrerror("No meaning for isign in convlv");
}
ans[2]=ans[n+1];
realft(ans,n,-1);
free_vector(fft,1,n<<1);
}

11
lib/nr/k_and_r/recipes/copy.c Normal file
View File

@@ -0,0 +1,11 @@
void copy(aout,ain,n)
double **ain,**aout;
int n;
{
int i,j;
for (i=1;i<=n;i++)
for (j=1;j<=n;j++)
aout[j][i]=ain[j][i];
}

22
lib/nr/k_and_r/recipes/correl.c Normal file
View File

@@ -0,0 +1,22 @@
#include "nrutil.h"
void correl(data1,data2,n,ans)
float ans[],data1[],data2[];
unsigned long n;
{
void realft(),twofft();
unsigned long no2,i;
float dum,*fft;
fft=vector(1,n<<1);
twofft(data1,data2,fft,ans,n);
no2=n>>1;
for (i=2;i<=n+2;i+=2) {
ans[i-1]=(fft[i-1]*(dum=ans[i-1])+fft[i]*ans[i])/no2;
ans[i]=(fft[i]*dum-fft[i-1]*ans[i])/no2;
}
ans[2]=ans[n+1];
realft(ans,n,-1);
free_vector(fft,1,n<<1);
}

38
lib/nr/k_and_r/recipes/cosft1.c Normal file
View File

@@ -0,0 +1,38 @@
#include <math.h>
#define PI 3.141592653589793
void cosft1(y,n)
float y[];
int n;
{
void realft();
int j,n2;
float sum,y1,y2;
double theta,wi=0.0,wpi,wpr,wr=1.0,wtemp;
theta=PI/n;
wtemp=sin(0.5*theta);
wpr = -2.0*wtemp*wtemp;
wpi=sin(theta);
sum=0.5*(y[1]-y[n+1]);
y[1]=0.5*(y[1]+y[n+1]);
n2=n+2;
for (j=2;j<=(n>>1);j++) {
wr=(wtemp=wr)*wpr-wi*wpi+wr;
wi=wi*wpr+wtemp*wpi+wi;
y1=0.5*(y[j]+y[n2-j]);
y2=(y[j]-y[n2-j]);
y[j]=y1-wi*y2;
y[n2-j]=y1+wi*y2;
sum += wr*y2;
}
realft(y,n,1);
y[n+1]=y[2];
y[2]=sum;
for (j=4;j<=n;j+=2) {
sum += y[j];
y[j]=sum;
}
}
#undef PI

66
lib/nr/k_and_r/recipes/cosft2.c Normal file
View File

@@ -0,0 +1,66 @@
#include <math.h>
#define PI 3.141592653589793
void cosft2(y,n,isign)
float y[];
int isign,n;
{
void realft();
int i;
float sum,sum1,y1,y2,ytemp;
double theta,wi=0.0,wi1,wpi,wpr,wr=1.0,wr1,wtemp;
theta=0.5*PI/n;
wr1=cos(theta);
wi1=sin(theta);
wpr = -2.0*wi1*wi1;
wpi=sin(2.0*theta);
if (isign == 1) {
for (i=1;i<=n/2;i++) {
y1=0.5*(y[i]+y[n-i+1]);
y2=wi1*(y[i]-y[n-i+1]);
y[i]=y1+y2;
y[n-i+1]=y1-y2;
wr1=(wtemp=wr1)*wpr-wi1*wpi+wr1;
wi1=wi1*wpr+wtemp*wpi+wi1;
}
realft(y,n,1);
for (i=3;i<=n;i+=2) {
wr=(wtemp=wr)*wpr-wi*wpi+wr;
wi=wi*wpr+wtemp*wpi+wi;
y1=y[i]*wr-y[i+1]*wi;
y2=y[i+1]*wr+y[i]*wi;
y[i]=y1;
y[i+1]=y2;
}
sum=0.5*y[2];
for (i=n;i>=2;i-=2) {
sum1=sum;
sum += y[i];
y[i]=sum1;
}
} else if (isign == -1) {
ytemp=y[n];
for (i=n;i>=4;i-=2) y[i]=y[i-2]-y[i];
y[2]=2.0*ytemp;
for (i=3;i<=n;i+=2) {
wr=(wtemp=wr)*wpr-wi*wpi+wr;
wi=wi*wpr+wtemp*wpi+wi;
y1=y[i]*wr+y[i+1]*wi;
y2=y[i+1]*wr-y[i]*wi;
y[i]=y1;
y[i+1]=y2;
}
realft(y,n,-1);
for (i=1;i<=n/2;i++) {
y1=y[i]+y[n-i+1];
y2=(0.5/wi1)*(y[i]-y[n-i+1]);
y[i]=0.5*(y1+y2);
y[n-i+1]=0.5*(y1-y2);
wr1=(wtemp=wr1)*wpr-wi1*wpi+wr1;
wi1=wi1*wpr+wtemp*wpi+wi1;
}
}
}
#undef PI

22
lib/nr/k_and_r/recipes/covsrt.c Normal file
View File

@@ -0,0 +1,22 @@
#define SWAP(a,b) {swap=(a);(a)=(b);(b)=swap;}
void covsrt(covar,ma,ia,mfit)
float **covar;
int ia[],ma,mfit;
{
int i,j,k;
float swap;
for (i=mfit+1;i<=ma;i++)
for (j=1;j<=i;j++) covar[i][j]=covar[j][i]=0.0;
k=mfit;
for (j=ma;j>=1;j--) {
if (ia[j]) {
for (i=1;i<=ma;i++) SWAP(covar[i][k],covar[i][j])
for (i=1;i<=ma;i++) SWAP(covar[k][i],covar[j][i])
k--;
}
}
}
#undef SWAP

24
lib/nr/k_and_r/recipes/crank.c Normal file
View File

@@ -0,0 +1,24 @@
void crank(n,w,s)
float *s,w[];
unsigned long n;
{
unsigned long j=1,ji,jt;
float t,rank;
*s=0.0;
while (j < n) {
if (w[j+1] != w[j]) {
w[j]=j;
++j;
} else {
for (jt=j+1;jt<=n && w[jt]==w[j];jt++);
rank=0.5*(j+jt-1);
for (ji=j;ji<=(jt-1);ji++) w[ji]=rank;
t=jt-j;
*s += t*t*t-t;
j=jt;
}
}
if (j == n) w[n]=n;
}

31
lib/nr/k_and_r/recipes/cyclic.c Normal file
View File

@@ -0,0 +1,31 @@
#include "nrutil.h"
void cyclic(a,b,c,alpha,beta,r,x,n)
float a[],alpha,b[],beta,c[],r[],x[];
unsigned long n;
{
void tridag();
unsigned long i;
float fact,gamma,*bb,*u,*z;
if (n <= 2) nrerror("n too small in cyclic");
bb=vector(1,n);
u=vector(1,n);
z=vector(1,n);
gamma = -b[1];
bb[1]=b[1]-gamma;
bb[n]=b[n]-alpha*beta/gamma;
for (i=2;i<n;i++) bb[i]=b[i];
tridag(a,bb,c,r,x,n);
u[1]=gamma;
u[n]=alpha;
for (i=2;i<n;i++) u[i]=0.0;
tridag(a,bb,c,u,z,n);
fact=(x[1]+beta*x[n]/gamma)/
(1.0+z[1]+beta*z[n]/gamma);
for (i=1;i<=n;i++) x[i] -= fact*z[i];
free_vector(z,1,n);
free_vector(u,1,n);
free_vector(bb,1,n);
}

40
lib/nr/k_and_r/recipes/daub4.c Normal file
View File

@@ -0,0 +1,40 @@
#include "nrutil.h"
#define C0 0.4829629131445341
#define C1 0.8365163037378079
#define C2 0.2241438680420134
#define C3 -0.1294095225512604
void daub4(a,n,isign)
float a[];
int isign;
unsigned long n;
{
float *wksp;
unsigned long nh,nh1,i,j;
if (n < 4) return;
wksp=vector(1,n);
nh1=(nh=n >> 1)+1;
if (isign >= 0) {
for (i=1,j=1;j<=n-3;j+=2,i++) {
wksp[i]=C0*a[j]+C1*a[j+1]+C2*a[j+2]+C3*a[j+3];
wksp[i+nh] = C3*a[j]-C2*a[j+1]+C1*a[j+2]-C0*a[j+3];
}
wksp[i]=C0*a[n-1]+C1*a[n]+C2*a[1]+C3*a[2];
wksp[i+nh] = C3*a[n-1]-C2*a[n]+C1*a[1]-C0*a[2];
} else {
wksp[1]=C2*a[nh]+C1*a[n]+C0*a[1]+C3*a[nh1];
wksp[2] = C3*a[nh]-C0*a[n]+C1*a[1]-C2*a[nh1];
for (i=1,j=3;i<nh;i++) {
wksp[j++]=C2*a[i]+C1*a[i+nh]+C0*a[i+1]+C3*a[i+nh1];
wksp[j++] = C3*a[i]-C0*a[i+nh]+C1*a[i+1]-C2*a[i+nh1];
}
}
for (i=1;i<=n;i++) a[i]=wksp[i];
free_vector(wksp,1,n);
}
#undef C0
#undef C1
#undef C2
#undef C3

44
lib/nr/k_and_r/recipes/dawson.c Normal file
View File

@@ -0,0 +1,44 @@
#include <math.h>
#include "nrutil.h"
#define NMAX 6
#define H 0.4
#define A1 (2.0/3.0)
#define A2 0.4
#define A3 (2.0/7.0)
float dawson(x)
float x;
{
int i,n0;
float d1,d2,e1,e2,sum,x2,xp,xx,ans;
static float c[NMAX+1];
static int init = 0;
if (init == 0) {
init=1;
for (i=1;i<=NMAX;i++) c[i]=exp(-SQR((2.0*i-1.0)*H));
}
if (fabs(x) < 0.2) {
x2=x*x;
ans=x*(1.0-A1*x2*(1.0-A2*x2*(1.0-A3*x2)));
} else {
xx=fabs(x);
n0=2*(int)(0.5*xx/H+0.5);
xp=xx-n0*H;
e1=exp(2.0*xp*H);
e2=e1*e1;
d1=n0+1;
d2=d1-2.0;
sum=0.0;
for (i=1;i<=NMAX;i++,d1+=2.0,d2-=2.0,e1*=e2)
sum += c[i]*(e1/d1+1.0/(d2*e1));
ans=0.5641895835*SIGN(exp(-xp*xp),x)*sum;
}
return ans;
}
#undef NMAX
#undef H
#undef A1
#undef A2
#undef A3

91
lib/nr/k_and_r/recipes/dbrent.c Normal file
View File

@@ -0,0 +1,91 @@
#include <math.h>
#include "nrutil.h"
#define ITMAX 100
#define ZEPS 1.0e-10
#define MOV3(a,b,c, d,e,f) (a)=(d);(b)=(e);(c)=(f);
float dbrent(ax,bx,cx,f,df,tol,xmin)
float (*df)(),(*f)(),*xmin,ax,bx,cx,tol;
{
int iter,ok1,ok2;
float a,b,d,d1,d2,du,dv,dw,dx,e=0.0;
float fu,fv,fw,fx,olde,tol1,tol2,u,u1,u2,v,w,x,xm;
a=(ax < cx ? ax : cx);
b=(ax > cx ? ax : cx);
x=w=v=bx;
fw=fv=fx=(*f)(x);
dw=dv=dx=(*df)(x);
for (iter=1;iter<=ITMAX;iter++) {
xm=0.5*(a+b);
tol1=tol*fabs(x)+ZEPS;
tol2=2.0*tol1;
if (fabs(x-xm) <= (tol2-0.5*(b-a))) {
*xmin=x;
return fx;
}
if (fabs(e) > tol1) {
d1=2.0*(b-a);
d2=d1;
if (dw != dx) d1=(w-x)*dx/(dx-dw);
if (dv != dx) d2=(v-x)*dx/(dx-dv);
u1=x+d1;
u2=x+d2;
ok1 = (a-u1)*(u1-b) > 0.0 && dx*d1 <= 0.0;
ok2 = (a-u2)*(u2-b) > 0.0 && dx*d2 <= 0.0;
olde=e;
e=d;
if (ok1 || ok2) {
if (ok1 && ok2)
d=(fabs(d1) < fabs(d2) ? d1 : d2);
else if (ok1)
d=d1;
else
d=d2;
if (fabs(d) <= fabs(0.5*olde)) {
u=x+d;
if (u-a < tol2 || b-u < tol2)
d=SIGN(tol1,xm-x);
} else {
d=0.5*(e=(dx >= 0.0 ? a-x : b-x));
}
} else {
d=0.5*(e=(dx >= 0.0 ? a-x : b-x));
}
} else {
d=0.5*(e=(dx >= 0.0 ? a-x : b-x));
}
if (fabs(d) >= tol1) {
u=x+d;
fu=(*f)(u);
} else {
u=x+SIGN(tol1,d);
fu=(*f)(u);
if (fu > fx) {
*xmin=x;
return fx;
}
}
du=(*df)(u);
if (fu <= fx) {
if (u >= x) a=x; else b=x;
MOV3(v,fv,dv, w,fw,dw)
MOV3(w,fw,dw, x,fx,dx)
MOV3(x,fx,dx, u,fu,du)
} else {
if (u < x) a=u; else b=u;
if (fu <= fw || w == x) {
MOV3(v,fv,dv, w,fw,dw)
MOV3(w,fw,dw, u,fu,du)
} else if (fu < fv || v == x || v == w) {
MOV3(v,fv,dv, u,fu,du)
}
}
}
nrerror("Too many iterations in routine dbrent");
return 0.0;
}
#undef ITMAX
#undef ZEPS
#undef MOV3

21
lib/nr/k_and_r/recipes/ddpoly.c Normal file
View File

@@ -0,0 +1,21 @@
void ddpoly(c,nc,x,pd,nd)
float c[],pd[],x;
int nc,nd;
{
int nnd,j,i;
float cnst=1.0;
pd[0]=c[nc];
for (j=1;j<=nd;j++) pd[j]=0.0;
for (i=nc-1;i>=0;i--) {
nnd=(nd < (nc-i) ? nd : nc-i);
for (j=nnd;j>=1;j--)
pd[j]=pd[j]*x+pd[j-1];
pd[0]=pd[0]*x+c[i];
}
for (i=2;i<=nd;i++) {
cnst *= i;
pd[i] *= cnst;
}
}

25
lib/nr/k_and_r/recipes/decchk.c Normal file
View File

@@ -0,0 +1,25 @@
int decchk(string,n,ch)
char *ch,string[];
int n;
{
char c;
int j,k=0,m=0;
static int ip[10][8]={0,1,5,8,9,4,2,7,1,5, 8,9,4,2,7,0,2,7,0,1,
5,8,9,4,3,6,3,6,3,6, 3,6,4,2,7,0,1,5,8,9, 5,8,9,4,2,7,0,1,6,3,
6,3,6,3,6,3,7,0,1,5, 8,9,4,2,8,9,4,2,7,0, 1,5,9,4,2,7,0,1,5,8};
static int ij[10][10]={0,1,2,3,4,5,6,7,8,9, 1,2,3,4,0,6,7,8,9,5,
2,3,4,0,1,7,8,9,5,6, 3,4,0,1,2,8,9,5,6,7, 4,0,1,2,3,9,5,6,7,8,
5,9,8,7,6,0,4,3,2,1, 6,5,9,8,7,1,0,4,3,2, 7,6,5,9,8,2,1,0,4,3,
8,7,6,5,9,3,2,1,0,4, 9,8,7,6,5,4,3,2,1,0};
for (j=0;j<n;j++) {
c=string[j];
if (c >= 48 && c <= 57)
k=ij[k][ip[(c+2) % 10][7 & m++]];
}
for (j=0;j<=9;j++)
if (!ij[k][ip[j][m & 7]]) break;
*ch=j+48;
return k==0;
}

23
lib/nr/k_and_r/recipes/df1dim.c Normal file
View File

@@ -0,0 +1,23 @@
#include "nrutil.h"
extern int ncom;
extern float *pcom,*xicom,(*nrfunc)();
extern void (*nrdfun)();
float df1dim(x)
float x;
{
int j;
float df1=0.0;
float *xt,*df;
xt=vector(1,ncom);
df=vector(1,ncom);
for (j=1;j<=ncom;j++) xt[j]=pcom[j]+x*xicom[j];
(*nrdfun)(xt,df);
for (j=1;j<=ncom;j++) df1 += df[j]*xicom[j];
free_vector(df,1,ncom);
free_vector(xt,1,ncom);
return df1;
}

53
lib/nr/k_and_r/recipes/dfour1.c Normal file
View File

@@ -0,0 +1,53 @@
#include <math.h>
#define SWAP(a,b) tempr=(a);(a)=(b);(b)=tempr
void dfour1(data,nn,isign)
double data[];
int isign;
unsigned long nn;
{
unsigned long n,mmax,m,j,istep,i;
double wtemp,wr,wpr,wpi,wi,theta;
double tempr,tempi;
n=nn << 1;
j=1;
for (i=1;i<n;i+=2) {
if (j > i) {
SWAP(data[j],data[i]);
SWAP(data[j+1],data[i+1]);
}
m=n >> 1;
while (m >= 2 && j > m) {
j -= m;
m >>= 1;
}
j += m;
}
mmax=2;
while (n > mmax) {
istep=mmax << 1;
theta=isign*(6.28318530717959/mmax);
wtemp=sin(0.5*theta);
wpr = -2.0*wtemp*wtemp;
wpi=sin(theta);
wr=1.0;
wi=0.0;
for (m=1;m<mmax;m+=2) {
for (i=m;i<=n;i+=istep) {
j=i+mmax;
tempr=wr*data[j]-wi*data[j+1];
tempi=wr*data[j+1]+wi*data[j];
data[j]=data[i]-tempr;
data[j+1]=data[i+1]-tempi;
data[i] += tempr;
data[i+1] += tempi;
}
wr=(wtemp=wr)*wpr-wi*wpi+wr;
wi=wi*wpr+wtemp*wpi+wi;
}
mmax=istep;
}
}
#undef SWAP

103
lib/nr/k_and_r/recipes/dfpmin.c Normal file
View File

@@ -0,0 +1,103 @@
#include <math.h>
#include "nrutil.h"
#define ITMAX 200
#define EPS 3.0e-8
#define TOLX (4*EPS)
#define STPMX 100.0
#define FREEALL free_vector(xi,1,n);free_vector(pnew,1,n); \
free_matrix(hessin,1,n,1,n);free_vector(hdg,1,n);free_vector(g,1,n); \
free_vector(dg,1,n);
void dfpmin(p,n,gtol,iter,fret,func,dfunc)
float (*func)(),*fret,gtol,p[];
int *iter,n;
void (*dfunc)();
{
void lnsrch();
int check,i,its,j;
float den,fac,fad,fae,fp,stpmax,sum=0.0,sumdg,sumxi,temp,test;
float *dg,*g,*hdg,**hessin,*pnew,*xi;
dg=vector(1,n);
g=vector(1,n);
hdg=vector(1,n);
hessin=matrix(1,n,1,n);
pnew=vector(1,n);
xi=vector(1,n);
fp=(*func)(p);
(*dfunc)(p,g);
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) hessin[i][j]=0.0;
hessin[i][i]=1.0;
xi[i] = -g[i];
sum += p[i]*p[i];
}
stpmax=STPMX*FMAX(sqrt(sum),(float)n);
for (its=1;its<=ITMAX;its++) {
*iter=its;
lnsrch(n,p,fp,g,xi,pnew,fret,stpmax,&check,func);
fp = *fret;
for (i=1;i<=n;i++) {
xi[i]=pnew[i]-p[i];
p[i]=pnew[i];
}
test=0.0;
for (i=1;i<=n;i++) {
temp=fabs(xi[i])/FMAX(fabs(p[i]),1.0);
if (temp > test) test=temp;
}
if (test < TOLX) {
FREEALL
return;
}
for (i=1;i<=n;i++) dg[i]=g[i];
(*dfunc)(p,g);
test=0.0;
den=FMAX(*fret,1.0);
for (i=1;i<=n;i++) {
temp=fabs(g[i])*FMAX(fabs(p[i]),1.0)/den;
if (temp > test) test=temp;
}
if (test < gtol) {
FREEALL
return;
}
for (i=1;i<=n;i++) dg[i]=g[i]-dg[i];
for (i=1;i<=n;i++) {
hdg[i]=0.0;
for (j=1;j<=n;j++) hdg[i] += hessin[i][j]*dg[j];
}
fac=fae=sumdg=sumxi=0.0;
for (i=1;i<=n;i++) {
fac += dg[i]*xi[i];
fae += dg[i]*hdg[i];
sumdg += SQR(dg[i]);
sumxi += SQR(xi[i]);
}
if (fac > sqrt(EPS*sumdg*sumxi)) {
fac=1.0/fac;
fad=1.0/fae;
for (i=1;i<=n;i++) dg[i]=fac*xi[i]-fad*hdg[i];
for (i=1;i<=n;i++) {
for (j=i;j<=n;j++) {
hessin[i][j] += fac*xi[i]*xi[j]
-fad*hdg[i]*hdg[j]+fae*dg[i]*dg[j];
hessin[j][i]=hessin[i][j];
}
}
}
for (i=1;i<=n;i++) {
xi[i]=0.0;
for (j=1;j<=n;j++) xi[i] -= hessin[i][j]*g[j];
}
}
nrerror("too many iterations in dfpmin");
FREEALL
}
#undef ITMAX
#undef EPS
#undef TOLX
#undef STPMX
#undef FREEALL

43
lib/nr/k_and_r/recipes/dfridr.c Normal file
View File

@@ -0,0 +1,43 @@
#include <math.h>
#include "nrutil.h"
#define CON 1.4
#define CON2 (CON*CON)
#define BIG 1.0e30
#define NTAB 10
#define SAFE 2.0
float dfridr(func,x,h,err)
float (*func)(),*err,h,x;
{
int i,j;
float errt,fac,hh,**a,ans;
if (h == 0.0) nrerror("h must be nonzero in dfridr.");
a=matrix(1,NTAB,1,NTAB);
hh=h;
a[1][1]=((*func)(x+hh)-(*func)(x-hh))/(2.0*hh);
*err=BIG;
for (i=2;i<=NTAB;i++) {
hh /= CON;
a[1][i]=((*func)(x+hh)-(*func)(x-hh))/(2.0*hh);
fac=CON2;
for (j=2;j<=i;j++) {
a[j][i]=(a[j-1][i]*fac-a[j-1][i-1])/(fac-1.0);
fac=CON2*fac;
errt=FMAX(fabs(a[j][i]-a[j-1][i]),fabs(a[j][i]-a[j-1][i-1]));
if (errt <= *err) {
*err=errt;
ans=a[j][i];
}
}
if (fabs(a[i][i]-a[i-1][i-1]) >= SAFE*(*err)) break;
}
free_matrix(a,1,NTAB,1,NTAB);
return ans;
}
#undef CON
#undef CON2
#undef BIG
#undef NTAB
#undef SAFE

58
lib/nr/k_and_r/recipes/dftcor.c Normal file
View File

@@ -0,0 +1,58 @@
#include <math.h>
void dftcor(w,delta,a,b,endpts,corre,corim,corfac)
float *corfac,*corim,*corre,a,b,delta,endpts[],w;
{
void nrerror();
float a0i,a0r,a1i,a1r,a2i,a2r,a3i,a3r,arg,c,cl,cr,s,sl,sr,t;
float t2,t4,t6;
double cth,ctth,spth2,sth,sth4i,stth,th,th2,th4,tmth2,tth4i;
th=w*delta;
if (a >= b || th < 0.0e0 || th > 3.1416e0) nrerror("bad arguments to dftcor");
if (fabs(th) < 5.0e-2) {
t=th;
t2=t*t;
t4=t2*t2;
t6=t4*t2;
*corfac=1.0-(11.0/720.0)*t4+(23.0/15120.0)*t6;
a0r=(-2.0/3.0)+t2/45.0+(103.0/15120.0)*t4-(169.0/226800.0)*t6;
a1r=(7.0/24.0)-(7.0/180.0)*t2+(5.0/3456.0)*t4-(7.0/259200.0)*t6;
a2r=(-1.0/6.0)+t2/45.0-(5.0/6048.0)*t4+t6/64800.0;
a3r=(1.0/24.0)-t2/180.0+(5.0/24192.0)*t4-t6/259200.0;
a0i=t*(2.0/45.0+(2.0/105.0)*t2-(8.0/2835.0)*t4+(86.0/467775.0)*t6);
a1i=t*(7.0/72.0-t2/168.0+(11.0/72576.0)*t4-(13.0/5987520.0)*t6);
a2i=t*(-7.0/90.0+t2/210.0-(11.0/90720.0)*t4+(13.0/7484400.0)*t6);
a3i=t*(7.0/360.0-t2/840.0+(11.0/362880.0)*t4-(13.0/29937600.0)*t6);
} else {
cth=cos(th);
sth=sin(th);
ctth=cth*cth-sth*sth;
stth=2.0e0*sth*cth;
th2=th*th;
th4=th2*th2;
tmth2=3.0e0-th2;
spth2=6.0e0+th2;
sth4i=1.0/(6.0e0*th4);
tth4i=2.0e0*sth4i;
*corfac=tth4i*spth2*(3.0e0-4.0e0*cth+ctth);
a0r=sth4i*(-42.0e0+5.0e0*th2+spth2*(8.0e0*cth-ctth));
a0i=sth4i*(th*(-12.0e0+6.0e0*th2)+spth2*stth);
a1r=sth4i*(14.0e0*tmth2-7.0e0*spth2*cth);
a1i=sth4i*(30.0e0*th-5.0e0*spth2*sth);
a2r=tth4i*(-4.0e0*tmth2+2.0e0*spth2*cth);
a2i=tth4i*(-12.0e0*th+2.0e0*spth2*sth);
a3r=sth4i*(2.0e0*tmth2-spth2*cth);
a3i=sth4i*(6.0e0*th-spth2*sth);
}
cl=a0r*endpts[1]+a1r*endpts[2]+a2r*endpts[3]+a3r*endpts[4];
sl=a0i*endpts[1]+a1i*endpts[2]+a2i*endpts[3]+a3i*endpts[4];
cr=a0r*endpts[8]+a1r*endpts[7]+a2r*endpts[6]+a3r*endpts[5];
sr = -a0i*endpts[8]-a1i*endpts[7]-a2i*endpts[6]-a3i*endpts[5];
arg=w*(b-a);
c=cos(arg);
s=sin(arg);
*corre=cl+c*cr-s*sr;
*corim=sl+s*cr+c*sr;
}

65
lib/nr/k_and_r/recipes/dftint.c Normal file
View File

@@ -0,0 +1,65 @@
#include <math.h>
#include "nrutil.h"
#define M 64
#define NDFT 1024
#define MPOL 6
#define TWOPI (2.0*3.14159265)
void dftint(func,a,b,w,cosint,sinint)
float (*func)(),*cosint,*sinint,a,b,w;
{
void dftcor(),polint(),realft();
static int init=0;
int j,nn;
static float aold = -1.e30,bold = -1.e30,delta,(*funcold)();
static float data[NDFT+1],endpts[9];
float c,cdft,cerr,corfac,corim,corre,en,s;
float sdft,serr,*cpol,*spol,*xpol;
cpol=vector(1,MPOL);
spol=vector(1,MPOL);
xpol=vector(1,MPOL);
if (init != 1 || a != aold || b != bold || func != funcold) {
init=1;
aold=a;
bold=b;
funcold=func;
delta=(b-a)/M;
for (j=1;j<=M+1;j++)
data[j]=(*func)(a+(j-1)*delta);
for (j=M+2;j<=NDFT;j++)
data[j]=0.0;
for (j=1;j<=4;j++) {
endpts[j]=data[j];
endpts[j+4]=data[M-3+j];
}
realft(data,NDFT,1);
data[2]=0.0;
}
en=w*delta*NDFT/TWOPI+1.0;
nn=IMIN(IMAX((int)(en-0.5*MPOL+1.0),1),NDFT/2-MPOL+1);
for (j=1;j<=MPOL;j++,nn++) {
cpol[j]=data[2*nn-1];
spol[j]=data[2*nn];
xpol[j]=nn;
}
polint(xpol,cpol,MPOL,en,&cdft,&cerr);
polint(xpol,spol,MPOL,en,&sdft,&serr);
dftcor(w,delta,a,b,endpts,&corre,&corim,&corfac);
cdft *= corfac;
sdft *= corfac;
cdft += corre;
sdft += corim;
c=delta*cos(w*a);
s=delta*sin(w*a);
*cosint=c*cdft-s*sdft;
*sinint=s*cdft+c*sdft;
free_vector(cpol,1,MPOL);
free_vector(spol,1,MPOL);
free_vector(xpol,1,MPOL);
}
#undef M
#undef NDFT
#undef MPOL
#undef TWOPI

60
lib/nr/k_and_r/recipes/difeq.c Normal file
View File

@@ -0,0 +1,60 @@
extern int mm,n,mpt;
extern float h,c2,anorm,x[];
void difeq(k,k1,k2,jsf,is1,isf,indexv,ne,s,y)
float **s,**y;
int indexv[],is1,isf,jsf,k,k1,k2,ne;
{
float temp,temp1,temp2;
if (k == k1) {
if (n+mm & 1) {
s[3][3+indexv[1]]=1.0;
s[3][3+indexv[2]]=0.0;
s[3][3+indexv[3]]=0.0;
s[3][jsf]=y[1][1];
} else {
s[3][3+indexv[1]]=0.0;
s[3][3+indexv[2]]=1.0;
s[3][3+indexv[3]]=0.0;
s[3][jsf]=y[2][1];
}
} else if (k > k2) {
s[1][3+indexv[1]] = -(y[3][mpt]-c2)/(2.0*(mm+1.0));
s[1][3+indexv[2]]=1.0;
s[1][3+indexv[3]] = -y[1][mpt]/(2.0*(mm+1.0));
s[1][jsf]=y[2][mpt]-(y[3][mpt]-c2)*y[1][mpt]/(2.0*(mm+1.0));
s[2][3+indexv[1]]=1.0;
s[2][3+indexv[2]]=0.0;
s[2][3+indexv[3]]=0.0;
s[2][jsf]=y[1][mpt]-anorm;
} else {
s[1][indexv[1]] = -1.0;
s[1][indexv[2]] = -0.5*h;
s[1][indexv[3]]=0.0;
s[1][3+indexv[1]]=1.0;
s[1][3+indexv[2]] = -0.5*h;
s[1][3+indexv[3]]=0.0;
temp1=x[k]+x[k-1];
temp=h/(1.0-temp1*temp1*0.25);
temp2=0.5*(y[3][k]+y[3][k-1])-c2*0.25*temp1*temp1;
s[2][indexv[1]]=temp*temp2*0.5;
s[2][indexv[2]] = -1.0-0.5*temp*(mm+1.0)*temp1;
s[2][indexv[3]]=0.25*temp*(y[1][k]+y[1][k-1]);
s[2][3+indexv[1]]=s[2][indexv[1]];
s[2][3+indexv[2]]=2.0+s[2][indexv[2]];
s[2][3+indexv[3]]=s[2][indexv[3]];
s[3][indexv[1]]=0.0;
s[3][indexv[2]]=0.0;
s[3][indexv[3]] = -1.0;
s[3][3+indexv[1]]=0.0;
s[3][3+indexv[2]]=0.0;
s[3][3+indexv[3]]=1.0;
s[1][jsf]=y[1][k]-y[1][k-1]-0.5*h*(y[2][k]+y[2][k-1]);
s[2][jsf]=y[2][k]-y[2][k-1]-temp*((x[k]+x[k-1])
*0.5*(mm+1.0)*(y[2][k]+y[2][k-1])-temp2
*0.5*(y[1][k]+y[1][k-1]));
s[3][jsf]=y[3][k]-y[3][k-1];
}
}

39
lib/nr/k_and_r/recipes/dlinmin.c Normal file
View File

@@ -0,0 +1,39 @@
#include "nrutil.h"
#define TOL 2.0e-4
int ncom;
float *pcom,*xicom,(*nrfunc)();
void (*nrdfun)();
void dlinmin(p,xi,n,fret,func,dfunc)
float (*func)(),*fret,p[],xi[];
int n;
void (*dfunc)();
{
float dbrent(),df1dim(),f1dim();
void mnbrak();
int j;
float xx,xmin,fx,fb,fa,bx,ax;
ncom=n;
pcom=vector(1,n);
xicom=vector(1,n);
nrfunc=func;
nrdfun=dfunc;
for (j=1;j<=n;j++) {
pcom[j]=p[j];
xicom[j]=xi[j];
}
ax=0.0;
xx=1.0;
mnbrak(&ax,&xx,&bx,&fa,&fx,&fb,f1dim);
*fret=dbrent(ax,xx,bx,f1dim,df1dim,TOL,&xmin);
for (j=1;j<=n;j++) {
xi[j] *= xmin;
p[j] += xi[j];
}
free_vector(xicom,1,n);
free_vector(pcom,1,n);
}
#undef TOL

13
lib/nr/k_and_r/recipes/dpythag.c Normal file
View File

@@ -0,0 +1,13 @@
#include <math.h>
#include "nrutil.h"
double dpythag(a,b)
double a,b;
{
double absa,absb;
absa=fabs(a);
absb=fabs(b);
if (absa > absb) return absa*sqrt(1.0+DSQR(absb/absa));
else return (absb == 0.0 ? 0.0 : absb*sqrt(1.0+DSQR(absa/absb)));
}

49
lib/nr/k_and_r/recipes/drealft.c Normal file
View File

@@ -0,0 +1,49 @@
#include <math.h>
void drealft(data,n,isign)
double data[];
int isign;
unsigned long n;
{
void dfour1();
unsigned long i,i1,i2,i3,i4,np3;
double c1=0.5,c2,h1r,h1i,h2r,h2i;
double wr,wi,wpr,wpi,wtemp,theta;
theta=3.141592653589793/(double) (n>>1);
if (isign == 1) {
c2 = -0.5;
dfour1(data,n>>1,1);
} else {
c2=0.5;
theta = -theta;
}
wtemp=sin(0.5*theta);
wpr = -2.0*wtemp*wtemp;
wpi=sin(theta);
wr=1.0+wpr;
wi=wpi;
np3=n+3;
for (i=2;i<=(n>>2);i++) {
i4=1+(i3=np3-(i2=1+(i1=i+i-1)));
h1r=c1*(data[i1]+data[i3]);
h1i=c1*(data[i2]-data[i4]);
h2r = -c2*(data[i2]+data[i4]);
h2i=c2*(data[i1]-data[i3]);
data[i1]=h1r+wr*h2r-wi*h2i;
data[i2]=h1i+wr*h2i+wi*h2r;
data[i3]=h1r-wr*h2r+wi*h2i;
data[i4] = -h1i+wr*h2i+wi*h2r;
wr=(wtemp=wr)*wpr-wi*wpi+wr;
wi=wi*wpr+wtemp*wpi+wi;
}
if (isign == 1) {
data[1] = (h1r=data[1])+data[2];
data[2] = h1r-data[2];
} else {
data[1]=c1*((h1r=data[1])+data[2]);
data[2]=c1*(h1r-data[2]);
dfour1(data,n>>1,-1);
}
}

14
lib/nr/k_and_r/recipes/dsprsax.c Normal file
View File

@@ -0,0 +1,14 @@
void dsprsax(sa,ija,x,b,n)
double b[],sa[],x[];
unsigned long ija[],n;
{
void nrerror();
unsigned long i,k;
if (ija[1] != n+2) nrerror("dsprsax: mismatched vector and matrix");
for (i=1;i<=n;i++) {
b[i]=sa[i]*x[i];
for (k=ija[i];k<=ija[i+1]-1;k++) b[i] += sa[k]*x[ija[k]];
}
}

16
lib/nr/k_and_r/recipes/dsprstx.c Normal file
View File

@@ -0,0 +1,16 @@
void dsprstx(sa,ija,x,b,n)
double b[],sa[],x[];
unsigned long ija[],n;
{
void nrerror();
unsigned long i,j,k;
if (ija[1] != n+2) nrerror("mismatched vector and matrix in dsprstx");
for (i=1;i<=n;i++) b[i]=sa[i]*x[i];
for (i=1;i<=n;i++) {
for (k=ija[i];k<=ija[i+1]-1;k++) {
j=ija[k];
b[j] += sa[k]*x[i];
}
}
}

26
lib/nr/k_and_r/recipes/dsvbksb.c Normal file
View File

@@ -0,0 +1,26 @@
#include "nrutil.h"
void dsvbksb(u,w,v,m,n,b,x)
double **u,**v,b[],w[],x[];
int m,n;
{
int jj,j,i;
double s,*tmp;
tmp=dvector(1,n);
for (j=1;j<=n;j++) {
s=0.0;
if (w[j]) {
for (i=1;i<=m;i++) s += u[i][j]*b[i];
s /= w[j];
}
tmp[j]=s;
}
for (j=1;j<=n;j++) {
s=0.0;
for (jj=1;jj<=n;jj++) s += v[j][jj]*tmp[jj];
x[j]=s;
}
free_dvector(tmp,1,n);
}

183
lib/nr/k_and_r/recipes/dsvdcmp.c Normal file
View File

@@ -0,0 +1,183 @@
#include <math.h>
#include "nrutil.h"
void dsvdcmp(a,m,n,w,v)
double **a,**v,w[];
int m,n;
{
double dpythag();
int flag,i,its,j,jj,k,l,nm;
double anorm,c,f,g,h,s,scale,x,y,z,*rv1;
rv1=dvector(1,n);
g=scale=anorm=0.0;
for (i=1;i<=n;i++) {
l=i+1;
rv1[i]=scale*g;
g=s=scale=0.0;
if (i <= m) {
for (k=i;k<=m;k++) scale += fabs(a[k][i]);
if (scale) {
for (k=i;k<=m;k++) {
a[k][i] /= scale;
s += a[k][i]*a[k][i];
}
f=a[i][i];
g = -SIGN(sqrt(s),f);
h=f*g-s;
a[i][i]=f-g;
for (j=l;j<=n;j++) {
for (s=0.0,k=i;k<=m;k++) s += a[k][i]*a[k][j];
f=s/h;
for (k=i;k<=m;k++) a[k][j] += f*a[k][i];
}
for (k=i;k<=m;k++) a[k][i] *= scale;
}
}
w[i]=scale *g;
g=s=scale=0.0;
if (i <= m && i != n) {
for (k=l;k<=n;k++) scale += fabs(a[i][k]);
if (scale) {
for (k=l;k<=n;k++) {
a[i][k] /= scale;
s += a[i][k]*a[i][k];
}
f=a[i][l];
g = -SIGN(sqrt(s),f);
h=f*g-s;
a[i][l]=f-g;
for (k=l;k<=n;k++) rv1[k]=a[i][k]/h;
for (j=l;j<=m;j++) {
for (s=0.0,k=l;k<=n;k++) s += a[j][k]*a[i][k];
for (k=l;k<=n;k++) a[j][k] += s*rv1[k];
}
for (k=l;k<=n;k++) a[i][k] *= scale;
}
}
anorm=DMAX(anorm,(fabs(w[i])+fabs(rv1[i])));
}
for (i=n;i>=1;i--) {
if (i < n) {
if (g) {
for (j=l;j<=n;j++) v[j][i]=(a[i][j]/a[i][l])/g;
for (j=l;j<=n;j++) {
for (s=0.0,k=l;k<=n;k++) s += a[i][k]*v[k][j];
for (k=l;k<=n;k++) v[k][j] += s*v[k][i];
}
}
for (j=l;j<=n;j++) v[i][j]=v[j][i]=0.0;
}
v[i][i]=1.0;
g=rv1[i];
l=i;
}
for (i=IMIN(m,n);i>=1;i--) {
l=i+1;
g=w[i];
for (j=l;j<=n;j++) a[i][j]=0.0;
if (g) {
g=1.0/g;
for (j=l;j<=n;j++) {
for (s=0.0,k=l;k<=m;k++) s += a[k][i]*a[k][j];
f=(s/a[i][i])*g;
for (k=i;k<=m;k++) a[k][j] += f*a[k][i];
}
for (j=i;j<=m;j++) a[j][i] *= g;
} else for (j=i;j<=m;j++) a[j][i]=0.0;
++a[i][i];
}
for (k=n;k>=1;k--) {
for (its=1;its<=30;its++) {
flag=1;
for (l=k;l>=1;l--) {
nm=l-1;
if ((double)(fabs(rv1[l])+anorm) == anorm) {
flag=0;
break;
}
if ((double)(fabs(w[nm])+anorm) == anorm) break;
}
if (flag) {
c=0.0;
s=1.0;
for (i=l;i<=k;i++) {
f=s*rv1[i];
rv1[i]=c*rv1[i];
if ((double)(fabs(f)+anorm) == anorm) break;
g=w[i];
h=dpythag(f,g);
w[i]=h;
h=1.0/h;
c=g*h;
s = -f*h;
for (j=1;j<=m;j++) {
y=a[j][nm];
z=a[j][i];
a[j][nm]=y*c+z*s;
a[j][i]=z*c-y*s;
}
}
}
z=w[k];
if (l == k) {
if (z < 0.0) {
w[k] = -z;
for (j=1;j<=n;j++) v[j][k] = -v[j][k];
}
break;
}
if (its == 30) nrerror("no convergence in 30 dsvdcmp iterations");
x=w[l];
nm=k-1;
y=w[nm];
g=rv1[nm];
h=rv1[k];
f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y);
g=dpythag(f,1.0);
f=((x-z)*(x+z)+h*((y/(f+SIGN(g,f)))-h))/x;
c=s=1.0;
for (j=l;j<=nm;j++) {
i=j+1;
g=rv1[i];
y=w[i];
h=s*g;
g=c*g;
z=dpythag(f,h);
rv1[j]=z;
c=f/z;
s=h/z;
f=x*c+g*s;
g = g*c-x*s;
h=y*s;
y *= c;
for (jj=1;jj<=n;jj++) {
x=v[jj][j];
z=v[jj][i];
v[jj][j]=x*c+z*s;
v[jj][i]=z*c-x*s;
}
z=dpythag(f,h);
w[j]=z;
if (z) {
z=1.0/z;
c=f*z;
s=h*z;
}
f=c*g+s*y;
x=c*y-s*g;
for (jj=1;jj<=m;jj++) {
y=a[jj][j];
z=a[jj][i];
a[jj][j]=y*c+z*s;
a[jj][i]=z*c-y*s;
}
}
rv1[l]=0.0;
rv1[k]=f;
w[k]=x;
}
}
free_dvector(rv1,1,n);
}

17
lib/nr/k_and_r/recipes/eclass.c Normal file
View File

@@ -0,0 +1,17 @@
void eclass(nf,n,lista,listb,m)
int lista[],listb[],m,n,nf[];
{
int l,k,j;
for (k=1;k<=n;k++) nf[k]=k;
for (l=1;l<=m;l++) {
j=lista[l];
while (nf[j] != j) j=nf[j];
k=listb[l];
while (nf[k] != k) k=nf[k];
if (j != k) nf[j]=k;
}
for (j=1;j<=n;j++)
while (nf[j] != nf[nf[j]]) nf[j]=nf[nf[j]];
}

16
lib/nr/k_and_r/recipes/eclazz.c Normal file
View File

@@ -0,0 +1,16 @@
void eclazz(nf,n,equiv)
int (*equiv)(),n,nf[];
{
int kk,jj;
nf[1]=1;
for (jj=2;jj<=n;jj++) {
nf[jj]=jj;
for (kk=1;kk<=(jj-1);kk++) {
nf[kk]=nf[nf[kk]];
if ((*equiv)(jj,kk)) nf[nf[nf[kk]]]=jj;
}
}
for (jj=1;jj<=n;jj++) nf[jj]=nf[nf[jj]];
}

47
lib/nr/k_and_r/recipes/ei.c Normal file
View File

@@ -0,0 +1,47 @@
#include <math.h>
#define EULER 0.57721566
#define MAXIT 100
#define FPMIN 1.0e-30
#define EPS 6.0e-8
float ei(x)
float x;
{
void nrerror();
int k;
float fact,prev,sum,term;
if (x <= 0.0) nrerror("Bad argument in ei");
if (x < FPMIN) return log(x)+EULER;
if (x <= -log(EPS)) {
sum=0.0;
fact=1.0;
for (k=1;k<=MAXIT;k++) {
fact *= x/k;
term=fact/k;
sum += term;
if (term < EPS*sum) break;
}
if (k > MAXIT) nrerror("Series failed in ei");
return sum+log(x)+EULER;
} else {
sum=0.0;
term=1.0;
for (k=1;k<=MAXIT;k++) {
prev=term;
term *= k/x;
if (term < EPS) break;
if (term < prev) sum += term;
else {
sum -= prev;
break;
}
}
return exp(x)*(1.0+sum)/x;
}
}
#undef EPS
#undef EULER
#undef MAXIT
#undef FPMIN

23
lib/nr/k_and_r/recipes/eigsrt.c Normal file
View File

@@ -0,0 +1,23 @@
void eigsrt(d,v,n)
float **v,d[];
int n;
{
int k,j,i;
float p;
for (i=1;i<n;i++) {
p=d[k=i];
for (j=i+1;j<=n;j++)
if (d[j] >= p) p=d[k=j];
if (k != i) {
d[k]=d[i];
d[i]=p;
for (j=1;j<=n;j++) {
p=v[j][i];
v[j][i]=v[j][k];
v[j][k]=p;
}
}
}
}

15
lib/nr/k_and_r/recipes/elle.c Normal file
View File

@@ -0,0 +1,15 @@
#include <math.h>
#include "nrutil.h"
float elle(phi,ak)
float ak,phi;
{
float rd(),rf();
float cc,q,s;
s=sin(phi);
cc=SQR(cos(phi));
q=(1.0-s*ak)*(1.0+s*ak);
return s*(rf(cc,q,1.0)-(SQR(s*ak))*rd(cc,q,1.0)/3.0);
}

13
lib/nr/k_and_r/recipes/ellf.c Normal file
View File

@@ -0,0 +1,13 @@
#include <math.h>
#include "nrutil.h"
float ellf(phi,ak)
float ak,phi;
{
float rf();
float s;
s=sin(phi);
return s*rf(SQR(cos(phi)),(1.0-s*ak)*(1.0+s*ak),1.0);
}

16
lib/nr/k_and_r/recipes/ellpi.c Normal file
View File

@@ -0,0 +1,16 @@
#include <math.h>
#include "nrutil.h"
float ellpi(phi,en,ak)
float ak,en,phi;
{
float rf(),rj();
float cc,enss,q,s;
s=sin(phi);
enss=en*s*s;
cc=SQR(cos(phi));
q=(1.0-s*ak)*(1.0+s*ak);
return s*(rf(cc,q,1.0)-enss*rj(cc,q,1.0,1.0+enss)/3.0);
}

39
lib/nr/k_and_r/recipes/elmhes.c Normal file
View File

@@ -0,0 +1,39 @@
#include <math.h>
#define SWAP(g,h) {y=(g);(g)=(h);(h)=y;}
void elmhes(a,n)
float **a;
int n;
{
int m,j,i;
float y,x;
for (m=2;m<n;m++) {
x=0.0;
i=m;
for (j=m;j<=n;j++) {
if (fabs(a[j][m-1]) > fabs(x)) {
x=a[j][m-1];
i=j;
}
}
if (i != m) {
for (j=m-1;j<=n;j++) SWAP(a[i][j],a[m][j])
for (j=1;j<=n;j++) SWAP(a[j][i],a[j][m])
}
if (x) {
for (i=m+1;i<=n;i++) {
if ((y=a[i][m-1]) != 0.0) {
y /= x;
a[i][m-1]=y;
for (j=m;j<=n;j++)
a[i][j] -= y*a[m][j];
for (j=1;j<=n;j++)
a[j][m] += y*a[j][i];
}
}
}
}
}
#undef SWAP

15
lib/nr/k_and_r/recipes/erfcc.c Normal file
View File

@@ -0,0 +1,15 @@
#include <math.h>
float erfcc(x)
float x;
{
float t,z,ans;
z=fabs(x);
t=1.0/(1.0+0.5*z);
ans=t*exp(-z*z-1.26551223+t*(1.00002368+t*(0.37409196+t*(0.09678418+
t*(-0.18628806+t*(0.27886807+t*(-1.13520398+t*(1.48851587+
t*(-0.82215223+t*0.17087277)))))))));
return x >= 0.0 ? ans : 2.0-ans;
}

8
lib/nr/k_and_r/recipes/erff.c Normal file
View File

@@ -0,0 +1,8 @@
float erff(x)
float x;
{
float gammp();
return x < 0.0 ? -gammp(0.5,x*x) : gammp(0.5,x*x);
}

Some files were not shown because too many files have changed in this diff Show More