BEGIN_C_DECLS
/*--------------------------------------------------------------------------*/
fint hos_forward_(fint* ftag,
fint* fm,
fint* fn,
fint* fd,
fint* fk,
fdouble* fbase,
fdouble* fx,
fdouble* fvalue,
fdouble* fy) {
int rc= -1;
int tag=*ftag, m=*fm, n=*fn, d=*fd, k=*fk;
double* base = myalloc1(n);
double* value = myalloc1(m);
double** X = myalloc2(n,d);
double** Y = myalloc2(m,d);
spread1(n,fbase,base);
spread2(n,d,fx,X);
rc= hos_forward(tag,m,n,d,k,base,X,value,Y);
pack2(m,d,Y,fy);
pack1(m,value,fvalue);
free((char*)*X);
free((char*)X);
free((char*)*Y);
free((char*)Y);
free((char*)base);
free((char*)value);
return rc;
}
int inverse_Taylor_prop( unsigned short tag, int n, int d,
double** Y, double** X ) {
int i,j,l,q;
static double **I;
register double bi;
static double** Xhelp;
static double** W;
static double* xold;
static double ***A;
static double *w;
static int *dd;
static double *b;
static int nax,dax,bd,cgd;
static short **nonzero;
short* nz;
double* Aij;
double* Xj;
int ii, di, da, Di;
int rc = 3;
/* Re/Allocation Stuff */
if ((n != nax) || (d != dax)) {
if (nax) {
free(**A);
free(*A);
free(A);
free(*I);
free(I);
free(*W);
free(W);
free(*Xhelp);
free(Xhelp);
free(w);
free(xold);
free(*nonzero);
free(nonzero);
free(dd);
free(b);
}
A = myalloc3(n,n,d+1);
I = myalloc2(n,n);
W = myalloc2(n,d);
Xhelp = myalloc2(n,d);
w = myalloc1(n);
dd = (int*)malloc((d+1)*sizeof(int));
b = (double*)malloc(n*sizeof(double));
xold = (double*)malloc(n*sizeof(double));
nonzero = (short**)malloc(n*sizeof(short*));
nz = (short*)malloc(n*n*sizeof(short));
for (i=0; i<n; i++) {
nonzero[i] = nz;
nz = nz + n;
xold[i] = 0;
for (j=0; j<n; j++)
I[i][j]=(i==j)?1.0:0.0;
}
cgd = 1;
nax=n;
dax=d;
dd[0] = d+1;
i = -1;
while(dd[++i] > 1)
dd[i+1] = (int)ceil(dd[i]*0.5);
bd = i+1;
}
if (cgd == 0)
for (i=0; i<n; i++)
if (X[i][0] != xold[i])
cgd = 1;
if (cgd == 1) {
cgd = 0;
for (i=0; i<n; i++)
xold[i] = X[i][0];
MINDEC(rc,jac_solv(tag,n,xold,b,0,1));
if (rc == -3)
return -3;
}
ii = bd;
for (i=0; i<n; i++)
for (j=0; j<d; j++)
Xhelp[i][j] = X[i][j+1];
while (--ii > 0) {
di = dd[ii-1]-1;
Di = dd[ii-1]-dd[ii]-1;
MINDEC(rc,hos_forward(tag,n,n,di,Di+1,xold,Xhelp,w,W));
MINDEC(rc,hov_reverse(tag,n,n,Di,n,I,A,nonzero));
da = dd[ii];
for (l=da; l<dd[ii-1]; l++) {
for (i=0; i<n; i++) {
if (l == 0)
bi = w[i]-Y[i][0];
else
bi = W[i][l-1]-Y[i][l];
for (j=0; j<n; j++)
if (nonzero[i][j]>1) {
Aij = A[i][j];
Xj = X[j]+l;
for (q=da; q<l; q++)
bi += (*(++Aij))*(*(--Xj));
}
b[i] = -bi;
}
MINDEC(rc,jac_solv(tag,n,xold,b,0,2));
if (rc == -3)
return -3;
for (i=0; i<n; i++) {
X[i][l] += b[i];
/* 981214 new nl */
Xhelp[i][l-1] += b[i];
}
}
}
return rc;
}
bool link_poly(
size_t size ,
size_t repeat ,
CppAD::vector<double> &a , // coefficients of polynomial
CppAD::vector<double> &z , // polynomial argument value
CppAD::vector<double> &ddp ) // second derivative w.r.t z
{
// -----------------------------------------------------
// setup
int tag = 0; // tape identifier
int keep = 1; // keep forward mode results in buffer
int m = 1; // number of dependent variables
int n = 1; // number of independent variables
int d = 2; // order of the derivative
double f; // function value
int i; // temporary index
// choose a vector of polynomial coefficients
CppAD::uniform_01(size, a);
// AD copy of the polynomial coefficients
std::vector<adouble> A(size);
for(i = 0; i < int(size); i++)
A[i] = a[i];
// domain and range space AD values
adouble Z, P;
// allocate arguments to hos_forward
double *x0 = 0;
x0 = CPPAD_TRACK_NEW_VEC(n, x0);
double *y0 = 0;
y0 = CPPAD_TRACK_NEW_VEC(m, y0);
double **x = 0;
x = CPPAD_TRACK_NEW_VEC(n, x);
double **y = 0;
y = CPPAD_TRACK_NEW_VEC(m, y);
for(i = 0; i < n; i++)
{ x[i] = 0;
x[i] = CPPAD_TRACK_NEW_VEC(d, x[i]);
}
for(i = 0; i < m; i++)
{ y[i] = 0;
y[i] = CPPAD_TRACK_NEW_VEC(d, y[i]);
}
// Taylor coefficient for argument
x[0][0] = 1.; // first order
x[0][1] = 0.; // second order
extern bool global_retape;
if( global_retape ) while(repeat--)
{ // choose an argument value
CppAD::uniform_01(1, z);
// declare independent variables
trace_on(tag, keep);
Z <<= z[0];
// AD computation of the function value
P = CppAD::Poly(0, A, Z);
// create function object f : Z -> P
P >>= f;
trace_off();
// get the next argument value
CppAD::uniform_01(1, z);
x0[0] = z[0];
// evaluate the polynomial at the new argument value
hos_forward(tag, m, n, d, keep, x0, x, y0, y);
// second derivative is twice second order Taylor coef
ddp[0] = 2. * y[0][1];
}
else
{
BEGIN_C_DECLS
/****************************************************************************/
/* DRIVERS FOR ODEs */
/*--------------------------------------------------------------------------*/
/* forodec */
/* forodec(tag, n, tau, dold, dnew, X[n][d+1]) */
int forodec(short tag, /* tape identifier */
int n, /* space dimension */
double tau, /* scaling defaults to 1.0 */
int dol, /* previous degree defaults to zero */
int deg, /* New degree of consistency */
double** Y) /* Taylor series */
{
/*********************************************************************
This is assumed to be the autonomous case.
Here we are just going around computing the vectors
y[][j] for dol < j <= deg
by successive calls to forward that works on the tape identified
by tag. This tape (array of file) must obviously have been
generated by a the execution of an active section between
trace_on and trace_off with n independent and n dependent variables
y must have been set up as pointer to an array of n pointers
to double arrays containing at least deg+1 components.
The scaling by tau is sometimes necessary to avoid overflow.
**********************************************************************/
int rc= 3;
int i, j, k;
double taut;
ADOLC_OPENMP_THREAD_NUMBER;
ADOLC_OPENMP_GET_THREAD_NUMBER;
if ( n > ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_nax ||
deg > ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_dax )
{
if (ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_nax) {
myfree1(ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_y);
myfree1(ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_z);
myfree2(ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_Z);
}
ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_Z = myalloc2(n, deg);
ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_z = myalloc1(n);
ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_y = myalloc1(n);
ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_nax = n;
ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_dax = deg;
}
for (i = 0; i < n; ++i) {
ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_y[i] = Y[i][0];
/*printf("y[%i] = %f\n",i,y[i]);*/
for (k = 0; k < deg; ++k) {
Y[i][k] = Y[i][k+1];
/*printf("Y[%i][%i] = %f\n",i,k,Y[i][k]);*/
}
}
/****** Here we get going ********/
if (dol == 0) {
j = dol; /* j = 0 */
k = (deg) * (j == deg-1 ) ; /* keep death values in prepration */
MINDEC(rc, zos_forward(tag, n, n, k,
ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_y,
ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_z));
/* for reverse called by jacode */
if(rc < 0) return rc;
taut = tau / (1 + j); /* only the last time through. */
for (i = 0; i < n; ++i)
Y[i][j] = taut * ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_z[i];
dol++; /* !!! */
}
for (j = dol; j < deg; ++j) {
k = (deg)*(j == deg-1) ; /* keep death values in prepration */
MINDEC(rc, hos_forward(tag, n, n, j, k,
ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_y,
Y, ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_z,
ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_Z));
/* for reverse called by jacode */
if( rc < 0) return rc;
taut = tau / (1 + j); /* only the last time through. */
for (i = 0; i < n; ++i)
Y[i][j] = taut *
ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_Z[i][j-1];
}
/****** Done ********/
for (i = 0; i < n; ++i) {
for (k = deg; k > 0; --k) {
Y[i][k] = Y[i][k-1];
/*printf("Y[%i][%i] = %f\n",i,k,Y[i][k]);*/
}
Y[i][0] = ADOLC_CURRENT_TAPE_INFOS.pTapeInfos.forodec_y[i];
/*printf("Y[%i][0] = %f\n",i,Y[i][0]);*/
}
return rc;
}
