Пример #1
0
void main ()
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	void chldecbnd(real_t [], int, int, real_t []);
	void chlsolbnd(real_t [], int, int, real_t []);
	real_t chldetermbnd(real_t [], int, int);
	int i;
	real_t *symband,*right,*aux;

	symband=allocate_real_vector(1,9);
	right=allocate_real_vector(1,5);
	aux=allocate_real_vector(2,3);

	for (i=1; i<=9; i++)
		symband[i] = ((i/2)*2 < i) ? 2.0 : -1.0;
	right[1]=right[5]=1.0;
	right[2]=right[3]=right[4]=0.0;
	aux[2]=1.0e-12;
	chldecbnd(symband,5,1,aux);
	if (aux[3] == 5) {
		chlsolbnd(symband,5,1,right);
		printf("Delivers: %8.4f %8.4f %8.4f %8.4f %8.4f\n"
				"Determinant is  %e\n",right[1],right[2],right[3],
				right[4],right[5],chldetermbnd(symband,5,1));
	}
	free_real_vector(symband,1);
	free_real_vector(right,1);
	free_real_vector(aux,2);
}
Пример #2
0
void main ()
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	void chldecsol1(real_t [], int, real_t [], real_t []);
	real_t chldeterm1(real_t [], int);
	void chldecinv1(real_t [], int, real_t []);
	int i,j,jj;
	real_t determinant,*pascal1,*b,*aux;

	pascal1=allocate_real_vector(1,((4+1)*4)/2);
	b=allocate_real_vector(1,4);
	aux=allocate_real_vector(2,3);

	jj=1;
	for (j=1; j<=4; j++) {
		pascal1[jj]=1.0;
		for (i=2; i<=j; i++)
			pascal1[jj+i-1] = (i == j) ?
					pascal1[jj+i-2]*2.0 : pascal1[jj+i-2]+pascal1[jj+i-j];
		b[j]=pow(2.0,j);
		jj += j;
	}
	aux[2]=1.0e-11;
	chldecsol1(pascal1,4,aux,b);
	if (aux[3] == 4)
		determinant=chldeterm1(pascal1,4);
	else
		printf("Matrix not positive definite");
	printf("Solution with CHLDECSOL1:\n %e  %e  %e  %e\n",
			b[1],b[2],b[3],b[4]);
	printf("\nDeterminant with CHLDETERM1: %e\n",determinant);
	jj=1;
	for (j=1; j<=4; j++) {
		pascal1[jj]=1.0;
		for (i=2; i<=j; i++)
			pascal1[jj+i-1] = (i == j) ?
					pascal1[jj+i-2]*2.0 : pascal1[jj+i-2]+pascal1[jj+i-j];
		jj += j;
	}
	chldecinv1(pascal1,4,aux);
	printf("\nInverse matrix with CHLDECINV1:\n");
	for (i=1; i<=4; i++) {
		for (j=1; j<=4; j++)
			if (j < i)
				printf("           ");
			else
				printf("%11.5f",pascal1[((j-1)*j)/2+i]);
		printf("\n");
	}

	free_real_vector(pascal1,1);
	free_real_vector(b,1);
	free_real_vector(aux,2);
}
Пример #3
0
void main ()
{
	real_t *allocate_real_vector(int, int);
	real_t **allocate_real_matrix(int, int, int, int);
	void free_real_vector(real_t *, int);
	void free_real_matrix(real_t **, int, int, int);
	void chldecsol2(real_t **, int, real_t [], real_t []);
	real_t chldeterm2(real_t **, int);
	void chldecinv2(real_t **, int, real_t []);
	int i,j;
	real_t determinant,**pascal2,*b,*aux;

	pascal2=allocate_real_matrix(1,4,1,4);
	b=allocate_real_vector(1,4);
	aux=allocate_real_vector(2,3);

	for (j=1; j<=4; j++) {
		pascal2[1][j]=1.0;
		for (i=2; i<=j; i++)
			pascal2[i][j] = (i == j) ?
					pascal2[i-1][j]*2.0 : pascal2[i][j-1]+pascal2[i-1][j];
		b[j]=pow(2.0,j);
	}
	aux[2]=1.0e-11;
	chldecsol2(pascal2,4,aux,b);
	if (aux[3] == 4)
		determinant=chldeterm2(pascal2,4);
	else
		printf("Matrix not positive definite");
	printf("Solution with CHLDECSOL2:\n %e  %e  %e  %e\n",
			b[1],b[2],b[3],b[4]);
	printf("\nDeterminant with CHLDETERM2: %e\n",determinant);
	for (j=1; j<=4; j++) {
		pascal2[1][j]=1.0;
		for (i=2; i<=j; i++)
			pascal2[i][j] = (i == j) ?
					pascal2[i-1][j]*2.0 : pascal2[i][j-1]+pascal2[i-1][j];
	}
	chldecinv2(pascal2,4,aux);
	printf("\nInverse matrix with CHLDECINV2:\n");
	for (i=1; i<=4; i++) {
		for (j=1; j<=4; j++)
			if (j < i)
				printf("           ");
			else
				printf("%11.5f",pascal2[i][j]);
		printf("\n");
	}

	free_real_matrix(pascal2,1,4,1);
	free_real_vector(b,1);
	free_real_vector(aux,2);
}
Пример #4
0
void main ()
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	void ark(real_t *, real_t *, int *, int *, real_t [],
			void (*)(int *, int *, real_t *, real_t[]), real_t [],
			void (*)(int *, int *, real_t *, real_t *,
						real_t [], real_t []));
	int m0,m,i;
	static real_t dat1[13]={3.0, 3.0, 1.0, 1.0, 1.0e-3, 1.0e-6,
				1.0e-6, 0.0, 0.0, 0.0, 1.0, 0.5, 1.0/6.0};
	static real_t dat2[14]={4.0, 3.0, 0.0, 500.0/3.0, 0.0,
			-1.0, -1.0, 0.0, 0.0, 0.0, 1.0, 0.5, 1.0/6.0, 1.0/24.0};
	real_t t,te,y[2],*u,data[15];

	u=allocate_real_vector(-150,150);
	for (i=1; i<=13; i++) data[i]=dat1[i-1];
	t=0.0;
	y[1]=1.0;
	te=1.0;
	m0=m=1;
	ark(&t,&te,&m0,&m,y,der1,data,out1);
	for (i=1; i<=14; i++) data[i]=dat2[i-1];
	data[3]=sqrt(8.0);
	data[5]=data[3]/data[4];
	m0 = -150;
	m=150;
	t=0.0;
	u[0]=1.0;
	for (i=1; i<=m; i++) u[i]=u[-i]=exp(-(0.003*i)*(0.003*i));
	te=0.6;
	ark(&t,&te,&m0,&m,u,der2,data,out2);
	free_real_vector(u,-150);
}
Пример #5
0
void chlinv1(real_t a[], int n)
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	real_t seqvec(int, int, int, int, real_t [], real_t []);
	real_t symmatvec(int, int, int, real_t [], real_t []);
	int i,ii,i1,j,ij;
	real_t r,*u;

	u=allocate_real_vector(1,n);
	ii=((n+1)*n)/2;
	for (i=n; i>=1; i--) {
		r=1.0/a[ii];
		i1=i+1;
		ij=ii+i;
		for (j=i1; j<=n; j++) {
			u[j]=a[ij];
			ij += j;
		}
		for (j=n; j>=i1; j--) {
			ij -= j;
			a[ij] = -symmatvec(i1,n,j,a,u)*r;
		}
		a[ii]=(r-seqvec(i1,n,ii+i,0,a,u))*r;
		ii -= i;
	}
	free_real_vector(u,1);
}
Пример #6
0
void eigvalhrm(real_t **a, int n, int numval, real_t val[], real_t em[])
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	void hshhrmtrival(real_t **, int, real_t [], real_t [], real_t []);
	void valsymtri(real_t [], real_t [], int, int, int,
						real_t [], real_t []);
	real_t *d,*bb;

	d=allocate_real_vector(1,n);
	bb=allocate_real_vector(1,n-1);
	hshhrmtrival(a,n,d,bb,em);
	valsymtri(d,bb,n,1,numval,val,em);
	free_real_vector(d,1);
	free_real_vector(bb,1);
}
Пример #7
0
void hshdecmul(int n, real_t **a, real_t **b, real_t dwarf)
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	real_t tammat(int, int, int, int, real_t **, real_t **);
	void hshvecmat(int, int, int, int, real_t, real_t [], real_t **);
	int j,k,k1,n1;
	real_t r,t,c,*v;

	v=allocate_real_vector(1,n);
	k=1;
	n1=n+1;
	for (k1=2; k1<=n1; k1++) {
		r=tammat(k1,n,k,k,b,b);
		if (r > dwarf) {
			r = (b[k][k] < 0.0) ? -sqrt(r+b[k][k]*b[k][k]) :
							sqrt(r+b[k][k]*b[k][k]);
			t=b[k][k]+r;
			c = -t/r;
			b[k][k] = -r;
			v[k]=1.0;
			for (j=k1; j<=n; j++) v[j]=b[j][k]/t;
			hshvecmat(k,n,k1,n,c,v,b);
			hshvecmat(k,n,1,n,c,v,a);
		}
		k=k1;
	}
	free_real_vector(v,1);
}
Пример #8
0
int LLL(long n, double **b)
{
    /* Lattice reduction algorithm. */
    double *B = allocate_real_vector(n);
    double **bs = allocate_real_matrix(n, n);
    double **mu = allocate_real_matrix(n, n);
    double C, t, temp, x, y;
    long i, j, k, l;

    for (i = 0; i < n; i++) bs[0][i] = b[0][i];
    B[0] = Scalar(n, bs[0], bs[0]);
    for (i = 1; i < n; i++) {
        for (j = 0; j < n; j++) bs[i][j] = b[i][j];
        for (j = 0; j < i; j++) {
            mu[i][j] = Scalar(n, b[i], bs[j]) / B[j];
            for (k = 0; k < n; k++)
                bs[i][k] -= mu[i][j] * bs[j][k];
        }
        B[i] = Scalar(n, bs[i], bs[i]);
    }
L3:
    k = 1;
L4:
    l = k - 1;
    Reduce(k, l, n, b, mu);
    x = mu[k][l];
    y = 0.75 - x * x;
    if (B[k] < y * B[l]) {
        C = B[k] + x * x * B[l];
        mu[k][l] = x * B[l] / C;
        B[k] *= B[l] / C;
        B[l] = C;
        for (i = 0; i < n; i++) {
            temp = b[k][i];
            b[k][i] = b[l][i];
            b[l][i] = temp;
        }
        if (k > 1) {
            for (j = 0; j < k - 1; j++) {
                temp = mu[k][j];
                mu[k][j] = mu[l][j];
                mu[l][j] = temp;
            }
        }
        for (i = k + 1; i < n; i++) {
            t = mu[i][k];
            mu[i][k] = mu[i][l] - x * t;
            mu[i][l] = t + mu[k][l] * mu[i][k];
        }
        k = max(1, k - 1);
        goto L4;
    }
    for (l = k - 2; l >= 0; l--) Reduce(k, l, n, b, mu);
    k++;
    if (k < n) goto L4;
    free_real_matrix(bs, n);
    free_real_matrix(mu, n);
    free_real_vector(B);
    return 1;
}
Пример #9
0
void control(real_t *tp, real_t t, real_t h, real_t hnew, real_t **y,
				real_t err[], int n, real_t tend)
{
	int i;
	real_t c[6],*x,s,s2,s3,s4;

	x=allocate_real_vector(1,n);
	while (1) {
		s=(t-(*tp))/h;
		s2=s*s;
		s3=s2*s;
		s4=s3*s;
		c[3]=(s2-s)/2.0;
		c[4] = -s3/6.0+s2/2.0-s/3.0;
		c[5]=s4/24.0-s3/4.0+11.0*s2/24.0-s/4.0;
		for (i=1; i<=n; i++)
			x[i]=y[1][i]-s*y[2][i]+c[3]*y[3][i]+
					c[4]*y[4][i]+c[5]*y[5][i];
		printf(" %6.2f  %7.2e  %e   %e   %4d  %3d\n",
			*tp,err[3],x[1],x[2],nfe,nje);
		if (*tp >= tend) break;
		point++;
		*tp = print[point];
		if (*tp > t) break;
	}
	free_real_vector(x,1);
}
Пример #10
0
void hsh2row3(int l, int ua, int ub, int ux, int j, real_t a1, real_t a2,
					real_t **a, real_t **b, real_t **x)
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	void hshvectam(int, int, int, int, real_t, real_t [], real_t **);
	real_t *v,d1,d2,s1,s2,r,d,c;

	if (a2 != 0.0) {
		v=allocate_real_vector(j,j+1);
		d1=fabs(a1);
		d2=fabs(a2);
		s1 = (a1 >= 0.0) ? 1.0 : -1.0;
		s2 = (a2 >= 0.0) ? 1.0 : -1.0;
		if (d2 <= d1) {
			r=d2/d1;
			d=sqrt(1.0+r*r);
			c = -1.0-1.0/d;
			v[j]=s1*s2*r/(1.0+d);
		} else {
			r=d1/d2;
			d=sqrt(1.0+r*r);
			c = -1.0-r/d;
			v[j]=s1*s2/(r+d);
		}
		v[j+1]=1.0;
		hshvectam(l,ua,j,j+1,c,v,a);
		hshvectam(l,ub,j,j+1,c,v,b);
		hshvectam(1,ux,j,j+1,c,v,x);
		free_real_vector(v,j);
	}
}
Пример #11
0
void eigvalsym1(real_t a[], int n, int numval, real_t val[], real_t em[])
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	void tfmsymtri1(real_t [], int, real_t [], real_t [], real_t [],
						real_t []);
	void valsymtri(real_t [], real_t [], int, int, int,
						real_t [], real_t []);
	real_t *b,*bb,*d;

	b=allocate_real_vector(1,n);
	bb=allocate_real_vector(1,n);
	d=allocate_real_vector(1,n);
	tfmsymtri1(a,n,d,b,bb,em);
	valsymtri(d,bb,n,1,numval,val,em);
	free_real_vector(b,1);
	free_real_vector(bb,1);
	free_real_vector(d,1);
}
Пример #12
0
int main(void)
{
    long i, n = 8;
    double *a = allocate_real_vector(n);
    double *x = allocate_real_vector(n);
    double s;

    srand(time(NULL));
    printf("\n");
    for (i = 0; i < n; i++) a[i] = pow(2, i);
    s = a[rand() % n] + a[rand() % n];
    if (SubsetSum(n, s, a, x)) {
        printf("sum: %f\n\n", s);
        printf("x[i]\t\ta[i]\n\n");
        for (i = 0; i < n; i++)
            printf("%f\t%f\n", x[i], a[i]);
    }
    else printf("subset sum has no solution\n");
    free_real_vector(a);
    free_real_vector(x);
    return 0;
}
Пример #13
0
void alllagzer(int n, real_t alfa, real_t zer[])
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	void allzerortpol(int, real_t [], real_t [], real_t [], real_t []);
	int i;
	real_t *a,*b,em[6];

	a=allocate_real_vector(0,n);
	b=allocate_real_vector(0,n);
	b[0]=0.0;
	a[n-1]=n+n+alfa-1.0;
	for (i=1; i<=n-1; i++) {
		a[i-1]=i+i+alfa-1.0;
		b[i]=i*(i+alfa);
	}
	em[0]=FLT_MIN;
	em[2]=FLT_EPSILON;
	em[4]=6*n;
	allzerortpol(n,a,b,zer,em);
	free_real_vector(a,0);
	free_real_vector(b,0);
}
Пример #14
0
void main ()
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	void quanewbnd1(int, int, int, real_t [], real_t [],
						int (*)(int, int, int, real_t[], real_t[]),
						real_t [], real_t []);
	int i;
	real_t *x,*f,in[6],out[6];

	x=allocate_real_vector(1,600);
	f=allocate_real_vector(1,600);
	for (i=1; i<=600; i++) x[i] = -1.0;
	in[0]=1.0e-6;  in[1]=in[2]=in[3]=1.0e-5;  in[4]=20000.0;
	in[5]=0.001;
	quanewbnd1(600,1,1,x,f,fun,in,out);
	printf("Norm Residual vector: %e\n"
			"Length of last step:  %e\n"
			"Number of function component evaluations: %6.0f\n"
			"Number of iterations: %3.0f\nReport: %3.0f\n",
			out[2],out[1],out[3],out[4],out[5]);
	free_real_vector(x,1);
	free_real_vector(f,1);
}
Пример #15
0
int homsol(real_t **a, int m, int n, real_t **v, real_t em[])
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	int qrisngvaldec(real_t **, int, int, real_t [], real_t **, real_t []);
	void homsolsvd(real_t **, real_t [], real_t **, int, int);
	int i;
	real_t *val;

	val=allocate_real_vector(1,n);
	i=qrisngvaldec(a,m,n,val,v,em);
	if (i == 0) homsolsvd(a,val,v,m,n);
	free_real_vector(val,1);
	return i;
}
Пример #16
0
int qrivalhrm(real_t **a, int n, real_t val[], real_t em[])
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	void hshhrmtrival(real_t **, int, real_t [], real_t [], real_t []);
	int qrivalsymtri(real_t [], real_t [], int, real_t []);
	int i;
	real_t *bb;

	bb=allocate_real_vector(1,n);
	hshhrmtrival(a,n,val,bb,em);
	bb[n]=0.0;
	i=qrivalsymtri(val,bb,n,em);
	free_real_vector(bb,1);
	return i;
}
Пример #17
0
void hsh3row2(int l, int u, int j, real_t a1, real_t a2,
					real_t a3, real_t **a, real_t **b)
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	void hshvectam(int, int, int, int, real_t, real_t [], real_t **);
	real_t *v,c,d1,d2,d3,s1,s2,s3,r1,r2,r3,d;

	if (a2 != 0.0 || a3 != 0.0) {
		v=allocate_real_vector(j,j+2);
		d1=fabs(a1);
		d2=fabs(a2);
		d3=fabs(a3);
		s1 = (a1 >= 0.0) ? 1.0 : -1.0;
		s2 = (a2 >= 0.0) ? 1.0 : -1.0;
		s3 = (a3 >= 0.0) ? 1.0 : -1.0;
		if (d1 >= d2 && d1 >= d3) {
			r2=d2/d1;
			r3=d3/d1;
			d=sqrt(1.0+r2*r2+r3*r3);
			c = -1.0-(1.0/d);
			d=1.0/(1.0+d);
			v[j+1]=s1*s2*r2*d;
			v[j]=s1*s3*r3*d;
		} else if (d2 >= d1 && d2 >= d3) {
			r1=d1/d2;
			r3=d3/d2;
			d=sqrt(1.0+r1*r1+r3*r3);
			c = -1.0-(s1*r1/d);
			d=1.0/(r1+d);
			v[j+1]=s1*s2*d;
			v[j]=s1*s3*r3*d;
		} else {
			r1=d1/d3;
			r2=d2/d3;
			d=sqrt(1.0+r1*r1+r2*r2);
			c = -1.0-(s1*r1/d);
			d=1.0/(r1+d);
			v[j+1]=s1*s2*r2*d;
			v[j]=s1*s3*d;
		}
		v[j+2]=1.0;
		hshvectam(l,u,j,j+2,c,v,a);
		hshvectam(l,u,j,j+2,c,v,b);
		free_real_vector(v,j);
	}
}
Пример #18
0
void ixqfix(real_t x, real_t p, real_t q, int nmax, real_t eps,
				real_t i[])
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	real_t incbeta(real_t, real_t, real_t, real_t);
	void forward(real_t, real_t, real_t, real_t, real_t, int, real_t []);
	void backward(real_t, real_t, real_t, real_t, int, real_t, real_t []);
	int m,mmax;
	real_t s,iq0,iq1,q0,*iq;

	m=floor(q);
	s=q-m;
	q0 = (s > 0.0) ? s : s+1.0;
	mmax = (s > 0.0) ? m : m-1;
	iq0=incbeta(x,p,q0,eps);
	if (mmax > 0) iq1=incbeta(x,p,q0+1.0,eps);
	iq=allocate_real_vector(0,mmax);
	forward(x,p,q0,iq0,iq1,mmax,iq);
	backward(x,p,q,iq[mmax],nmax,eps,i);
	free_real_vector(iq,0);
}
Пример #19
0
int Ti_Optimization::qrisngvaldec(
				 double **a,     // the given matrix, exit: the matrix U in the singular value decomposition UDV'
				 int m,         // entry : the number of rows of a
				 int n,         // entry : the number of columns of a, n should satisfy n<=m
				 double val[],   // exit: the singular values
				 double **v,     // exit: the transpose of matrix V in the singular value decomposition
				 double em[8]   
			 // entry:
			 // em[0]: the machine precision
			 // em[2]: the relative precision in the singular values
			 // em[4]: the maximal number of interations to be performed
			 // em[6]: the minimal non-neglectable singular value;
			 // exit:
			 // em[1]: the infinity norm of the matrix
			 // em[3]: the maximal neglected superdiagonal element;
			 // em[5]: the number of iterations performed;
			 // em[7]: the numerical rank of the matrix; i.e. the number of singular values greater than or equal to em[6]
				 )
{
	/*double *allocate_real_vector(int, int);
	void free_real_vector(double *, int);
	void hshreabid(double **, int, int, double [], double [], double []);
	void psttfmmat(double **, int, double **, double []);
	void pretfmmat(double **, int, int, double []);
	int qrisngvaldecbid(double [], double [], int, int, double **,
							double **, double []);*/
	int i = 0;
	double *b;

	b=allocate_real_vector(1,n);
	hshreabid(a,m,n,val,b,em);
	psttfmmat(a,n,v,b);
	pretfmmat(a,m,n,val);
	i=qrisngvaldecbid(val,b,m,n,a,v,em);
	free_real_vector(b,1);
	return i;
}
Пример #20
0
void gssnewton(int m, int n, real_t par[], real_t rv[], real_t **jjinv,
					int (*funct)(int, int, real_t[], real_t[]),
					void (*jacobian)(int, int, real_t[], real_t[], real_t **),
					real_t in[], real_t out[])
{
	int *allocate_integer_vector(int, int);
	real_t *allocate_real_vector(int, int);
	real_t **allocate_real_matrix(int, int, int, int);
	void free_integer_vector(int *, int);
	void free_real_vector(real_t *, int);
	void free_real_matrix(real_t **, int, int, int);
	real_t vecvec(int, int, int, real_t [], real_t []);
	void dupvec(int, int, int, real_t [], real_t []);
	void elmvec(int, int, int, real_t [], real_t [], real_t);
	void lsqortdec(real_t **, int, int, real_t [], real_t [], int []);
	void lsqsol(real_t **, int, int, real_t [], int [], real_t []);
	void lsqinv(real_t **, int, real_t [], int []);
	int i,j,inr,mit,text,it,itmax,inrmax,tim,feval,fevalmax,conv,
			testthf,dampingon,*ci,fail;
	real_t rho,res1,res2,rn,reltolpar,abstolpar,abstolres,stap,normx,
			**jac,*pr,*aid,*sol,*fu2,aux[6];

	ci=allocate_integer_vector(1,n);
	pr=allocate_real_vector(1,n);
	aid=allocate_real_vector(1,n);
	sol=allocate_real_vector(1,n);
	fu2=allocate_real_vector(1,m);
	jac=allocate_real_matrix(1,m+1,1,n);

	itmax=fevalmax=in[5];
	aux[2]=n*in[0];
	tim=in[7];
	reltolpar=in[1]*in[1];
	abstolpar=in[2]*in[2];
	abstolres=in[4]*in[4];
	inrmax=in[6];
	dupvec(1,n,0,pr,par);
	if (m < n)
		for (i=1; i<=n; i++) jac[m+1][i]=0.0;
	text=4;
	mit=0;
	testthf=1;
	res2=stap=out[5]=out[6]=out[7]=0.0;
	(*funct)(m,n,par,fu2);
	rn=vecvec(1,m,0,fu2,fu2);
	out[3]=sqrt(rn);
	feval=1;
	dampingon=0;
	fail=0;
	it=1;
	do {
		out[5]=it;
		(*jacobian)(m,n,par,fu2,jac);
		if (!testthf) {
			text=7;
			fail=1;
			break;
		}
		lsqortdec(jac,m,n,aux,aid,ci);
		if (aux[3] != n) {
			text=5;
			fail=1;
			break;
		}
		lsqsol(jac,m,n,aid,ci,fu2);
		dupvec(1,n,0,sol,fu2);
		stap=vecvec(1,n,0,sol,sol);
		rho=2.0;
		normx=vecvec(1,n,0,par,par);
		if (stap > reltolpar*normx+abstolpar || it == 1 && stap > 0.0) {
			inr=0;
			do {
				rho /= 2.0;
				if (inr > 0) {
					res1=res2;
					dupvec(1,m,0,rv,fu2);
					dampingon = inr > 1;
				}
				for (i=1; i<=n; i++) pr[i]=par[i]-sol[i]*rho;
				feval++;
				if (!(*funct)(m,n,pr,fu2)) {
					text=6;
					fail=1;
					break;
				}
				res2=vecvec(1,m,0,fu2,fu2);
				conv = inr >= inrmax;
				inr++;
			} while ((inr == 1) ? (dampingon || res2 >= rn) :
						(!conv && (rn <= res1 || res2 < res1)));
			if (fail) break;
			if (conv) {
				mit++;
				if (mit < tim) conv=0;
			} else
				mit=0;
			if (inr > 1) {
				rho *= 2.0;
				elmvec(1,n,0,par,sol,-rho);
				rn=res1;
				if (inr > 2) out[7]=it;
			} else {
				dupvec(1,n,0,par,pr);
				rn=res2;
				dupvec(1,m,0,rv,fu2);
			}
			if (rn <= abstolres) {
				text=1;
				itmax=it;
			} else
				if (conv && inrmax > 0) {
					text=3;
					itmax=it;
				} else
					dupvec(1,m,0,fu2,rv);
		} else {
			text=2;
			rho=1.0;
			itmax=it;
		}
		it++;
	} while (it <= itmax && feval < fevalmax);
	if (!fail) {
		lsqinv(jac,n,aid,ci);
		for (i=1; i<=n; i++) {
			jjinv[i][i]=jac[i][i];
			for (j=i+1; j<=n; j++) jjinv[i][j]=jjinv[j][i]=jac[i][j];
		}
	}
	out[6]=sqrt(stap)*rho;
	out[2]=sqrt(rn);
	out[4]=feval;
	out[1]=text;
	out[8]=aux[3];
	out[9]=aux[5];
	free_integer_vector(ci,1);
	free_real_vector(pr,1);
	free_real_vector(aid,1);
	free_real_vector(sol,1);
	free_real_vector(fu2,1);
	free_real_matrix(jac,1,m+1,1);
}
Пример #21
0
void praxis( int n, double *x, int *data, double (*funct)(double *, void *data), double *in, double *out) {

	int illc,i,j,k,k2,nl,maxf,nf,kl,kt,ktm,emergency;
	double s,sl,dn,dmin,fx,f1,lds,ldt,sf,df,qf1,qd0,qd1,qa,qb,qc,m2,m4,
			small,vsmall,large,vlarge,scbd,ldfac,t2,macheps,reltol,
			abstol,h,**v,*d,*y,*z,*q0,*q1,**a,em[8],l;

	/*
	 *  Seed random number generator
	 */
#ifdef MSWIN
	srand(34084320);
#else
	srand48(34084320);
#endif

//	for (i=0; i<8; ++i) x[i+1] = (double)data->x[i];
	d=allocate_real_vector(1,n);
	y=allocate_real_vector(1,n);
	z=allocate_real_vector(1,n);
	q0=allocate_real_vector(1,n);
	q1=allocate_real_vector(1,n);
	v=allocate_real_matrix(1,n,1,n);
	a=allocate_real_matrix(1,n,1,n);

    //  heuristic numbers:
    //
    //  If the axes may be badly scaled (which is to be avoided if
    //  possible), then set scbd = 10.  otherwise set scbd=1.
    //
    //  If the problem is known to be ill-conditioned, set ILLC = true.
    //
    //  KTM is the number of iterations without improvement before the
    //  algorithm terminates.  KTM = 4 is very cautious; usually KTM = 1
    //  is satisfactory.
    //

	macheps=in[0];
	reltol=in[1];
	abstol=in[2];
	maxf=in[5];
	h=in[6];
	scbd=in[7];
	ktm=in[8];
	illc = in[9] < 0.0;
	small=macheps*macheps;
	vsmall=small*small;
	large=1.0/small;
	vlarge=1.0/vsmall;
	m2=reltol;
	m4=sqrt(m2);
	srand(1);
	ldfac = (illc ? 0.1 : 0.01);
	kt=nl=0;
	nf=1;
	out[3]=qf1=fx=(*funct)(x, data);
	abstol=t2=small+fabs(abstol);
	dmin=small;
	if (h < abstol*100.0) h=abstol*100;
	ldt=h;
	inimat(1,n,1,n,v,0.0);
	for (i=1; i<=n; i++) v[i][i]=1.0;
	d[1]=qd0=qd1=0.0;
	dupvec(1,n,0,q1,x);
	inivec(1,n,q0,0.0);
	emergency=0;

	while (1) {
		sf=d[1];
		d[1]=s=0.0;
		praxismin(1,2,&(d[1]),&s,&fx,0,
					n,x,v,&qa,&qb,&qc,qd0,qd1,q0,q1,&nf,
					&nl,&fx,m2,m4,dmin,ldt,reltol,abstol,small,h,funct, data);
		if (s <= 0.0) mulcol(1,n,1,1,v,v,-1.0);
		if (sf <= 0.9*d[1] || 0.9*sf >= d[1]) inivec(2,n,d,0.0);
		for (k=2; k<=n; k++) {
			dupvec(1,n,0,y,x);
			sf=fx;
			illc = (illc || kt > 0);
			while (1) {
				kl=k;
				df=0.0;
				if (illc) {
					/* random stop to get off resulting valley */
					for (i=1; i<=n; i++) {
						s=z[i]=(0.1*ldt+t2*pow(10.0,kt))*
#ifdef MSWIN
									((double)(rand())/RAND_MAX-0.5);
#else
									(drand48()-0.5);
#endif
						elmveccol(1,n,i,x,v,s);
					}
					fx=(*funct)(x, data);
					nf++;
				}
				for (k2=k; k2<=n; k2++) {
					sl=fx;
					s=0.0;
					praxismin(k2,2,&(d[k2]),&s,&fx,0,
						n,x,v,&qa,&qb,&qc,qd0,qd1,q0,q1,&nf,
						&nl,&fx,m2,m4,dmin,ldt,reltol,abstol,small,h,funct, data);
					s = illc ? d[k2]*(s+z[k2])*(s+z[k2]) : sl-fx;
					if (df < s) {
						df=s;
						kl=k2;
					}
				}
				if (!illc && df < fabs(100.0*macheps*fx))
					illc=1;
				else
					break;
			}
			for (k2=1; k2<=k-1; k2++) {
				s=0.0;
				praxismin(k2,2,&(d[k2]),&s,&fx,0,
					n,x,v,&qa,&qb,&qc,qd0,qd1,q0,q1,&nf,
					&nl,&fx,m2,m4,dmin,ldt,reltol,abstol,small,h,funct, data);
			}
			f1=fx;
			fx=sf;
			lds=0.0;
			for (i=1; i<=n; i++) {
				sl=x[i];
				x[i]=y[i];
				y[i] = sl -= y[i];
				lds += sl*sl;
			}
			lds=sqrt(lds);
			if (lds > small) {
				for (i=kl-1; i>=k; i--) {
					for (j=1; j<=n; j++) v[j][i+1]=v[j][i];
					d[i+1]=d[i];
				}
				d[k]=0.0;
				dupcolvec(1,n,k,v,y);
				mulcol(1,n,k,k,v,v,1.0/lds);
				praxismin(k,4,&(d[k]),&lds,&f1,1,
					n,x,v,&qa,&qb,&qc,qd0,qd1,q0,q1,&nf,
					&nl,&fx,m2,m4,dmin,ldt,reltol,abstol,small,h,funct, data);
				if (lds <= 0.0) {
					lds = -lds;
					mulcol(1,n,k,k,v,v,-1.0);
				}
			}
			ldt *= ldfac;
			if (ldt < lds) ldt=lds;
			t2=m2*sqrt(vecvec(1,n,0,x,x))+abstol;
			kt = (ldt > 0.5*t2) ? 0 : kt+1;
			if (kt > ktm) {
				out[1]=0.0;
				emergency=1;
			}
		}
		if (emergency) break;
		/* quad */
		s=fx;
		fx=qf1;
		qf1=s;
		qd1=0.0;
		for (i=1; i<=n; i++) {
			s=x[i];
			x[i]=l=q1[i];
			q1[i]=s;
			qd1 += (s-l)*(s-l);
		}
		l=qd1=sqrt(qd1);
		s=0.0;
		if ((qd0*qd1 > DBL_MIN) && (nl >=3*n*n)) {
			praxismin(0,2,&s,&l,&qf1,1,
					n,x,v,&qa,&qb,&qc,qd0,qd1,q0,q1,&nf,
					&nl,&fx,m2,m4,dmin,ldt,reltol,abstol,small,h,funct, data);
			qa=l*(l-qd1)/(qd0*(qd0+qd1));
			qb=(l+qd0)*(qd1-l)/(qd0*qd1);
			qc=l*(l+qd0)/(qd1*(qd0+qd1));
		} else {
			fx=qf1;
			qa=qb=0.0;
			qc=1.0;
		}
		qd0=qd1;
		for (i=1; i<=n; i++) {
			s=q0[i];
			q0[i]=x[i];
			x[i]=qa*s+qb*x[i]+qc*q1[i];
		}
		/* end of quad */
		dn=0.0;
		for (i=1; i<=n; i++) {
			d[i]=1.0/sqrt(d[i]);
			if (dn < d[i]) dn=d[i];
		}
		for (j=1; j<=n; j++) {
			s=d[j]/dn;
			mulcol(1,n,j,j,v,v,s);
		}
		if (scbd > 1.0) {
			s=vlarge;
			for (i=1; i<=n; i++) {
				sl=z[i]=sqrt(mattam(1,n,i,i,v,v));
				if (sl < m4) z[i]=m4;
				if (s > sl) s=sl;
			}
			for (i=1; i<=n; i++) {
				sl=s/z[i];
				z[i]=1.0/sl;
				if (z[i] > scbd) {
					sl=1.0/scbd;
					z[i]=scbd;
				}
				mulrow(1,n,i,i,v,v,sl);
			}
		}
		for (i=1; i<=n; i++) ichrowcol(i+1,n,i,i,v);
		em[0]=em[2]=macheps;
		em[4]=10*n;
		em[6]=vsmall;
		dupmat(1,n,1,n,a,v);
		if (qrisngvaldec(a,n,n,d,v,em) != 0) {
			out[1]=2.0;
			emergency=1;
		}
		if (emergency) break;
		if (scbd > 1.0) {
			for (i=1; i<=n; i++) mulrow(1,n,i,i,v,v,z[i]);
			for (i=1; i<=n; i++) {
				s=sqrt(tammat(1,n,i,i,v,v));
				d[i] *= s;
				s=1.0/s;
				mulcol(1,n,i,i,v,v,s);
			}
		}
		for (i=1; i<=n; i++) {
			s=dn*d[i];
			d[i] = (s > large) ? vsmall :
						((s < small) ? vlarge : 1.0/(s*s));
		}
		/* sort */
		for (i=1; i<=n-1; i++) {
			k=i;
			s=d[i];
			for (j=i+1; j<=n; j++)
				if (d[j] > s) {
					k=j;
					s=d[j];
				}
			if (k > i) {
				d[k]=d[i];
				d[i]=s;
				for (j=1; j<=n; j++) {
					s=v[j][i];
					v[j][i]=v[j][k];
					v[j][k]=s;
				}
			}
		}
		/* end of sort */
		dmin=d[n];
		if (dmin < small) dmin=small;
		illc = (m2*d[1]) > dmin;
		if (nf >= maxf) {
			out[1]=1.0;
			break;
		}
	}
	out[2]=fx;
	out[4]=nf;
	out[5]=nl;
	out[6]=ldt;
	free_real_vector(d,1);
	free_real_vector(y,1);
	free_real_vector(z,1);
	free_real_vector(q0,1);
	free_real_vector(q1,1);
	free_real_matrix(v,1,n,1);
	free_real_matrix(a,1,n,1);

//	for (i=0; i<40; ++i) data->x[i] = (double)x[i+1];

}
Пример #22
0
void rk3n(real_t *x, real_t a, real_t b, real_t y[], real_t ya[],
			real_t z[], real_t za[],
			real_t (*fxyj)(int, int, real_t, real_t[]),
			real_t e[], real_t d[], int fi, int n)
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	int j,jj,last,first,reject,test,ta,tb;
	real_t xl,h,hmin,ind,hl,absh,fhm,discry,discrz,toly,tolz,mu,
			mu1,fhy,fhz,*yl,*zl,*k0,*k1,*k2,*k3,*k4,*k5,*ee;

	yl=allocate_real_vector(1,n);
	zl=allocate_real_vector(1,n);
	k0=allocate_real_vector(1,n);
	k1=allocate_real_vector(1,n);
	k2=allocate_real_vector(1,n);
	k3=allocate_real_vector(1,n);
	k4=allocate_real_vector(1,n);
	k5=allocate_real_vector(1,n);
	ee=allocate_real_vector(1,4*n);

	if (fi) {
		d[3]=a;
		for (jj=1; jj<=n; jj++) {
			d[jj+3]=ya[jj];
			d[n+jj+3]=za[jj];
		}
	}
	d[1]=0.0;
	xl=d[3];
	for (jj=1; jj<=n; jj++) {
		yl[jj]=d[jj+3];
		zl[jj]=d[n+jj+3];
	}
	if (fi) d[2]=b-d[3];
	absh=h=fabs(d[2]);
	if (b-xl < 0.0) h = -h;
	ind=fabs(b-xl);
	hmin=ind*e[1]+e[2];
	for (jj=2; jj<=2*n; jj++) {
		hl=ind*e[2*jj-1]+e[2*jj];
		if (hl < hmin) hmin=hl;
	}
	for (jj=1; jj<=4*n; jj++) ee[jj]=e[jj]/ind;
	first=reject=1;
	test=1;
	if (fi) {
		last=1;
		test=0;
	}
	while (1) {
		if (test) {
			absh=fabs(h);
			if (absh < hmin) {
				h = (h > 0.0) ? hmin : -hmin;
				absh=hmin;
			}
			ta=(h >= b-xl);
			tb=(h >= 0.0);
			if ((ta && tb) || (!(ta || tb))) {
				d[2]=h;
				last=1;
				h=b-xl;
				absh=fabs(h);
			} else
				last=0;
		}
		test=1;
		if (reject) {
			*x=xl;
			for (jj=1; jj<=n; jj++) y[jj]=yl[jj];
			for (j=1; j<=n; j++) k0[j]=(*fxyj)(n,j,*x,y)*h;
		} else {
			fhy=h/hl;
			for (jj=1; jj<=n; jj++) k0[jj]=k5[jj]*fhy;
		}
		*x=xl+0.276393202250021*h;
		for (jj=1; jj<=n; jj++)
			y[jj]=yl[jj]+(zl[jj]*0.276393202250021+
							k0[jj]*0.038196601125011)*h;
		for (j=1; j<=n; j++) k1[j]=(*fxyj)(n,j,*x,y)*h;
		*x=xl+0.723606797749979*h;
		for (jj=1; jj<=n; jj++)
			y[jj]=yl[jj]+(zl[jj]*0.723606797749979+
							k1[jj]*0.261803398874989)*h;
		for (j=1; j<=n; j++) k2[j]=(*fxyj)(n,j,*x,y)*h;
		*x=xl+h*0.5;
		for (jj=1; jj<=n; jj++)
			y[jj]=yl[jj]+(zl[jj]*0.5+k0[jj]*0.046875+k1[jj]*
					0.079824155839840-k2[jj]*0.001699155839840)*h;
		for (j=1; j<=n; j++) k4[j]=(*fxyj)(n,j,*x,y)*h;
		*x = (last ? b : xl+h);
		for (jj=1; jj<=n; jj++)
			y[jj]=yl[jj]+(zl[jj]+k0[jj]*0.309016994374947+
							k2[jj]*0.190983005625053)*h;
		for (j=1; j<=n; j++) k3[j]=(*fxyj)(n,j,*x,y)*h;
		for (jj=1; jj<=n; jj++)
			y[jj]=yl[jj]+(zl[jj]+k0[jj]*0.083333333333333+k1[jj]*
					0.301502832395825+k2[jj]*0.115163834270842)*h;
		for (j=1; j<=n; j++) k5[j]=(*fxyj)(n,j,*x,y)*h;
		reject=0;
		fhm=0.0;
		for (jj=1; jj<=n; jj++) {
			discry=fabs((-k0[jj]*0.5+k1[jj]*1.809016994374947+
						k2[jj]*0.690983005625053-k4[jj]*2.0)*h);
			discrz=fabs((k0[jj]-k3[jj])*2.0-(k1[jj]+k2[jj])*10.0+
						k4[jj]*16.0+k5[jj]*4.0);
			toly=absh*(fabs(zl[jj])*ee[2*jj-1]+ee[2*jj]);
			tolz=fabs(k0[jj])*ee[2*(jj+n)-1]+absh*ee[2*(jj+n)];
			reject=((discry > toly) || (discrz > tolz) || reject);
			fhy=discry/toly;
			fhz=discrz/tolz;
			if (fhz > fhy) fhy=fhz;
			if (fhy > fhm) fhm=fhy;
		}
		mu=1.0/(1.0+fhm)+0.45;
		if (reject) {
			if (absh <= hmin) {
				d[1] += 1.0;
				for (jj=1; jj<=n; jj++) {
					y[jj]=yl[jj];
					z[jj]=zl[jj];
				}
				first=1;
				if (b == *x) break;
				xl = *x;
				for (jj=1; jj<=n; jj++) {
					yl[jj]=y[jj];
					zl[jj]=z[jj];
				}
			} else
				h *= mu;
		} else {
			if (first) {
				first=0;
				hl=h;
				h *= mu;
			} else {
				fhy=mu*h/hl+mu-mu1;
				hl=h;
				h *= fhy;
			}
			mu1=mu;
			for (jj=1; jj<=n; jj++)
				z[jj]=zl[jj]+(k0[jj]+k3[jj])*0.083333333333333+
								(k1[jj]+k2[jj])*0.416666666666667;
			if (b == *x) break;
			xl = *x;
			for (jj=1; jj<=n; jj++) {
				yl[jj]=y[jj];
				zl[jj]=z[jj];
			}
		}
	}
	if (!last) d[2]=h;
	d[3] = *x;
	for (jj=1; jj<=n; jj++) {
		d[jj+3]=y[jj];
		d[n+jj+3]=z[jj];
	}
	free_real_vector(yl,1);
	free_real_vector(zl,1);
	free_real_vector(k0,1);
	free_real_vector(k1,1);
	free_real_vector(k2,1);
	free_real_vector(k3,1);
	free_real_vector(k4,1);
	free_real_vector(k5,1);
	free_real_vector(ee,1);
}
Пример #23
0
void lsqdecomp(real_t **a, int n, int m, int n1, real_t aux[],
					real_t aid[], int ci[])
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	real_t matmat(int, int, int, int, real_t **, real_t **);
	real_t tammat(int, int, int, int, real_t **, real_t **);
	void elmcol(int, int, int, int, real_t **, real_t **, real_t);
	void ichcol(int, int, int, int, real_t **);
	int j,k,kpiv,nr,s,fsum;
	real_t beta,sigma,norm,aidk,akk,w,eps,temp,*sum;

	sum=allocate_real_vector(1,m);
	norm=0.0;
	aux[3]=m;
	nr=n1;
	fsum=1;
	for (k=1; k<=m; k++) {
		if (k == n1+1) {
			fsum=1;
			nr=n;
		}
		if (fsum)
			for (j=k; j<=m; j++) {
				w=sum[j]=tammat(k,nr,j,j,a,a);
				if (w > norm) norm=w;
			}
		fsum=0;
		eps=aux[2]*sqrt(norm);
		sigma=sum[k];
		kpiv=k;
		for (j=k+1; j<=m; j++)
			if (sum[j] > sigma) {
				sigma=sum[j];
				kpiv=j;
			}
		if (kpiv != k) {
			sum[kpiv]=sum[k];
			ichcol(1,n,k,kpiv,a);
		}
		ci[k]=kpiv;
		akk=a[k][k];
		sigma=tammat(k,nr,k,k,a,a);
		w=sqrt(sigma);
		aidk=aid[k]=((akk < 0.0) ? w : -w);
		if (w < eps) {
			aux[3]=k-1;
			break;
		}
		beta=1.0/(sigma-akk*aidk);
		a[k][k]=akk-aidk;
		for (j=k+1; j<=m; j++) {
			elmcol(k,nr,j,k,a,a,-beta*tammat(k,nr,k,j,a,a));
			temp=a[k][j];
			sum[j] -= temp*temp;
		}
		if (k == n1)
			for (j=n1+1; j<=n; j++)
				for (s=1; s<=m; s++) {
					nr = (s > n1) ? n1 : s-1;
					w=a[j][s]-matmat(1,nr,j,s,a,a);
					a[j][s] = (s > n1) ? w : w/aid[s];
				}
	}
	free_real_vector(sum,1);
}
Пример #24
0
void rk2n(real_t *x, real_t a, real_t b, real_t y[], real_t ya[],
			real_t z[], real_t za[],
			real_t (*fxyzj)(int, int, real_t, real_t [], real_t []),
			real_t e[], real_t d[], int fi, int n)
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	int j,jj,last,first,reject,test,ta,tb;
	real_t xl,h,ind,hmin,hl,absh,fhm,discry,discrz,toly,tolz,
			mu,mu1,fhy,fhz,*yl,*zl,*k0,*k1,*k2,*k3,*k4,*k5,*ee;

	yl=allocate_real_vector(1,n);
	zl=allocate_real_vector(1,n);
	k0=allocate_real_vector(1,n);
	k1=allocate_real_vector(1,n);
	k2=allocate_real_vector(1,n);
	k3=allocate_real_vector(1,n);
	k4=allocate_real_vector(1,n);
	k5=allocate_real_vector(1,n);
	ee=allocate_real_vector(1,4*n);
	if (fi) {
		d[3]=a;
		for (jj=1; jj<=n; jj++) {
			d[jj+3]=ya[jj];
			d[n+jj+3]=za[jj];
		}
	}
	d[1]=0.0;
	xl=d[3];
	for (jj=1; jj<=n; jj++) {
		yl[jj]=d[jj+3];
		zl[jj]=d[n+jj+3];
	}
	if (fi) d[2]=b-d[3];
	absh=h=fabs(d[2]);
	if (b-xl < 0.0) h = -h;
	ind=fabs(b-xl);
	hmin=ind*e[1]+e[2];
	for (jj=2; jj<=2*n; jj++) {
		hl=ind*e[2*jj-1]+e[2*jj];
		if (hl < hmin) hmin=hl;
	}
	for (jj=1; jj<=4*n; jj++) ee[jj]=e[jj]/ind;
	first=1;
	test=1;
	if (fi) {
		last=1;
		test=0;
	}
	while (1) {
		if (test) {
			absh=fabs(h);
			if (absh < hmin) {
				h = (h > 0.0) ? hmin : -hmin;
				absh=fabs(h);
			}
			ta=(h >= b-xl);
			tb=(h >= 0.0);
			if ((ta && tb) || (!(ta || tb))) {
				d[2]=h;
				last=1;
				h=b-xl;
				absh=fabs(h);
			} else
				last=0;
		}
		test=1;
		*x=xl;
		for (jj=1; jj<=n; jj++) {
			y[jj]=yl[jj];
			z[jj]=zl[jj];
		}
		for (j=1; j<=n; j++)	k0[j]=(*fxyzj)(n,j,*x,y,z)*h;
		*x=xl+h/4.5;
		for (jj=1; jj<=n; jj++) {
			y[jj]=yl[jj]+(zl[jj]*18.0+k0[jj]*2.0)/81.0*h;
			z[jj]=zl[jj]+k0[jj]/4.5;
		}
		for (j=1; j<=n; j++) k1[j]=(*fxyzj)(n,j,*x,y,z)*h;
		*x=xl+h/3.0;
		for (jj=1; jj<=n; jj++) {
			y[jj]=yl[jj]+(zl[jj]*6.0+k0[jj])/18.0*h;
			z[jj]=zl[jj]+(k0[jj]+k1[jj]*3.0)/12.0;
		}
		for (j=1; j<=n; j++) k2[j]=(*fxyzj)(n,j,*x,y,z)*h;
		*x=xl+h*0.5;
		for (jj=1; jj<=n; jj++) {
			y[jj]=yl[jj]+(zl[jj]*8.0+k0[jj]+k2[jj])/16.0*h;
			z[jj]=zl[jj]+(k0[jj]+k2[jj]*3.0)/8.0;
		}
		for (j=1; j<=n; j++) k3[j]=(*fxyzj)(n,j,*x,y,z)*h;
		*x=xl+h*0.8;
		for (jj=1; jj<=n; jj++) {
			y[jj]=yl[jj]+(zl[jj]*100.0+k0[jj]*12.0+
						k3[jj]*28.0)/125.0*h;
			z[jj]=zl[jj]+(k0[jj]*53.0-k1[jj]*135.0+k2[jj]*126.0+
						k3[jj]*56.0)/125.0;
		}
		for (j=1; j<=n; j++) k4[j]=(*fxyzj)(n,j,*x,y,z)*h;
		*x = (last ? b : xl+h);
		for (jj=1; jj<=n; jj++) {
			y[jj]=yl[jj]+(zl[jj]*336.0+k0[jj]*21.0+k2[jj]*92.0+
						k4[jj]*55.0)/336.0*h;
			z[jj]=zl[jj]+(k0[jj]*133.0-k1[jj]*378.0+k2[jj]*276.0+
						k3[jj]*112.0+k4[jj]*25.0)/168.0;
		}
		for (j=1; j<=n; j++) k5[j]=(*fxyzj)(n,j,*x,y,z)*h;
		reject=0;
		fhm=0.0;
		for (jj=1; jj<=n; jj++) {
			discry=fabs((-k0[jj]*21.0+k2[jj]*108.0-k3[jj]*112.0+
						k4[jj]*25.0)/56.0*h);
			discrz=fabs(k0[jj]*21.0-k2[jj]*162.0+k3[jj]*224.0-
						k4[jj]*125.0+k5[jj]*42.0)/14.0;
			toly=absh*(fabs(zl[jj])*ee[2*jj-1]+ee[2*jj]);
			tolz=fabs(k0[jj])*ee[2*(jj+n)-1]+absh*ee[2*(jj+n)];
			reject=((discry > toly) || (discrz > tolz) || reject);
			fhy=discry/toly;
			fhz=discrz/tolz;
			if (fhz > fhy) fhy=fhz;
			if (fhy > fhm) fhm=fhy;
		}
		mu=1.0/(1.0+fhm)+0.45;
		if (reject) {
			if (absh <= hmin) {
				d[1] += 1.0;
				for (jj=1; jj<=n; jj++) {
					y[jj]=yl[jj];
					z[jj]=zl[jj];
				}
				first=1;
				if (b == *x) break;
				xl = *x;
				for (jj=1; jj<=n; jj++) {
					yl[jj] = y[jj];
					zl[jj] = z[jj];
				}
			} else
				h *= mu;
		} else {
			if (first) {
				first=0;
				hl=h;
				h *= mu;
			} else {
				fhm=mu*h/hl+mu-mu1;
				hl=h;
				h *= fhm;
			}
			mu1=mu;
			for (jj=1; jj<=n; jj++) {
				y[jj]=yl[jj]+(zl[jj]*56.0+k0[jj]*7.0+k2[jj]*36.0-
							k4[jj]*15.0)/56.0*hl;
				z[jj]=zl[jj]+(-k0[jj]*63.0+k1[jj]*189.0-k2[jj]*36.0-
							k3[jj]*112.0+k4[jj]*50.0)/28.0;
			}
			for (j=1; j<=n; j++) k5[j]=(*fxyzj)(n,j,*x,y,z)*hl;
			for (jj=1; jj<=n; jj++) {
				y[jj]=yl[jj]+(zl[jj]*336.0+k0[jj]*35.0+k2[jj]*108.0+
							k4[jj]*25.0)/336.0*hl;
				z[jj]=zl[jj]+(k0[jj]*35.0+k2[jj]*162.0+k4[jj]*125.0+
							k5[jj]*14.0)/336.0;
			}
			if (b == *x) break;
			xl = *x;
			for (jj=1; jj<=n; jj++) {
				yl[jj] = y[jj];
				zl[jj] = z[jj];
			}
		}
	}
	if (!last) d[2]=h;
	d[3] = *x;
	for (jj=1; jj<=n; jj++) {
		d[jj+3]=y[jj];
		d[n+jj+3]=z[jj];
	}
	free_real_vector(yl,1);
	free_real_vector(zl,1);
	free_real_vector(k0,1);
	free_real_vector(k1,1);
	free_real_vector(k2,1);
	free_real_vector(k3,1);
	free_real_vector(k4,1);
	free_real_vector(k5,1);
	free_real_vector(ee,1);
}
Пример #25
0
void ark(real_t *t, real_t *te, int *m0, int *m, real_t u[],
			void (*derivative)(int *, int *, real_t *, real_t[]),
			real_t data[],
			void (*out)(int *, int *, real_t *, real_t *, real_t [],
							real_t []))
{
	real_t *allocate_real_vector(int, int);
	real_t **allocate_real_matrix(int, int, int, int);
	void free_real_vector(real_t *, int);
	void free_real_matrix(real_t **, int, int, int);
	void inivec(int, int, real_t [], real_t);
	void mulvec(int, int, int, real_t [], real_t [], real_t);
	void dupvec(int, int, int, real_t [], real_t []);
	real_t vecvec(int, int, int, real_t [], real_t []);
	void elmvec(int, int, int, real_t [], real_t [], real_t);
	void decsol(real_t **, int, real_t [], real_t []);
	real_t arkmui(int, int, int, real_t []);
	real_t arklabda(int, int, int, int, real_t []);
	static real_t th1[8] = {1.0, 0.5, 1.0/6.0, 1.0/3.0, 1.0/24.0,
		1.0/12.0, 0.125, 0.25};
	static real_t ec0,ec1,ec2,tau0,tau1,tau2,taus,t2;
	int p,n,q,start,step1,last,i,j,k,l,n1,m00;
	real_t thetanm1,tau,betan,qinv,eta,*mu,*lambda,*thetha,*ro,*r,
			**alfa,th[9],aux[4],s,ss,theta0,tauacc,taustab,
			aa,bb,cc,ec,mt,lt;

	n=data[1];
	m00=(*m0);
	mu=allocate_real_vector(1,n);
	lambda=allocate_real_vector(1,n);
	thetha=allocate_real_vector(0,n);
	ro=allocate_real_vector(m00,*m);
	r=allocate_real_vector(m00,*m);
	alfa=allocate_real_matrix(1,8,1,n+1);

	p=data[2];
	ec1=ec2=0.0;
	betan=data[3];
	thetanm1 = (p == 3) ? 0.75 : 1.0;
	theta0=1.0-thetanm1;
	s=1.0;
	for (j=n-1; j>=1; j--) {
		s = -s*theta0+data[n+10-j];
		mu[j]=data[n+11-j]/s;
		lambda[j]=mu[j]-theta0;
	}
	for (i=1; i<=8; i++)
		for (j=0; j<=n; j++)
			if (i == 1) alfa[i][j+1]=1.0;
			else if (j == 0) alfa[i][j+1]=0.0;
			else if (i == 2 || i == 4 || i == 8)
					alfa[i][j+1]=pow(arkmui(j,n,p,lambda),(i+2)/3);
			else if ((i == 3 || i == 6) && j > 1) {
				s=0.0;
				for (l=1; l<=j-1; l++)
					s += arklabda(j,l,n,p,lambda)*
								pow(arkmui(l,n,p,lambda),i/3);
				alfa[i][j+1]=s;
			}
			else if (i == 5 && j > 2) {
				s=0.0;
				for (l=2; l<=j-1; l++) {
					ss=0.0;
					for (k=1; k<=l-1; k++)
						ss += arklabda(l,k,n,p,lambda)*
									arkmui(k,n,p,lambda);
					s += arklabda(j,l,n,p,lambda)*ss;
				}
				alfa[i][j+1]=s;
			}
			else if (i == 7 && j > 1) {
				s=0.0;
				for (l=1; l<=j-1; l++)
					s += arklabda(j,l,n,p,lambda)*arkmui(l,n,p,lambda);
				alfa[i][j+1]=s*arkmui(j,n,p,lambda);
			}
			else alfa[i][j+1]=0.0;
	n1 = ((n < 4) ? n+1 : ((n < 7) ? 4 : 8));
	for (i=1; i<=8; i++) th[i]=th1[i-1];
	if (p == 3 && n < 7) th[1]=th[2]=0.0;
	aux[2]=FLT_EPSILON;
	decsol(alfa,n1,aux,th);
	inivec(0,n,thetha,0.0);
	dupvec(0,n1-1,1,thetha,th);
	if (!(p == 3 && n < 7)) {
		thetha[0] -= theta0;
		thetha[n-1] -= thetanm1;
		q=p+1;
	} else
		q=3;
	qinv=1.0/q;
	start=(data[8] == 0.0);
	data[10]=0.0;
	last=0;
	dupvec(*m0,*m,0,r,u);
	(*derivative)(m0,m,t,r);
	do {
		/* stepsize */
		eta=sqrt(vecvec(*m0,*m,0,u,u))*data[7]+data[6];
		if (eta > 0.0) {
			if (start) {
				if (data[8] == 0) {
					tauacc=data[5];
					step1=1;
				} else
					if (step1) {
						tauacc=pow(eta/ec2,qinv);
						if (tauacc > 10.0*tau2)
							tauacc=10.0*tau2;
						else
							step1=0;
					} else {
						bb=(ec2-ec1)/tau1;
						cc = -bb*t2+ec2;
						ec=bb*(*t)+cc;
						tauacc = (ec < 0.0) ? tau2 : pow(eta/ec,qinv);
						start=0;
					}
			} else {
				aa=((ec0-ec1)/tau0+(ec2-ec1)/tau1)/(tau1+tau0);
				bb=(ec2-ec1)/tau1-(2.0*t2-tau1)*aa;
				cc = -(aa*t2+bb)*t2+ec2;
				ec=(aa*(*t)+bb)*(*t)+cc;
				tauacc = ((ec < 0.0) ? taus : pow(eta/ec,qinv));
				if (tauacc > 2.0*taus) tauacc=2.0*taus;
				if (tauacc < taus/2.0) tauacc=taus/2.0;
			}
		} else
			tauacc=data[5];
		if (tauacc < data[5]) tauacc=data[5];
		taustab=betan/data[4];
		if (taustab < data[5]) {
			data[10]=1.0;
			break;
		}
		tau = ((tauacc > taustab) ? taustab : tauacc);
		taus=tau;
		if (tau >= (*te)-(*t)) {
			tau=(*te)-(*t);
			last=1;
		}
		tau0=tau1;
		tau1=tau2;
		tau2=tau;
		/* difference scheme */
		mulvec(*m0,*m,0,ro,r,thetha[0]);
		if (p == 3) elmvec(*m0,*m,0,u,r,0.25*tau);
		for (i=1; i<=n-1; i++) {
			mt=mu[i]*tau;
			lt=lambda[i]*tau;
			for (j=(*m0); j<=(*m); j++) r[j]=lt*r[j]+u[j];
			s=(*t)+mt;
			(*derivative)(m0,m,&s,r);
			if (thetha[i] != 0.0) elmvec(*m0,*m,0,ro,r,thetha[i]);
			if (i == n) {
				data[9]=sqrt(vecvec(*m0,*m,0,ro,ro))*tau;
				ec0=ec1;
				ec1=ec2;
				ec2=data[9]/pow(tau,q);
			}
		}
		elmvec(*m0,*m,0,u,r,thetanm1*tau);
		dupvec(*m0,*m,0,r,u);
		s=(*t)+tau;
		(*derivative)(m0,m,&s,r);
		if (thetha[n] != 0.0) elmvec(*m0,*m,0,ro,r,thetha[n]);
		data[9]=sqrt(vecvec(*m0,*m,0,ro,ro))*tau;
		ec0=ec1;
		ec1=ec2;
		ec2=data[9]/pow(tau,q);
		t2=(*t);
		if (last) {
			last=0;
			(*t)=(*te);
		} else
			(*t) += tau;
		data[8] += 1.0;
		(*out)(m0,m,t,te,u,data);
	} while ((*t) != (*te));
	free_real_vector(mu,1);
	free_real_vector(lambda,1);
	free_real_vector(thetha,0);
	free_real_vector(ro,m00);
	free_real_vector(r,m00);
	free_real_matrix(alfa,1,8,1);
}
Пример #26
0
void enx(real_t x, int n1, int n2, real_t a[])
{
	if (x <= 1.5) {
		real_t ei(real_t);
      int i;
		real_t w,e;
		w = -ei(-x);
		if (n1 == 1) a[1]=w;
		if (n2 > 1) e=exp(-x);
		for (i=2; i<=n2; i++) {
			w=(e-x*w)/(i-1);
			if (i >= n1) a[i]=w;
		}
	} else {
		int i,n;
		real_t w,e,an;
		n=ceil(x);
		if (n <= 10) {
			real_t f,w1,t,h,p[20];
			p[2] =0.37534261820491e-1;  p[11]=0.135335283236613;
			p[3] =0.89306465560228e-2;  p[12]=0.497870683678639e-1;
			p[4] =0.24233983686581e-2;  p[13]=0.183156388887342e-1;
			p[5] =0.70576069342458e-3;  p[14]=0.673794699908547e-2;
			p[6] =0.21480277819013e-3;  p[15]=0.247875217666636e-2;
			p[7] =0.67375807781018e-4;  p[16]=0.911881965554516e-3;
			p[8] =0.21600730159975e-4;  p[17]=0.335462627902512e-3;
			p[9] =0.70411579854292e-5;  p[18]=0.123409804086680e-3;
			p[10]=0.23253026570282e-5;  p[19]=0.453999297624848e-4;
			f=w=p[n];
			e=p[n+9];
			w1=t=1.0;
			h=x-n;
			i=n-1;
			do {
				f=(e-i*f)/n;
				t = -h*t/(n-i);
				w1=t*f;
				w += w1;
				i--;
			} while (fabs(w1) > 1.0e-15*w);
		} else {
			real_t *allocate_real_vector(int, int);
			void free_real_vector(real_t *, int);
			void nonexpenx(real_t, int, int, real_t []);
			real_t *b;
			b=allocate_real_vector(n,n);
			nonexpenx(x,n,n,b);
			w=b[n]*exp(-x);
			free_real_vector(b,n);
		}
		if (n1 == n2 && n1 == n)
			a[n]=w;
		else {
			e=exp(-x);
			an=w;
			if (n <= n2 && n >= n1) a[n]=w;
			for (i=n-1; i>=n1; i--) {
				w=(e-i*w)/x;
				if (i <= n2) a[i]=w;
			}
			w=an;
			for (i=n+1; i<=n2; i++) {
				w=(e-x*w)/(i-1);
				if (i >= n1) a[i]=w;
			}
		}
	}
}
Пример #27
0
int peidefunct(int nrow, int ncol, real_t par[], real_t res[],
		int n, int m, int nobs, int *nbp, int first, int *sec,
		int *max, int *nis, real_t eps1, int weight, int bp[],
		real_t save[], real_t ymax[], real_t y[], real_t **yp,
		real_t **fy, real_t **fp, int cobs[], real_t tobs[],
		real_t obs[], real_t in[], real_t aux[], int clean,
		int (*deriv)(int,int,real_t [],real_t [],real_t,real_t []),
		int (*jacdfdy)(int,int,real_t [],real_t [],real_t,real_t **),
		int (*jacdfdp)(int,int,real_t [],real_t [],real_t,real_t **),
		void (*callystart)(int,int,real_t [],real_t [],real_t[]),
		void (*monitor)(int,int,int,real_t [],real_t [],int,int))
{
	/* this function is internally used by PEIDE */

	void peidereset(int, int, real_t, real_t, real_t, real_t, real_t [],
				real_t [], real_t *, real_t *, real_t *, int *);
	void peideorder(int, int, real_t, real_t [], real_t [],
			real_t *, real_t *, real_t *, real_t *, real_t *, int *);
	void peidestep(int, int, int, real_t, real_t, real_t, real_t,
			real_t [], real_t [], real_t [], real_t [], int *, real_t *);
	real_t peideinterpol(int, int, int, real_t, real_t []);
	int l,k,knew,fails,same,kpold,n6,nnpar,j5n,cobsii,*p,evaluate,
			evaluated,decompose,conv,extra,npar,i,j,jj,ii;
	real_t xold,hold,a0,tolup,tol,toldwn,tolconv,h,ch,chnew,error,
			dfi,tobsdif,a[6],*delta,*lastdelta,*df,*y0,**jacob,xend,
			hmax,hmin,eps,s,aa,x,t,c;

	p=allocate_integer_vector(1,n);
	delta=allocate_real_vector(1,n);
	lastdelta=allocate_real_vector(1,n);
	df=allocate_real_vector(1,n);
	y0=allocate_real_vector(1,n);
	jacob=allocate_real_matrix(1,n,1,n);

	if (*sec) {
		*sec=0;
		goto Finish;
	}
	xend=tobs[nobs];
	eps=in[2];
	npar=m;
	extra=(*nis)=0;
	ii=1;
	jj = (*nbp == 0) ? 0 : 1;
	n6=n*6;
	inivec(-3,-1,save,0.0);
	inivec(n6+1,(6+m)*n,y,0.0);
	inimat(1,nobs+(*nbp),1,m+(*nbp),yp,0.0);
	t=tobs[1];
	x=tobs[0];
	(*callystart)(n,m,par,y,ymax);
	hmax=tobs[1]-tobs[0];
	hmin=hmax*in[1];
	/* evaluate jacobian */
	evaluate=0;
	decompose=evaluated=1;
	if (!(*jacdfdy)(n,m,par,y,x,fy)) {
		save[-3]=4.0;
		goto Finish;
	}
	nnpar=n*npar;

	Newstart:
	k=1;
	kpold=0;
	same=2;
	peideorder(n,k,eps,a,save,&tol,&tolup,&toldwn,&tolconv,
					&a0,&decompose);
	if (!(*deriv)(n,m,par,y,x,df)) {
		save[-3]=3.0;
		goto Finish;
	}
	s=FLT_MIN;
	for (i=1; i<=n; i++) {
		aa=matvec(1,n,i,fy,df)/ymax[i];
		s += aa*aa;
	}
	h=sqrt(2.0*eps/sqrt(s));
	if (h > hmax)
		h=hmax;
	else
		if (h < hmin) h=hmin;
	xold=x;
	hold=h;
	ch=1.0;
	for (i=1; i<=n; i++) {
		save[i]=y[i];
		save[n+i]=y[n+i]=df[i]*h;
	}
	fails=0;
	while (x < xend) {
		if (x+h <= xend)
			x += h;
		else {
			h=xend-x;
			x=xend;
			ch=h/hold;
			c=1.0;
			for (j=n; j<=k*n; j += n) {
				c *= ch;
				for (i=j+1; i<=j+n; i++) y[i] *= c;
			}
			same = (same < 3) ? 3 : same+1;
		}
		/* prediction */
		for (l=1; l<=n; l++) {
			for (i=l; i<=(k-1)*n+l; i += n)
				for (j=(k-1)*n+l; j>=i; j -= n) y[j] += y[j+n];
			delta[l]=0.0;
		}
		evaluated=0;
		/* correction and estimation local error */
		for (l=1; l<=3; l++) {
			if (!(*deriv)(n,m,par,y,x,df)) {
				save[-3]=3;
				goto Finish;
			}
			for (i=1; i<=n; i++) df[i]=df[i]*h-y[n+i];
			if (evaluate) {
				/* evaluate jacobian */
				evaluate=0;
				decompose=evaluated=1;
				if (!(*jacdfdy)(n,m,par,y,x,fy)) {
					save[-3]=4.0;
					goto Finish;
				}
			}
			if (decompose) {
				/* decompose jacobian */
				decompose=0;
				c = -a0*h;
				for (j=1; j<=n; j++) {
					for (i=1; i<=n; i++) jacob[i][j]=fy[i][j]*c;
					jacob[j][j] += 1.0;
				}
				dec(jacob,n,aux,p);
			}
			sol(jacob,n,p,df);
			conv=1;
			for (i=1; i<=n; i++) {
				dfi=df[i];
				y[i] += a0*dfi;
				y[n+i] += dfi;
				delta[i] += dfi;
				conv=(conv && (fabs(dfi) < tolconv*ymax[i]));
			}
			if (conv) {
				s=FLT_MIN;
				for (i=1; i<=n; i++) {
					aa=delta[i]/ymax[i];
					s += aa*aa;
				}
				error=s;
				break;
			}
		}
		/* acceptance or rejection */
		if (!conv) {
			if (!evaluated)
				evaluate=1;
			else {
				ch /= 4.0;
				if (h < 4.0*hmin) {
					save[-1] += 10.0;
					hmin /= 10.0;
					if (save[-1] > 40.0) goto Finish;
				}
			}
			peidereset(n,k,hmin,hmax,hold,xold,y,save,&ch,&x,
							&h,&decompose);
		} else if (error > tol) {
			fails++;
			if (h > 1.1*hmin) {
				if (fails > 2) {
					peidereset(n,k,hmin,hmax,hold,xold,y,save,&ch,&x,
								&h,&decompose);
					goto Newstart;
				} else {
					/* calculate step and order */
					peidestep(n,k,fails,tolup,toldwn,tol,error,delta,
								lastdelta,y,ymax,&knew,&chnew);
					if (knew != k) {
						k=knew;
						peideorder(n,k,eps,a,save,&tol,&tolup,
									&toldwn,&tolconv,&a0,&decompose);
					}
					ch *= chnew;
					peidereset(n,k,hmin,hmax,hold,xold,y,save,&ch,&x,
								&h,&decompose);
				}
			} else {
				if (k == 1) {
					/* violate eps criterion */
					save[-2] += 1.0;
					same=4;
					goto Errortestok;
				}
				k=1;
				peidereset(n,k,hmin,hmax,hold,xold,y,save,&ch,&x,
							&h,&decompose);
				peideorder(n,k,eps,a,save,&tol,&tolup,
							&toldwn,&tolconv,&a0,&decompose);
				same=2;
			}
		} else {
			Errortestok:
			fails=0;
			for (i=1; i<=n; i++) {
				c=delta[i];
				for (l=2; l<=k; l++) y[l*n+i] += a[l]*c;
				if (fabs(y[i]) > ymax[i]) ymax[i]=fabs(y[i]);
			}
			same--;
			if (same == 1)
				dupvec(1,n,0,lastdelta,delta);
			else if (same == 0) {
				/* calculate step and order */
				peidestep(n,k,fails,tolup,toldwn,tol,error,delta,
							lastdelta,y,ymax,&knew,&chnew);
				if (chnew > 1.1) {
					if (k != knew) {
						if (knew > k)
							mulvec(knew*n+1,knew*n+n,-knew*n,y,delta,
									a[k]/knew);
						k=knew;
						peideorder(n,k,eps,a,save,&tol,&tolup,
									&toldwn,&tolconv,&a0,&decompose);
					}
					same=k+1;
					if (chnew*h > hmax) chnew=hmax/h;
					h *= chnew;
					c=1.0;
					for (j=n; j<=k*n; j += n) {
						c *= chnew;
						mulvec(j+1,j+n,0,y,y,c);
					}
					decompose=1;
				} else
					same=10;
			}
			(*nis)++;
			/* start of an integration step of yp */
			if (clean) {
				hold=h;
				xold=x;
				kpold=k;
				ch=1.0;
				dupvec(1,k*n+n,0,save,y);
			} else {
				if (h != hold) {
					ch=h/hold;
					c=1.0;
					for (j=n6+nnpar; j<=kpold*nnpar+n6; j += nnpar) {
						c *= ch;
						for (i=j+1; i<=j+nnpar; i++) y[i] *= c;
					}
					hold=h;
				}
				if (k > kpold)
					inivec(n6+k*nnpar+1,n6+k*nnpar+nnpar,y,0.0);
				xold=x;
				kpold=k;
				ch=1.0;
				dupvec(1,k*n+n,0,save,y);
				/* evaluate jacobian */
				evaluate=0;
				decompose=evaluated=1;
				if (!(*jacdfdy)(n,m,par,y,x,fy)) {
					save[-3]=4.0;
					goto Finish;
				}
				/* decompose jacobian */
				decompose=0;
				c = -a0*h;
				for (j=1; j<=n; j++) {
					for (i=1; i<=n; i++) jacob[i][j]=fy[i][j]*c;
					jacob[j][j] += 1.0;
				}
				dec(jacob,n,aux,p);
				if (!(*jacdfdp)(n,m,par,y,x,fp)) {
					save[-3]=5.0;
					goto Finish;
				}
				if (npar > m) inimat(1,n,m+1,npar,fp,0.0);
				/* prediction */
				for (l=0; l<=k-1; l++)
					for (j=k-1; j>=l; j--)
						elmvec(j*nnpar+n6+1,j*nnpar+n6+nnpar,nnpar,
									y,y,1.0);
				/* correction */
				for (j=1; j<=npar; j++) {
					j5n=(j+5)*n;
					dupvec(1,n,j5n,y0,y);
					for (i=1; i<=n; i++)
						df[i]=h*(fp[i][j]+matvec(1,n,i,fy,y0))-
									y[nnpar+j5n+i];
					sol(jacob,n,p,df);
					for (l=0; l<=k; l++) {
						i=l*nnpar+j5n;
						elmvec(i+1,i+n,-i,y,df,a[l]);
					}
				}
			}
			while (x >= t) {
				/* calculate a row of the jacobian matrix and an
					element of the residual vector */
				tobsdif=(tobs[ii]-x)/h;
				cobsii=cobs[ii];
				res[ii]=peideinterpol(cobsii,n,k,tobsdif,y)-obs[ii];
				if (!clean) {
					for (i=1; i<=npar; i++)
						yp[ii][i]=peideinterpol(cobsii+(i+5)*n,nnpar,k,
														tobsdif,y);
					/* introducing break-points */
					if (bp[jj] != ii) {
					} else if (first && fabs(res[ii]) < eps1) {
						(*nbp)--;
						for (i=jj; i<=(*nbp); i++) bp[i]=bp[i+1];
						bp[*nbp+1]=0;
					} else {
						extra++;
						if (first) par[m+jj]=obs[ii];
						/* introducing a jacobian row and a residual
							vector element for continuity requirements */
						yp[nobs+jj][m+jj] = -weight;
						mulrow(1,npar,nobs+jj,ii,yp,yp,weight);
						res[nobs+jj]=weight*(res[ii]+obs[ii]-par[m+jj]);
					}
				}
				if (ii == nobs)
					goto Finish;
				else {
					t=tobs[ii+1];
					if (bp[jj] == ii && jj < *nbp) jj++;
					hmax=t-tobs[ii];
					hmin=hmax*in[1];
					ii++;
				}
			}
			/* break-points introduce new initial values for y & yp */
			if (extra > 0) {
				for (i=1; i<=n; i++) {
					y[i]=peideinterpol(i,n,k,tobsdif,y);
					for (j=1; j<=npar; j++)
						y[i+(j+5)*n]=peideinterpol(i+(j+5)*n,nnpar,
															k,tobsdif,y);
				}
				for (l=1; l<=extra; l++) {
					cobsii=cobs[bp[npar-m+l]];
					y[cobsii]=par[npar+l];
					for (i=1; i<=npar+extra; i++) y[cobsii+(5+i)*n]=0.0;
					inivec(1+nnpar+(l+5)*n,nnpar+(l+6)*n,y,0.0);
					y[cobsii+(5+npar+l)*n]=1.0;
				}
				npar += extra;
				extra=0;
				x=tobs[ii-1];
				/* evaluate jacobian */
				evaluate=0;
				decompose=evaluated=1;
				if (!(*jacdfdy)(n,m,par,y,x,fy)) {
					save[-3]=4.0;
					goto Finish;
				}
				nnpar=n*npar;
				goto Newstart;
			}
		}
	}
	Finish:
	if (save[-2] > *max) *max=save[-2];
	if (!first) (*monitor)(1,ncol,nrow,par,res,weight,*nis);
	free_integer_vector(p,1);
	free_real_vector(delta,1);
	free_real_vector(lastdelta,1);
	free_real_vector(df,1);
	free_real_vector(y0,1);
	free_real_matrix(jacob,1,n,1);
	return (save[-1] <= 40.0 && save[-3] == 0.0);
}
Пример #28
0
void peide(int n, int m, int nobs, int *nbp, real_t par[],
		real_t res[], int bp[], real_t **jtjinv,
		real_t in[], real_t out[],
		int (*deriv)(int,int,real_t [],real_t [],real_t,real_t []),
		int (*jacdfdy)(int,int,real_t [],real_t [],real_t,real_t **),
		int (*jacdfdp)(int,int,real_t [],real_t [],real_t,real_t **),
		void (*callystart)(int,int,real_t [],real_t [],real_t[]),
		void (*data)(int,real_t [],real_t [],int[]),
		void (*monitor)(int,int,int,real_t [],real_t [],int,int))
{
	int i,j,weight,ncol,nrow,away,max,nfe,nis,*cobs,
			first,sec,clean,nbpold,maxfe,fe,it,err,emergency;
	real_t eps1,res1,in3,in4,fac3,fac4,aux[4],*obs,*save,*tobs,
			**yp,*ymax,*y,**fy,**fp,w,**aid,temp,
			vv,ww,w2,mu,res2,fpar,fparpres,lambda,lambdamin,p,pw,
			reltolres,abstolres,em[8],*val,*b,*bb,*parpres,**jaco;
	static real_t save1[35]={1.0, 1.0, 9.0, 4.0, 0.0, 2.0/3.0, 1.0,
			1.0/3.0, 36.0, 20.25, 1.0, 6.0/11.0, 1.0, 6.0/11.0,
			1.0/11.0, 84.028, 53.778, 0.25, 0.48, 1.0, 0.7, 0.2,
			0.02, 156.25, 108.51, 0.027778, 120.0/274.0, 1.0,
			225.0/274.0, 85.0/274.0, 15.0/274.0, 1.0/274.0, 0.0,
			187.69, 0.0047361};

	nbpold=(*nbp);
	cobs=allocate_integer_vector(1,nobs);
	obs=allocate_real_vector(1,nobs);
	save=allocate_real_vector(-38,6*n);
	tobs=allocate_real_vector(0,nobs);
	ymax=allocate_real_vector(1,n);
	y=allocate_real_vector(1,6*n*(nbpold+m+1));
	yp=allocate_real_matrix(1,nbpold+nobs,1,nbpold+m);
	fy=allocate_real_matrix(1,n,1,n);
	fp=allocate_real_matrix(1,n,1,m+nbpold);
	aid=allocate_real_matrix(1,m+nbpold,1,m+nbpold);

	for (i=0; i<=34; i++) save[-38+i]=save1[i];
	(*data)(nobs,tobs,obs,cobs);
	weight=1;
	first=sec=0;
	clean=(*nbp > 0);
	aux[2]=FLT_EPSILON;
	eps1=1.0e10;
	out[1]=0.0;
	bp[0]=max=0;
	/* smooth integration without break-points */
	if (!peidefunct(nobs,m,par,res,
			n,m,nobs,nbp,first,&sec,&max,&nis,eps1,weight,bp,
			save,ymax,y,yp,fy,fp,cobs,tobs,obs,in,aux,clean,deriv,
			jacdfdy,jacdfdp,callystart,monitor)) goto Escape;
	res1=sqrt(vecvec(1,nobs,0,res,res));
	nfe=1;
	if (in[5] == 1.0) {
		out[1]=1.0;
		goto Escape;
	}
	if (clean) {
		first=1;
		clean=0;
		fac3=sqrt(sqrt(in[3]/res1));
		fac4=sqrt(sqrt(in[4]/res1));
		eps1=res1*fac4;
		if (!peidefunct(nobs,m,par,res,
				n,m,nobs,nbp,first,&sec,&max,&nis,eps1,weight,bp,
				save,ymax,y,yp,fy,fp,cobs,tobs,obs,in,aux,clean,deriv,
				jacdfdy,jacdfdp,callystart,monitor)) goto Escape;
		first=0;
	} else
		nfe=0;
	ncol=m+(*nbp);
	nrow=nobs+(*nbp);
	sec=1;
	in3=in[3];
	in4=in[4];
	in[3]=res1;
	weight=away=0;
	out[4]=out[5]=w=0.0;
	temp=sqrt(weight)+1.0;
	weight=temp*temp;
	while (weight != 16 && *nbp > 0) {
		if (away == 0 && w != 0.0) {
			/* if no break-points were omitted then one function
				function evaluation is saved */
			w=weight/w;
			for (i=nobs+1; i<=nrow; i++) {
				for (j=1; j<=ncol; j++) yp[i][j] *= w;
				res[i] *= w;
			}
			sec=1;
			nfe--;
		}
		in[3] *= fac3*weight;
		in[4]=eps1;
		(*monitor)(2,ncol,nrow,par,res,weight,nis);
		/* marquardt's method */
		val=allocate_real_vector(1,ncol);
		b=allocate_real_vector(1,ncol);
		bb=allocate_real_vector(1,ncol);
		parpres=allocate_real_vector(1,ncol);
		jaco=allocate_real_matrix(1,nrow,1,ncol);
		vv=10.0;
		w2=0.5;
		mu=0.01;
		ww = (in[6] < 1.0e-7) ? 1.0e-8 : 1.0e-1*in[6];
		em[0]=em[2]=em[6]=in[0];
		em[4]=10*ncol;
		reltolres=in[3];
		abstolres=in[4]*in[4];
		maxfe=in[5];
		err=0;
		fe=it=1;
		p=fpar=res2=0.0;
		pw = -log(ww*in[0])/2.30;
		if (!peidefunct(nrow,ncol,par,res,
					n,m,nobs,nbp,first,&sec,&max,&nis,eps1,
					weight,bp,save,ymax,y,yp,fy,fp,cobs,tobs,obs,
					in,aux,clean,deriv,jacdfdy,jacdfdp,
					callystart,monitor))
			err=3;
		else {
			fpar=vecvec(1,nrow,0,res,res);
			out[3]=sqrt(fpar);
			emergency=0;
			it=1;
			do {
				dupmat(1,nrow,1,ncol,jaco,yp);
				i=qrisngvaldec(jaco,nrow,ncol,val,aid,em);
				if (it == 1)
					lambda=in[6]*vecvec(1,ncol,0,val,val);
				else
					if (p == 0.0) lambda *= w2;
				for (i=1; i<=ncol; i++)
					b[i]=val[i]*tamvec(1,nrow,i,jaco,res);
				while (1) {
					for (i=1; i<=ncol; i++)
						bb[i]=b[i]/(val[i]*val[i]+lambda);
					for (i=1; i<=ncol; i++)
						parpres[i]=par[i]-matvec(1,ncol,i,aid,bb);
					fe++;
					if (fe >= maxfe)
						err=1;
					else
						if (!peidefunct(nrow,ncol,parpres,res,
								n,m,nobs,nbp,first,&sec,&max,&nis,
								eps1,weight,bp,save,ymax,y,yp,fy,fp,
								cobs,tobs,obs,in,aux,clean,deriv,
								jacdfdy,jacdfdp,callystart,monitor))
							err=2;
					if (err != 0) {
						emergency=1;
						break;
					}
					fparpres=vecvec(1,nrow,0,res,res);
					res2=fpar-fparpres;
					if (res2 < mu*vecvec(1,ncol,0,b,bb)) {
						p += 1.0;
						lambda *= vv;
						if (p == 1.0) {
							lambdamin=ww*vecvec(1,ncol,0,val,val);
							if (lambda < lambdamin) lambda=lambdamin;
						}
						if (p >= pw) {
							err=4;
							emergency=1;
							break;
						}
					} else {
						dupvec(1,ncol,0,par,parpres);
						fpar=fparpres;
						break;
					}
				}
				if (emergency) break;
				it++;
			} while (fpar>abstolres &&
							res2>reltolres*fpar+abstolres);
			for (i=1; i<=ncol; i++)
				mulcol(1,ncol,i,i,jaco,aid,1.0/(val[i]+in[0]));
			for (i=1; i<=ncol; i++)
				for (j=1; j<=i; j++)
					aid[i][j]=aid[j][i]=mattam(1,ncol,i,j,jaco,jaco);
			lambda=lambdamin=val[1];
			for (i=2; i<=ncol; i++)
				if (val[i] > lambda)
					lambda=val[i];
				else
					if (val[i] < lambdamin) lambdamin=val[i];
			temp=lambda/(lambdamin+in[0]);
			out[7]=temp*temp;
			out[2]=sqrt(fpar);
			out[6]=sqrt(res2+fpar)-out[2];
		}
		out[4]=fe;
		out[5]=it-1;
		out[1]=err;
		free_real_vector(val,1);
		free_real_vector(b,1);
		free_real_vector(bb,1);
		free_real_vector(parpres,1);
		free_real_matrix(jaco,1,nrow,1);
		if (out[1] > 0.0) goto Escape;
		/* the relative starting value of lambda is adjusted
			to the last value of lambda used */
		away=out[4]-out[5]-1.0;
		in[6] *= pow(5.0,away)*pow(2.0,away-out[5]);
		nfe += out[4];
		w=weight;
		temp=sqrt(weight)+1.0;
		eps1=temp*temp*in[4]*fac4;
		away=0;
		/* omit useless break-points */
		for (j=1; j<=(*nbp); j++)
			if (fabs(obs[bp[j]]+res[bp[j]]-par[j+m]) < eps1) {
				(*nbp)--;
				for (i=j; i<=(*nbp); i++) bp[i]=bp[i+1];
				dupvec(j+m,(*nbp)+m,1,par,par);
				j--;
				away++;
				bp[*nbp+1]=0;
			}
		ncol -= away;
		nrow -= away;
		temp=sqrt(weight)+1.0;
		weight=temp*temp;
	}
	in[3]=in3;
	in[4]=in4;
	*nbp=0;
	weight=1;
	(*monitor)(2,m,nobs,par,res,weight,nis);
	/* marquardt's method */
	val=allocate_real_vector(1,m);
	b=allocate_real_vector(1,m);
	bb=allocate_real_vector(1,m);
	parpres=allocate_real_vector(1,m);
	jaco=allocate_real_matrix(1,nobs,1,m);
	vv=10.0;
	w2=0.5;
	mu=0.01;
	ww = (in[6] < 1.0e-7) ? 1.0e-8 : 1.0e-1*in[6];
	em[0]=em[2]=em[6]=in[0];
	em[4]=10*m;
	reltolres=in[3];
	abstolres=in[4]*in[4];
	maxfe=in[5];
	err=0;
	fe=it=1;
	p=fpar=res2=0.0;
	pw = -log(ww*in[0])/2.30;
	if (!peidefunct(nobs,m,par,res,
				n,m,nobs,nbp,first,&sec,&max,&nis,eps1,weight,bp,
				save,ymax,y,yp,fy,fp,cobs,tobs,obs,in,aux,clean,
				deriv,jacdfdy,jacdfdp,callystart,monitor))
		err=3;
	else {
		fpar=vecvec(1,nobs,0,res,res);
		out[3]=sqrt(fpar);
		emergency=0;
		it=1;
		do {
			dupmat(1,nobs,1,m,jaco,yp);
			i=qrisngvaldec(jaco,nobs,m,val,jtjinv,em);
			if (it == 1)
				lambda=in[6]*vecvec(1,m,0,val,val);
			else
				if (p == 0.0) lambda *= w2;
			for (i=1; i<=m; i++)
				b[i]=val[i]*tamvec(1,nobs,i,jaco,res);
			while (1) {
				for (i=1; i<=m; i++)
					bb[i]=b[i]/(val[i]*val[i]+lambda);
				for (i=1; i<=m; i++)
					parpres[i]=par[i]-matvec(1,m,i,jtjinv,bb);
				fe++;
				if (fe >= maxfe)
					err=1;
				else
					if (!peidefunct(nobs,m,parpres,res,
							n,m,nobs,nbp,first,&sec,&max,&nis,eps1,
							weight,bp,save,ymax,y,yp,fy,fp,cobs,tobs,
							obs,in,aux,clean,deriv,jacdfdy,jacdfdp,
							callystart,monitor))
						err=2;
				if (err != 0) {
					emergency=1;
					break;
				}
				fparpres=vecvec(1,nobs,0,res,res);
				res2=fpar-fparpres;
				if (res2 < mu*vecvec(1,m,0,b,bb)) {
					p += 1.0;
					lambda *= vv;
					if (p == 1.0) {
						lambdamin=ww*vecvec(1,m,0,val,val);
						if (lambda < lambdamin) lambda=lambdamin;
					}
					if (p >= pw) {
						err=4;
						emergency=1;
						break;
					}
				} else {
					dupvec(1,m,0,par,parpres);
					fpar=fparpres;
					break;
				}
			}
			if (emergency) break;
			it++;
		} while (fpar>abstolres && res2>reltolres*fpar+abstolres);
		for (i=1; i<=m; i++)
			mulcol(1,m,i,i,jaco,jtjinv,1.0/(val[i]+in[0]));
		for (i=1; i<=m; i++)
			for (j=1; j<=i; j++)
				jtjinv[i][j]=jtjinv[j][i]=mattam(1,m,i,j,jaco,jaco);
		lambda=lambdamin=val[1];
		for (i=2; i<=m; i++)
			if (val[i] > lambda)
				lambda=val[i];
			else
				if (val[i] < lambdamin) lambdamin=val[i];
		temp=lambda/(lambdamin+in[0]);
		out[7]=temp*temp;
		out[2]=sqrt(fpar);
		out[6]=sqrt(res2+fpar)-out[2];
	}
	out[4]=fe;
	out[5]=it-1;
	out[1]=err;
	free_real_vector(val,1);
	free_real_vector(b,1);
	free_real_vector(bb,1);
	free_real_vector(parpres,1);
	free_real_matrix(jaco,1,nobs,1);
	nfe += out[4];

	Escape:
	if (out[1] == 3.0)
		out[1]=2.0;
	else
		if (out[1] == 4.0) out[1]=6.0;
	if (save[-3] != 0.0) out[1]=save[-3];
	out[3]=res1;
	out[4]=nfe;
	out[5]=max;
	free_integer_vector(cobs,1);
	free_real_vector(obs,1);
	free_real_vector(save,-38);
	free_real_vector(tobs,0);
	free_real_vector(ymax,1);
	free_real_vector(y,1);
	free_real_matrix(yp,1,nbpold+nobs,1);
	free_real_matrix(fy,1,n,1);
	free_real_matrix(fp,1,n,1);
	free_real_matrix(aid,1,m+nbpold,1);
}
Пример #29
0
real_t flemin(int n, real_t x[], real_t g[], real_t h[],
					real_t (*funct)(int, real_t[], real_t[]),
					real_t in[], real_t out[])
{
	real_t *allocate_real_vector(int, int);
	void free_real_vector(real_t *, int);
	real_t vecvec(int, int, int, real_t [], real_t []);
	void elmvec(int, int, int, real_t [], real_t [], real_t);
	real_t symmatvec(int, int, int, real_t [], real_t []);
	void inivec(int, int, real_t [], real_t);
	void inisymd(int, int, int, real_t [], real_t);
	void mulvec(int, int, int, real_t [], real_t [], real_t);
	void dupvec(int, int, int, real_t [], real_t []);
	void linemin(int, real_t [], real_t [], real_t, real_t *, real_t [],
					real_t (*)(int, real_t[], real_t[]), real_t, real_t *,
					real_t, real_t *, int *, int, real_t []);
	void davupd(real_t [], int, real_t [], real_t [], real_t, real_t);
	void fleupd(real_t [], int, real_t [], real_t [], real_t, real_t);
	int i,it,cntl,evl,evlmax;
	real_t f,f0,fmin,mu,dg,dg0,nrmdelta,alfa,reltol,abstol,eps,tolg,
			aid,*v,*delta,*s;

	v=allocate_real_vector(1,n);
	delta=allocate_real_vector(1,n);
	s=allocate_real_vector(1,n);

	reltol=in[1];
	abstol=in[2];
	mu=in[3];
	tolg=in[4];
	fmin=in[5];
	alfa=in[6];
	evlmax=in[7];
	out[4]=0.0;
	it=0;
	f=(*funct)(n,x,g);
	evl=1;
	cntl=0;
	if (alfa > 0.0) {
		inivec(1,(n*(n+1))/2,h,0.0);
		inisymd(1,n,0,h,alfa);
	}
	for (i=1; i<=n; i++) delta[i] = -symmatvec(1,n,i,h,g);
	dg=sqrt(vecvec(1,n,0,g,g));
	nrmdelta=sqrt(vecvec(1,n,0,delta,delta));
	eps=sqrt(vecvec(1,n,0,x,x))*reltol+abstol;
	dg0=vecvec(1,n,0,delta,g);
	it++;
	while ((nrmdelta > eps || dg > tolg) && (evl < evlmax)) {
		dupvec(1,n,0,s,x);
		dupvec(1,n,0,v,g);
		if (it >= n)
			alfa=1.0;
		else {
			if (it != 1)
				alfa /= nrmdelta;
			else {
				alfa=2.0*(fmin-f)/dg0;
				if (alfa > 1.0) alfa=1.0;
			}
		}
		elmvec(1,n,0,x,delta,alfa);
		f0=f;
		f=(*funct)(n,x,g);
		evl++;
		dg=vecvec(1,n,0,delta,g);
		if (it == 1 || f0-f < -mu*dg0*alfa) {
			/* line minimization */
			i=evlmax-evl;
			cntl++;
			linemin(n,s,delta,nrmdelta,&alfa,g,funct,f0,&f,
						dg0,&dg,&i,0,in);
			evl += i;
			dupvec(1,n,0,x,s);
		}
		if (alfa != 1.0) mulvec(1,n,0,delta,delta,alfa);
		mulvec(1,n,0,v,v,-1.0);
		elmvec(1,n,0,v,g,1.0);
		for (i=1; i<=n; i++) s[i]=symmatvec(1,n,i,h,v);
		aid=vecvec(1,n,0,v,s);
		dg=(dg-dg0)*alfa;
		if (dg > 0.0)
			if (dg >= aid)
				fleupd(h,n,delta,s,1.0/dg,(1.0+aid/dg)/dg);
			else
				davupd(h,n,delta,s,1.0/dg,1.0/aid);
		for (i=1; i<=n; i++) delta[i] = -symmatvec(1,n,i,h,g);
		alfa *= nrmdelta;
		nrmdelta=sqrt(vecvec(1,n,0,delta,delta));
		eps=sqrt(vecvec(1,n,0,x,x))*reltol+abstol;
		dg=sqrt(vecvec(1,n,0,g,g));
		dg0=vecvec(1,n,0,delta,g);
		if (dg0 > 0.0) {
			out[4] = -1.0;
			break;
		}
		it++;
	}
	out[0]=nrmdelta;
	out[1]=dg;
	out[2]=evl;
	out[3]=cntl;
	free_real_vector(v,1);
	free_real_vector(delta,1);
	free_real_vector(s,1);
	return f;
}
Пример #30
0
void efsirk(real_t *x, real_t xe, int m, real_t y[],
			real_t *delta, void (*derivative)(int, real_t[], real_t *),
			void (*jacobian)(int, real_t **, real_t [], real_t *),
			real_t **j, int *n, real_t aeta, real_t reta, real_t hmin,
			real_t hmax, int linear,
			void (*output)(real_t, real_t, int, real_t [],
								real_t, real_t **, int))
{
	int *allocate_integer_vector(int, int);
	real_t *allocate_real_vector(int, int);
	real_t **allocate_real_matrix(int, int, int, int);
	void free_integer_vector(int *, int);
	void free_real_vector(real_t *, int);
	void free_real_matrix(real_t **, int, int, int);
	real_t vecvec(int, int, int, real_t [], real_t []);
	real_t matmat(int, int, int, int, real_t **, real_t **);
	real_t matvec(int, int, int, real_t **, real_t []);
	void gsselm(real_t **, int, real_t [], int [], int []);
	void solelm(real_t **, int, int [], int [], real_t []);
	int k,l,lin,*ri,*ci;
	real_t step,h,mu0,mu1,mu2,theta0,theta1,nu1,nu2,nu3,yk,fk,c1,c2,
			d,*f,*k0,*labda,**j1,aux[8],discr,eta,s,z1,z2,e,alpha1,a,b;

	ri=allocate_integer_vector(1,m);
	ci=allocate_integer_vector(1,m);
	f=allocate_real_vector(1,m);
	k0=allocate_real_vector(1,m);
	labda=allocate_real_vector(1,m);
	j1=allocate_real_matrix(1,m,1,m);

	aux[2]=FLT_EPSILON;
	aux[4]=8.0;
	for (k=1; k<=m; k++) f[k]=y[k];
	*n = 0;
	(*output)(*x,xe,m,y,*delta,j,*n);
	step=0.0;
	do {
		(*n)++;
		/* difference scheme */
		(*derivative)(m,f,delta);
		/* step size */
		if (linear)
			s=h=hmax;
		else
			if (*n == 1 || hmin == hmax)
				s=h=hmin;
			else {
				eta=aeta+reta*sqrt(vecvec(1,m,0,y,y));
				c1=nu3*step;
				for (k=1; k<=m; k++) labda[k] += c1*f[k]-y[k];
				discr=sqrt(vecvec(1,m,0,labda,labda));
				s=h=(eta/(0.75*(eta+discr))+0.33)*h;
				if (h < hmin)
					s=h=hmin;
				else
					if (h > hmax) s=h=hmax;
			}
		if ((*x)+s > xe) s=xe-(*x);
		lin=((step == s) && linear);
		step=s;
		if (!linear || *n == 1) (*jacobian)(m,j,y,delta);
		if (!lin) {
			/* coefficient */
			z1=step*(*delta);
			if (*n == 1) z2=z1+z1;
			if (fabs(z2-z1) > 1.0e-6*fabs(z1) || z2 > -1.0) {
				a=z1*z1+12.0;
				b=6.0*z1;
				if (fabs(z1) < 0.1)
					alpha1=(z1*z1/140.0-1.0)*z1/30.0;
				else if (z1 < 1.0e-14)
					alpha1=1.0/3.0;
				else if (z1 < -33.0)
					alpha1=(a+b)/(3.0*z1*(2.0+z1));
				else {
					e=((z1 < 230.0) ? exp(z1) : FLT_MAX);
					alpha1=((a-b)*e-a-b)/(((2.0-z1)*e-2.0-z1)*3.0*z1);
				}
				mu2=(1.0/3.0+alpha1)*0.25;
				mu1 = -(1.0+alpha1)*0.5;
				mu0=(6.0*mu1+2.0)/9.0;
				theta0=0.25;
				theta1=0.75;
				a=3.0*alpha1;
				nu3=(1.0+a)/(5.0-a)*0.5;
				a=nu3+nu3;
				nu1=0.5-a;
				nu2=(1.0+a)*0.75;
				z2=z1;
			}
			c1=step*mu1;
			d=step*step*mu2;
			for (k=1; k<=m; k++) {
				for (l=1; l<=m; l++)
					j1[k][l]=d*matmat(1,m,k,l,j,j)+c1*j[k][l];
				j1[k][k] += 1.0;
			}
			gsselm(j1,m,aux,ri,ci);
		}
		c1=step*step*mu0;
		d=step*2.0/3.0;
		for (k=1; k<=m; k++) {
			k0[k]=fk=f[k];
			labda[k]=d*fk+c1*matvec(1,m,k,j,f);
		}
		solelm(j1,m,ri,ci,labda);
		for (k=1; k<=m; k++) f[k]=y[k]+labda[k];
		(*derivative)(m,f,delta);
		c1=theta0*step;
		c2=theta1*step;
		d=nu1*step;
		for (k=1; k<=m; k++) {
			yk=y[k];
			fk=f[k];
			labda[k]=yk+d*fk+nu2*labda[k];
			y[k]=f[k]=yk+c1*k0[k]+c2*fk;
		}
		(*x) += step;
		(*output)(*x,xe,m,y,*delta,j,*n);
	} while (*x < xe);
	free_integer_vector(ri,1);
	free_integer_vector(ci,1);
	free_real_vector(f,1);
	free_real_vector(k0,1);
	free_real_vector(labda,1);
	free_real_matrix(j1,1,m,1);
}