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);
}
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];
}
void arkmat(real_t *t, real_t te, int m, int n, real_t **u,
void (*der)(int, int, real_t, real_t **, real_t **),
int type, int *order, real_t *spr,
void (*out)(real_t, real_t, int, int, real_t **, int,
int, real_t *))
{
real_t **allocate_real_matrix(int, int, int, int);
void free_real_matrix(real_t **, int, int, int);
void elmcol(int, int, int, int, real_t **, real_t **, real_t);
void dupmat(int, int, int, int, real_t **, real_t **);
int sig,l,last,ta,tb,i;
real_t tau,lambda[10],**uh,**du,mlt;
static real_t lbd1[9]={1.0/9.0, 1.0/8.0, 1.0/7.0, 1.0/6.0,
1.0/5.0, 1.0/4.0, 1.0/3.0, 1.0/2.0, 4.3};
static real_t lbd2[9]={0.1418519249e-2, 0.3404154076e-2,
0.0063118569, 0.01082794375, 0.01842733851,
0.03278507942, 0.0653627415, 0.1691078577, 156.0};
static real_t lbd3[9]={0.3534355908e-2, 0.8532600867e-2,
0.015956206, 0.02772229155, 0.04812587964,
0.08848689452, 0.1863578961, 0.5, 64.0};
static real_t lbd4[9]={1.0/8.0, 1.0/20.0, 5.0/32.0, 2.0/17.0,
17.0/80.0, 5.0/22.0, 11.0/32.0, 1.0/2.0, 8.0};
uh=allocate_real_matrix(1,n,1,m);
du=allocate_real_matrix(1,n,1,m);
/* initialize */
if (type != 2 && type != 3) type=1;
if (type != 2)
*order = 2;
else
if (*order != 2) *order = 1;
switch ((type == 1) ? 1 : type+(*order)-1) {
case 1: for (i=0; i<=8; i++) lambda[i+1]=lbd1[i]; break;
case 2: for (i=0; i<=8; i++) lambda[i+1]=lbd2[i]; break;
case 3: for (i=0; i<=8; i++) lambda[i+1]=lbd3[i]; break;
case 4: for (i=0; i<=8; i++) lambda[i+1]=lbd4[i]; break;
}
sig = ((te == *t) ? 0 : ((te > *t) ? 1 : -1));
last=0;
do {
tau=((*spr == 0.0) ? fabs(te-(*t)) :
fabs(lambda[9]/(*spr)))*sig;
ta = (*t)+tau >= te;
tb = tau >= 0.0;
if ((ta && tb) || (!(ta || tb))) {
tau=te-(*t);
last=1;
}
/* difference scheme */
(*der)(m,n,*t,u,du);
for (i=1; i<=8; i++) {
mlt=lambda[i]*tau;
dupmat(1,n,1,m,uh,u);
for (l=1; l<=m; l++) elmcol(1,n,l,l,uh,du,mlt);
(*der)(m,n,(*t)+mlt,uh,du);
}
for (l=1; l<=m; l++) elmcol(1,n,l,l,u,du,tau);
*t = (last ? te : (*t)+tau);
(*out)(*t,te,m,n,u,type,*order,spr);
} while (!last);
free_real_matrix(uh,1,n,1);
free_real_matrix(du,1,n,1);
}