/*--------------------------------------------------------------------------*/ fint zos_forward_(fint* ftag, fint* fm, fint* fn, fint* fk, fdouble* fbase, fdouble* fvalue) { int rc=-1; int tag=*ftag, m=*fm, n=*fn, k=*fk; double* base=myalloc1(n); double* value = myalloc1(m); spread1(n,fbase,base); rc=zos_forward(tag,m,n,k,base,value); pack1(m,value,fvalue); free((char*)base); free((char*)value); return rc; }
/* hess_vec(tag, n, x[n], v[n], w[n]) */ fint hess_vec_(fint* ftag, fint* fn, fdouble *fargument, fdouble *ftangent, fdouble *fresult) { int rc= -1; int tag=*ftag, n=*fn; double *argument = myalloc1(n); double *tangent = myalloc1(n); double *result = myalloc1(n); spread1(n,fargument,argument); spread1(n,ftangent,tangent); rc= hess_vec(tag,n,argument,tangent,result); pack1(n,result,fresult); free((char*)argument); free((char*)tangent); free((char*)result); return rc; }
/* jac_vec(tag, m, n, x[n], v[n], u[m]); */ fint jac_vec_(fint* ftag, fint* fm, fint* fn, fdouble* fargument, fdouble* ftangent, fdouble* fcolumn) { int rc= -1; int tag=*ftag, m=*fm, n=*fn; double* argument = myalloc1(n); double* tangent = myalloc1(n); double* column = myalloc1(m); spread1(n,ftangent,tangent); spread1(n,fargument,argument); rc= jac_vec(tag,m,n,argument,tangent,column); pack1(m,column,fcolumn); free((char*)argument); free((char*)tangent); free((char*)column); return rc; }
/* vec_jac(tag, m, n, repeat, x[n], u[m], v[n]) */ fint vec_jac_(fint* ftag, fint* fm, fint* fn, fint* frepeat, fdouble* fargument, fdouble* flagrange, fdouble* frow) { int rc= -1; int tag=*ftag, m=*fm, n=*fn, repeat=*frepeat; double* argument = myalloc1(n); double* lagrange = myalloc1(m); double* row = myalloc1(n); spread1(m,flagrange,lagrange); spread1(n,fargument,argument); rc= vec_jac(tag,m,n,repeat,argument,lagrange, row); pack1(n,row,frow); free((char*)argument); free((char*)lagrange); free((char*)row); return rc; }
BEGIN_C_DECLS /****************************************************************************/ /* DRIVERS FOR OPTIMIZATION AND NONLINEAR EQUATIONS */ /*--------------------------------------------------------------------------*/ /* function */ /* function(tag, m, n, x[n], y[m]) */ fint function_(fint* ftag, fint* fm, fint* fn, fdouble* fargument, fdouble* fresult) { int rc= -1; int tag=*ftag, m=*fm, n=*fn; double* argument = myalloc1(n); double* result = myalloc1(m); spread1(n,fargument,argument); rc= function(tag,m,n,argument,result); pack1(m,result,fresult); free((char*)argument); free((char*)result); return rc; }
/* lagra_hess_vec(tag, m, n, x[n], v[n], u[m], w[n]) */ fint lagra_hess_vec_(fint* ftag, fint* fm, fint* fn, fdouble *fargument, fdouble *ftangent, fdouble *flagrange, fdouble *fresult) { int rc=-1; int tag=*ftag, m=*fm, n=*fn; double *argument = myalloc1(n); double *tangent = myalloc1(n); double *lagrange = myalloc1(m); double *result = myalloc1(n); spread1(n,fargument,argument); spread1(n,ftangent,tangent); spread1(m,flagrange,lagrange); rc= lagra_hess_vec(tag,m,n,argument,tangent,lagrange,result); pack1(n,result,fresult); free((char*)argument); free((char*)tangent); free((char*)lagrange); free((char*)result); return rc; }
/* jacobian(tag, m, n, x[n], J[m][n]) */ fint jacobian_(fint* ftag, fint* fdepen, fint* findep, fdouble *fargument, fdouble *fjac) { int rc= -1; int tag=*ftag, depen=*fdepen, indep=*findep; double** Jac = myalloc2(depen,indep); double* argument = myalloc1(indep); spread1(indep,fargument,argument); rc= jacobian(tag,depen,indep,argument,Jac); pack2(depen,indep,Jac,fjac); free((char*)*Jac); free((char*)Jac); free((char*)argument); return rc; }
/*--------------------------------------------------------------------------*/ void GauszSolve( double** J, int n, int* RI, int* CI, double* b ) { double* tmpZ; int i,j; tmpZ = myalloc1(n); for (i=0; i<n; i++) { tmpZ[i]=b[RI[i]]; for (j=0; j<i; j++) tmpZ[i]-=J[RI[i]][CI[j]]*tmpZ[j]; } for (i=n-1; i>=0; i--) { b[CI[i]]=tmpZ[i]; for (j=i+1; j<n; j++) b[CI[i]]-=J[RI[i]][CI[j]]*b[CI[j]]; b[CI[i]]/=J[RI[i]][CI[i]]; } free(tmpZ); }
/*--------------------------------------------------------------------------*/ fint hos_reverse_(fint* ftag, fint* fm, fint* fn, fint* fd, fdouble* fu, fdouble* fz) { int rc=-1; int tag=*ftag, m=*fm, n=*fn, d=*fd; double** Z = myalloc2(n,d+1); double* u = myalloc1(m); spread1(m,fu,u); rc=hos_reverse(tag,m,n,d,u,Z); pack2(n,d+1,Z,fz); free((char*)*Z); free((char*)Z); free((char*)u); return rc; }
/* hessian(tag, n, x[n], lower triangle of H[n][n]) */ fint hessian_(fint* ftag, fint* fn, fdouble* fx, fdouble* fh) /* length of h should be n*n but the upper half of this matrix remains unchanged */ { int rc= -1; int tag=*ftag, n=*fn; double** H = myalloc2(n,n); double* x = myalloc1(n); spread1(n,fx,x); rc= hessian(tag,n,x,H); pack2(n,n,H,fh); free((char*)*H); free((char*)H); free((char*)x); 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; }
int jac_solv( unsigned short tag, int n, double* x, double* b, unsigned short sparse, unsigned short mode ) { static double **J; static double **I; static double *y; static double *xold; static int* ri; static int* ci; static int nax,tagold,modeold,cgd; int i,j; int rc = 3; if ((n != nax) || (tag != tagold)) { if (nax) { free(*J); free(J); free(*I); free(I); free(xold); free(ri); free(ci); free(y); } J = myalloc2(n,n); I = myalloc2(n,n); y = myalloc1(n); xold = myalloc1(n); ri = (int*)malloc(n*sizeof(int)); ci = (int*)malloc(n*sizeof(int)); for (i=0; i<n; i++) { xold[i] = 0; for (j=0;j<n;j++) I[i][j]=(i==j)?1.0:0.0; } cgd = 1; modeold = 0; nax = n; tagold = tag; } if (cgd == 0) for (i=0; i<n; i++) if (x[i] != xold[i]) cgd = 1; if (cgd == 1) for (i=0; i<n; i++) xold[i] = x[i]; switch(mode) { case 0: MINDEC(rc,zos_forward(tag,n,n,1,x,y)); MINDEC(rc,fov_reverse(tag,n,n,n,I,J)); break; case 1: if ((modeold == 0) || (cgd == 1)) { MINDEC(rc,zos_forward(tag,n,n,1,x,y)); MINDEC(rc,fov_reverse(tag,n,n,n,I,J)); } if (LUFactorization(J,n,ri,ci) < 0) return -3; modeold = 1; break; case 2: if ((modeold < 1) || (cgd == 1)) { MINDEC(rc,zos_forward(tag,n,n,1,x,y)); MINDEC(rc,fov_reverse(tag,n,n,n,I,J)); if (LUFactorization(J,n,ri,ci) < 0) return -3; } GauszSolve(J,n,ri,ci,b); modeold = 2; break; } cgd = 0; return rc; }
/* MAIN PROGRAM */ int main() { /*------------------------------------------------------------------------*/ /* variables */ const int tag = 1; // tape tag const int size = 5; // system size const int indep = size*size+size; // # of indeps const int depen = size; // # of deps double A[size][size], a1[size], a2[size], // passive variables b[size], x[size]; adouble **AA, *AAp, *Abx; // active variables double *args = myalloc1(indep); // arguments double **jac = myalloc2(depen,indep); // the Jacobian double *laghessvec = myalloc1(indep); // Hessian-vector product int i,j; /*------------------------------------------------------------------------*/ /* Info */ fprintf(stdout,"LINEAR SYSTEM SOLVING by " "LU-DECOMPOSITION (ADOL-C Example)\n\n"); /*------------------------------------------------------------------------*/ /* Allocation und initialization of the system matrix */ AA = new adouble*[size]; AAp = new adouble[size*size]; for (i=0; i<size; i++) { AA[i] = AAp; AAp += size; } Abx = new adouble[size]; for(i=0; i<size; i++) { a1[i] = i*0.25; a2[i] = i*0.33; } for(i=0; i<size; i++) { for(j=0; j<size; j++) A[i][j] = a1[i]*a2[j]; A[i][i] += i+1; b[i] = -i-1; } /*------------------------------------------------------------------------*/ /* Taping the computation of the determinant */ trace_on(tag); /* marking indeps */ for(i=0; i<size; i++) for(j=0; j<size; j++) AA[i][j] <<= (args[i*size+j] = A[i][j]); for(i=0; i<size; i++) Abx[i] <<= (args[size*size+i] = b[i]); /* LU-factorization and computation of solution */ LUfact(size,AA); LUsolve(size,AA,Abx); /* marking deps */ for (i=0; i<size; i++) Abx[i] >>= x[i]; trace_off(); fprintf(stdout," x[0] (original): %16.4le\n",x[0]); /*------------------------------------------------------------------------*/ /* Recomputation */ function(tag,depen,indep,args,x); fprintf(stdout," x[0] (from tape): %16.4le\n",x[0]); /*------------------------------------------------------------------------*/ /* Computation of Jacobian */ jacobian(tag,depen,indep,args,jac); fprintf(stdout," Jacobian:\n"); for (i=0; i<depen; i++) { for (j=0; j<indep; j++) fprintf(stdout," %14.6le",jac[i][j]); fprintf(stdout,"\n"); } /*------------------------------------------------------------------------*/ /* Computation of Lagrange-Hessian-vector product */ lagra_hess_vec(tag,depen,indep,args,args,x,laghessvec); fprintf(stdout," Part of Lagrange-Hessian-vector product:\n"); for (i=0; i<size; i++) { for (j=0; j<size; j++) fprintf(stdout," %14.6le",laghessvec[i*size+j]); fprintf(stdout,"\n"); } /*------------------------------------------------------------------------*/ /* Tape-documentation */ tape_doc(tag,depen,indep,args,x); /*------------------------------------------------------------------------*/ /* Tape statistics */ int tape_stats[STAT_SIZE]; tapestats(tag,tape_stats); fprintf(stdout,"\n independents %d\n",tape_stats[NUM_INDEPENDENTS]); fprintf(stdout," dependents %d\n",tape_stats[NUM_DEPENDENTS]); fprintf(stdout," operations %d\n",tape_stats[NUM_OPERATIONS]); fprintf(stdout," operations buffer size %d\n",tape_stats[OP_BUFFER_SIZE]); fprintf(stdout," locations buffer size %d\n",tape_stats[LOC_BUFFER_SIZE]); fprintf(stdout," constants buffer size %d\n",tape_stats[VAL_BUFFER_SIZE]); fprintf(stdout," maxlive %d\n",tape_stats[NUM_MAX_LIVES]); fprintf(stdout," valstack size %d\n\n",tape_stats[TAY_STACK_SIZE]); /*------------------------------------------------------------------------*/ /* That's it */ return 1; }
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; }