Doub rtnewt(T &funcd, const Doub x1, const Doub x2, const Doub xacc) {
cout << setiosflags(ios::fixed) << setprecision(10);
cout << "k|\t\tx(k)\t\t\td(k)\t\t\t\td/d" << endl;
cout << "--------------------------------------------------------" << endl;
const Int JMAX=20;
Doub rtn=0.5*(x1+x2);
Doub oldrtn;
Doub oldd, d;
for (Int j=0;j<JMAX;j++) {
Doub f=funcd(rtn);
Doub df=funcd.df(rtn);
Doub dx=f/df;
rtn -= dx;
cout << j << "|\t\t" << rtn;
if (j > 0) {
d = rtn - oldrtn;
cout << "\t" << d;
}
if (j > 1) {
cout << "\t\t" << d / oldd;
}
cout << endl;
oldrtn = rtn;
oldd = d;
if ((x1-rtn)*(rtn-x2) < 0.0)
throw("Jumped out of brackets in rtnewt");
if (abs(dx) < xacc) return rtn;
}
throw("Maximum number of iterations exceeded in rtnewt");
}
void gl_rs_distfunc( double *pa,double *pb,double *pc,double *pd,
double *px1,double *px2,double *pxacc, int *max_it,
double *ecks, double *u, int *pl)
{
/* pa to pd: pointers to the values of the parameters of the gld (rs param)
* px1: minimum value of u, should be zero
* px2: maximum value of u, should be 1
* pxacc: desired accuracy of the calculation
* max_it: maximum iterations for N-R root finder
* ecks: the quantiles of the gld given
* u: array to put the calculated depths
* pl: length of the data
*/
double x1, x2, xacc;
double a, b, c, d;
int l;
int i,j;
double df,dx,dxold,f,fh,fl;
double temp,xh,xl,rts;
void funcd();
x1 = *px1; x2 = *px2; xacc = *pxacc;
a = *pa; b = *pb; c = *pc; d = *pd;
l = *pl;
la = a; lb = b; lc = c; ld = d;
/* The C version has something here to force the limits to be xacc and 1-xacc
rather than 0 and 1 if lambda3 and lambda4 are negative. I can't
see why, so I'm leaving it out.*/
for (i=0;i<l;i++)
{
x = ecks[i];
u[i] = 0.0;
funcd(x1,&fl,&df);
funcd(x2,&fh,&df);
if (fl*fh >= 0.0) {
error("gld package C code numerical failure (this should not happen - please report to maintainer)\n Program aborted during calculation of F(x)\n at parameter values %f, %f, %f, %f\n The x value was index: %d, value %f\n",*pa, *pb, *pc, *pd, i, x);
}
if (fl < 0.0) {
xl = x1;
xh = x2;
}
else {
xh = x1;
xl = x2;
}
rts = 0.5*(x1+x2);
dxold = fabs(x2-x1);
dx = dxold;
funcd(rts,&f,&df);
for (j=1;j<= *max_it;j++) {
if ((((rts - xh)*df - f)* ( (rts-xl)*df - f) >= 0.0 ) ||
( fabs(2.0*f) > fabs (dxold*df))) {
dxold = dx;
dx = .5* (xh - xl);
rts = xl +dx;
if (xl == rts ) { u[i] = rts; break; }
}
else {
dxold = dx;
dx = f/df;
temp = rts;
rts -= dx;
if (temp == rts) { u[i] = rts; break; }
}
if (fabs(dx) < xacc) { u[i] = rts; break; }
funcd(rts,&f,&df);
if (f < 0.0)
xl =rts;
else
xh =rts;
}
}
}
void gl_rs_distfunc_p( double *pa,double *pb,double *pc,double *pd,
double *px1,double *px2,double *pxacc, int *max_it,
double **ecks, double *u, int *pl,double *tolR)
{
/* pa to pd: pointers to the values of the parameters of the gld (rs param)
* px1: minimum value of u, should be zero
* px2: maximum value of u, should be 1
* pxacc: desired accuracy of the calculation
* max_it: maximum iterations for N-R root finder
* ecks: the quantiles of the gld given
* u: array to put the calculated depths
* pl: length of the data
*/
double x1, x2, xacc;
double a, b, c, d;
int l;
int i,j;
double df,dx,dxold,f,fh,fl;
double temp,xh,xl,rts;
x1 = *px1; x2 = *px2; xacc = *pxacc;
a = *pa; b = *pb; c = *pc; d = *pd;
l = *pl, tol = *tolR;
la = a; lb = b; lc = c; ld = d;
/* Robert King's comment: The C version force the limits to be xacc and 1-xacc
rather than 0 and 1 if lambda3 and lambda4 are negative. */
for (i=0;i<l;i++)
{
x = *ecks[i];
u[i] = 0.0;
funcd(x1,&fl,&df);
funcd(x2,&fh,&df);
if (fl*fh >= 0.0) {
error("C code numerical failure");
/* fprintf(stderr,"Program aborted during calculation of F(x)");
fprintf(stderr,"at parameter values %e, %e, %e, %e\n", *pa, *pb, *pc, *pd);
fprintf(stderr,"The x value being investigated was index: %d",i);
fprintf(stderr," value: %f\n",x);
exit(1);
*/
}
if (fl < 0.0) {
xl = x1;
xh = x2;
}
else {
xh = x1;
xl = x2;
}
rts = 0.5*(x1+x2);
dxold = fabs(x2-x1);
dx = dxold;
funcd(rts,&f,&df);
for (j=1;j<= *max_it;j++) {
if ((((rts - xh)*df - f)* ( (rts-xl)*df - f) >= 0.0 ) ||
( fabs(2.0*f) > fabs (dxold*df))) {
dxold = dx;
dx = .5* (xh - xl);
rts = xl +dx;
if (xl == rts ) { u[i] = rts; break; }
}
else {
dxold = dx;
dx = f/df;
temp = rts;
rts -= dx;
if (temp == rts) { u[i] = rts; break; }
}
if (fabs(dx) < xacc) { u[i] = rts; break; }
funcd(rts,&f,&df);
if (f < 0.0)
xl =rts;
else
xh =rts;
}
}
}
