00001 /* 00002 ------------------------------------------------------------------- 00003 00004 Copyright (C) 2006, 2007, 2008, 2009, Andrew W. Steiner 00005 00006 This file is part of O2scl. 00007 00008 O2scl is free software; you can redistribute it and/or modify 00009 it under the terms of the GNU General Public License as published by 00010 the Free Software Foundation; either version 3 of the License, or 00011 (at your option) any later version. 00012 00013 O2scl is distributed in the hope that it will be useful, 00014 but WITHOUT ANY WARRANTY; without even the implied warranty of 00015 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00016 GNU General Public License for more details. 00017 00018 You should have received a copy of the GNU General Public License 00019 along with O2scl. If not, see <http://www.gnu.org/licenses/>. 00020 00021 ------------------------------------------------------------------- 00022 */ 00023 /* ode-initval/bsimp.c 00024 * 00025 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2004 Gerard Jungman 00026 * 00027 * This program is free software; you can redistribute it and/or modify 00028 * it under the terms of the GNU General Public License as published by 00029 * the Free Software Foundation; either version 3 of the License, or (at 00030 * your option) any later version. 00031 * 00032 * This program is distributed in the hope that it will be useful, but 00033 * WITHOUT ANY WARRANTY; without even the implied warranty of 00034 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 00035 * General Public License for more details. 00036 * 00037 * You should have received a copy of the GNU General Public License 00038 * along with this program; if not, write to the Free Software 00039 * Foundation, Inc., 51 Franklin Street, Fifth Floor, 00040 * Boston, MA 02110-1301, USA. 00041 */ 00042 00043 #ifndef O2SCL_GSL_BSIMP_H 00044 #define O2SCL_GSL_BSIMP_H 00045 00046 #include <gsl/gsl_math.h> 00047 00048 #include <o2scl/err_hnd.h> 00049 #include <o2scl/odestep.h> 00050 #include <o2scl/ode_jac_funct.h> 00051 #include <o2scl/vec_arith.h> 00052 #include <o2scl/lu.h> 00053 #include <o2scl/permutation.h> 00054 00055 #ifndef DOXYGENP 00056 namespace o2scl { 00057 #endif 00058 00059 /** 00060 \brief Bulirsch-Stoer implicit ODE stepper (GSL) 00061 00062 Bader-Deuflhard implicit extrapolative stepper (\ref Bader83). 00063 00064 \note The variable <tt>h_next</tt> was defined in the original 00065 GSL version has been removed here, as it was unused by the 00066 stepper routine. 00067 00068 \todoc More detailed documentation 00069 \todo Ensure error handling is sensible if the "derivs" or jacobian 00070 functions return a non-zero value 00071 \todo Create an example with a stiff diff eq. which requires 00072 this kind of stepper 00073 00074 \future I don't like setting yerr to GSL_POSINF, there should 00075 be a better way to force an adaptive stepper which is calling 00076 this stepper to readjust the stepsize. 00077 \future Some of these functions can be moved out of this header 00078 file 00079 \future Rework internal arrays as uvectors? 00080 \future The function step_local() is actually its own ODE stepper 00081 and could be reimplemented as an object of type odestep 00082 */ 00083 template<class param_t, class func_t, class jac_func_t, 00084 class vec_t=ovector_base, class alloc_vec_t=ovector, 00085 class alloc_t=ovector_alloc, class mat_t=omatrix_base, 00086 class alloc_mat_t=omatrix, class mat_alloc_t=omatrix_alloc> 00087 class gsl_bsimp { 00088 00089 #ifndef DOXYGEN_INTERAL 00090 00091 protected: 00092 00093 /// Size of allocated vectors 00094 size_t dim; 00095 00096 /// Memory allocator for objects of type \c alloc_vec_t 00097 alloc_t ao; 00098 00099 /// Memory allocator for objects of type \c alloc_mat_t 00100 mat_alloc_t mo; 00101 00102 /// Function specifying derivatives 00103 func_t *funcp; 00104 00105 /// Jacobian 00106 jac_func_t *jfuncp; 00107 00108 /// User-specified paramter 00109 param_t *pap; 00110 00111 /// Desc 00112 static const int sequence_count=8; 00113 00114 /// Desc 00115 static const int sequence_max=7; 00116 00117 /// Workspace for extrapolation 00118 gsl_matrix *d; 00119 /// Workspace for linear system matrix 00120 gsl_matrix *a_mat; 00121 00122 /** \brief Workspace for extrapolation 00123 00124 (This state variable was named 'x' in GSL.) 00125 */ 00126 double ex_wk[sequence_max]; 00127 00128 /// \name State info 00129 //@{ 00130 size_t k_current; 00131 size_t k_choice; 00132 //double h_next; 00133 double eps; 00134 //@} 00135 00136 /// \name Workspace for extrapolation step 00137 //@{ 00138 double *yp; 00139 double *y_save; 00140 double *yerr_save; 00141 double *y_extrap_save; 00142 alloc_vec_t y_extrap_sequence; 00143 double *extrap_work; 00144 alloc_vec_t dfdt; 00145 alloc_vec_t y_temp; 00146 alloc_vec_t delta_temp; 00147 double *weight; 00148 alloc_mat_t dfdy; 00149 //@} 00150 00151 /// \name Workspace for the basic stepper 00152 //@{ 00153 alloc_vec_t rhs_temp; 00154 double *delta; 00155 //@} 00156 00157 /// Order of last step 00158 size_t order; 00159 00160 /// Compute weights 00161 int compute_weights(const double y[], double w[], size_t n) { 00162 size_t i; 00163 // w[i] is 1 if y[i] is zero and the absolute value of y[i] 00164 // otherwise 00165 for (i = 0; i < n; i++) { 00166 double u = fabs(y[i]); 00167 w[i] = (u > 0.0) ? u : 1.0; 00168 } 00169 return 0; 00170 } 00171 00172 /** 00173 \brief Calculate a choice for the "order" of the method, using the 00174 Deuflhard criteria. 00175 00176 Used in the allocate() function. 00177 */ 00178 size_t deuf_kchoice(double eps2, size_t dimension) { 00179 00180 const double safety_f = 0.25; 00181 const double small_eps = safety_f * eps2; 00182 00183 double a_work[sequence_count]; 00184 double alpha[sequence_max][sequence_max]; 00185 00186 /* Bader-Deuflhard extrapolation sequence */ 00187 static const int bd_sequence[sequence_count] = 00188 { 2, 6, 10, 14, 22, 34, 50, 70 }; 00189 00190 int i, k; 00191 00192 a_work[0] = bd_sequence[0] + 1.0; 00193 00194 for (k = 0; k < sequence_max; k++) { 00195 a_work[k + 1] = a_work[k] + bd_sequence[k + 1]; 00196 } 00197 00198 for (i = 0; i < sequence_max; i++) { 00199 alpha[i][i] = 1.0; 00200 for (k = 0; k < i; k++) { 00201 const double tmp1 = a_work[k + 1] - a_work[i + 1]; 00202 const double tmp2 = (a_work[i + 1] - a_work[0] + 1.0) * 00203 (2 * k + 1); 00204 alpha[k][i] = pow (small_eps, tmp1 / tmp2); 00205 } 00206 } 00207 00208 a_work[0] += dimension; 00209 00210 for (k = 0; k < sequence_max; k++) { 00211 a_work[k + 1] = a_work[k] + bd_sequence[k + 1]; 00212 } 00213 00214 for (k = 0; k < sequence_max - 1; k++) { 00215 if (a_work[k + 2] > a_work[k + 1] * alpha[k][k + 1]) { 00216 break; 00217 } 00218 } 00219 00220 return k; 00221 } 00222 00223 /** 00224 \brief Polynomial extrapolation 00225 00226 Compute the step of index <tt>i_step</tt> using polynomial 00227 extrapolation to evaulate functions by fitting a polynomial 00228 to estimates <tt>(x_i,y_i)</tt> and output the result to 00229 <tt>y_0</tt> and <tt>y_0_err</tt>. 00230 00231 The index <tt>i_step</tt> begins with zero. 00232 00233 */ 00234 int poly_extrap(gsl_matrix *dloc, const double x[], 00235 const unsigned int i_step, const double x_i, 00236 const vec_t &y_i, vec_t &y_0, vec_t &y_0_err, 00237 double work[]) { 00238 size_t j, k; 00239 00240 o2scl::vector_copy(dim,y_i,y_0_err); 00241 o2scl::vector_copy(dim,y_i,y_0); 00242 00243 if (i_step == 0) { 00244 00245 for (j = 0; j < dim; j++) { 00246 gsl_matrix_set (dloc, 0, j, y_i[j]); 00247 } 00248 00249 } else { 00250 00251 o2scl::vector_copy(dim,y_i,work); 00252 00253 for (k = 0; k < i_step; k++) { 00254 double deltaloc = 1.0 / (x[i_step - k - 1] - x_i); 00255 const double f1 = deltaloc * x_i; 00256 const double f2 = deltaloc * x[i_step - k - 1]; 00257 00258 for (j = 0; j < dim; j++) { 00259 const double q_kj = gsl_matrix_get (dloc, k, j); 00260 gsl_matrix_set (dloc, k, j, y_0_err[j]); 00261 deltaloc = work[j] - q_kj; 00262 y_0_err[j] = f1 * deltaloc; 00263 work[j] = f2 * deltaloc; 00264 y_0[j] += y_0_err[j]; 00265 } 00266 } 00267 00268 for (j = 0; j < dim; j++) { 00269 gsl_matrix_set(dloc, i_step, j, y_0_err[j]); 00270 } 00271 } 00272 return 0; 00273 } 00274 00275 /** 00276 \brief Basic implicit Bulirsch-Stoer step 00277 00278 Divide the step <tt>h_total</tt> into <tt>n_step</tt> smaller 00279 steps and do the Bader-Deuflhard semi-implicit iteration. This 00280 function starts at <tt>t0</tt> with function values 00281 <tt>y</tt>, derivatives <tt>yp_loc</tt>, and information from 00282 the Jacobian to compute the final value <tt>y_out</tt>. 00283 */ 00284 int step_local(const double t0, const double h_total, 00285 const unsigned int n_step, const double y[], 00286 const double yp_loc[], const vec_t &dfdt_loc, 00287 const mat_t &dfdy_loc, vec_t &y_out) { 00288 00289 double *const w=weight; 00290 00291 const double h = h_total / n_step; 00292 double t = t0 + h; 00293 00294 double sum; 00295 00296 /* This is the factor sigma referred to in equation 3.4 of the 00297 paper. A relative change in y exceeding sigma indicates a 00298 runaway behavior. According to the authors suitable values 00299 for sigma are >>1. I have chosen a value of 100*dim. BJG 00300 */ 00301 const double max_sum = 100.0 * dim; 00302 00303 int signum, status; 00304 size_t i, j; 00305 size_t n_inter; 00306 00307 /* Calculate the matrix for the linear system. */ 00308 for (i = 0; i < dim; i++) { 00309 for (j = 0; j < dim; j++) { 00310 gsl_matrix_set(a_mat,i,j,-h*dfdy_loc[i][j]); 00311 } 00312 gsl_matrix_set(a_mat,i,i,gsl_matrix_get(a_mat,i,i)+1.0); 00313 } 00314 00315 /* LU decomposition for the linear system. */ 00316 00317 o2scl::permutation p_vec; 00318 omatrix *om=(omatrix *)a_mat; 00319 o2scl_linalg::LU_decomp(dim,*om,p_vec,signum); 00320 00321 /* Compute weighting factors */ 00322 compute_weights(y,w,dim); 00323 00324 /* Initial step. */ 00325 00326 for (i = 0; i < dim; i++) { 00327 y_temp[i]=h*(yp_loc[i]+h*dfdt_loc[i]); 00328 } 00329 00330 o2scl_linalg::LU_solve(dim,*om,p_vec,y_temp,delta_temp); 00331 00332 sum = 0.0; 00333 for (i = 0; i < dim; i++) { 00334 const double di = delta_temp[i]; 00335 delta[i] = di; 00336 y_temp[i] = y[i] + di; 00337 sum += fabs(di) / w[i]; 00338 } 00339 if (sum > max_sum) { 00340 return gsl_efailed; 00341 } 00342 00343 /* Intermediate steps. */ 00344 00345 status=(*funcp)(t,dim,y_temp,y_out,*pap); 00346 if (status) { 00347 return status; 00348 } 00349 00350 for (n_inter = 1; n_inter < n_step; n_inter++) { 00351 00352 for (i = 0; i < dim; i++) { 00353 rhs_temp[i] = h*y_out[i]-delta[i]; 00354 } 00355 00356 o2scl_linalg::LU_solve(dim,*om,p_vec,rhs_temp,delta_temp); 00357 00358 sum = 0.0; 00359 for (i = 0; i < dim; i++) { 00360 delta[i] += 2.0 * delta_temp[i]; 00361 y_temp[i] += delta[i]; 00362 sum += fabs(delta[i]) / w[i]; 00363 } 00364 if (sum > max_sum) { 00365 return gsl_efailed ; 00366 } 00367 00368 t += h; 00369 00370 status=(*funcp)(t,dim,y_temp,y_out,*pap); 00371 if (status) { 00372 return status; 00373 } 00374 } 00375 00376 00377 /* Final step. */ 00378 00379 for (i = 0; i < dim; i++) { 00380 rhs_temp[i]=h*y_out[i]-delta[i]; 00381 } 00382 00383 o2scl_linalg::LU_solve(dim,*om,p_vec,rhs_temp,delta_temp); 00384 00385 sum = 0.0; 00386 for (i = 0; i < dim; i++) { 00387 y_out[i] = y_temp[i]+delta_temp[i]; 00388 sum += fabs(delta_temp[i])/w[i]; 00389 } 00390 00391 if (sum > max_sum) { 00392 return gsl_efailed; 00393 } 00394 00395 return gsl_success; 00396 } 00397 00398 /// Allocate memory for a system of size \c n 00399 int allocate(size_t n) { 00400 00401 if (dim>0) free(); 00402 00403 dim=n; 00404 00405 d=gsl_matrix_alloc(sequence_max,n); 00406 a_mat=gsl_matrix_alloc(n,n); 00407 00408 yp=(double *)malloc(n*sizeof(double)); 00409 00410 // AWS, 12/2/08 - This was added to ensure memory reallocation 00411 // resets the stepper just like reset() does 00412 for(size_t i=0;i<n;i++) yp[i]=0.0; 00413 00414 y_save=(double *)malloc(n*sizeof(double)); 00415 yerr_save=(double *)malloc(n*sizeof(double)); 00416 y_extrap_save=(double *)malloc(n*sizeof(double)); 00417 extrap_work=(double *)malloc(n*sizeof(double)); 00418 weight=(double *)malloc(n*sizeof(double)); 00419 00420 mo.allocate(dfdy,n,n); 00421 ao.allocate(dfdt,n); 00422 ao.allocate(y_extrap_sequence,n); 00423 ao.allocate(y_temp,n); 00424 ao.allocate(rhs_temp,n); 00425 ao.allocate(delta_temp,n); 00426 00427 delta=(double *)malloc(n*sizeof(double)); 00428 00429 // This choice of epsilon is not necessarily optimal, it has 00430 // a "FIXME" comment in the original GSL code 00431 size_t k_choice_loc=deuf_kchoice(GSL_SQRT_DBL_EPSILON,n); 00432 k_choice=k_choice_loc; 00433 k_current=k_choice_loc; 00434 order=2*k_choice_loc; 00435 00436 //h_next=-GSL_SQRT_DBL_MAX; 00437 00438 return 0; 00439 } 00440 00441 /// Free allocated memory 00442 void free() { 00443 if (dim>0) { 00444 std::free(delta); 00445 00446 mo.free(dfdy,dim); 00447 ao.free(rhs_temp); 00448 ao.free(dfdt); 00449 ao.free(y_temp); 00450 ao.free(y_extrap_sequence); 00451 ao.free(delta_temp); 00452 00453 std::free(weight); 00454 std::free(extrap_work); 00455 std::free(y_extrap_save); 00456 std::free(y_save); 00457 std::free(yerr_save); 00458 std::free(yp); 00459 00460 gsl_matrix_free(a_mat); 00461 gsl_matrix_free(d); 00462 dim=0; 00463 } 00464 } 00465 00466 #endif 00467 00468 public: 00469 00470 gsl_bsimp() { 00471 dim=0; 00472 } 00473 00474 virtual ~gsl_bsimp() { 00475 if (dim>0) free(); 00476 } 00477 00478 /// Reset stepper 00479 int reset() { 00480 for(size_t i=0;i<dim;i++) yp[i]=0.0; 00481 return gsl_success; 00482 } 00483 00484 /** 00485 \brief Perform an integration step 00486 00487 Given initial value of the n-dimensional function in \c y and 00488 the derivative in \c dydx (which must generally be computed 00489 beforehand) at the point \c x, take a step of size \c h giving 00490 the result in \c yout, the uncertainty in \c yerr, and the new 00491 derivative in \c dydx_out (at \c x+h) using function \c derivs 00492 to calculate derivatives. Implementations which do not 00493 calculate \c yerr and/or \c dydx_out do not reference these 00494 variables so that a blank \c vec_t can be given. All of the 00495 implementations allow \c yout=y and \c dydx_out=dydx if 00496 necessary. 00497 */ 00498 virtual int step(double x, double h, size_t n, vec_t &y, vec_t &dydx, 00499 vec_t &yout, vec_t &yerr, vec_t &dydx_out, param_t &pa, 00500 func_t &derivs, jac_func_t &jac) { 00501 00502 int ret; 00503 00504 funcp=&derivs; 00505 jfuncp=&jac; 00506 pap=&pa; 00507 00508 if (n!=dim) allocate(n); 00509 00510 /* Bader-Deuflhard extrapolation sequence */ 00511 static const int bd_sequence[sequence_count] = 00512 { 2, 6, 10, 14, 22, 34, 50, 70 }; 00513 00514 double t_local=x; 00515 00516 size_t i, k; 00517 00518 if (h + t_local == t_local) { 00519 // This section is labeled with a "FIXME" comment in the 00520 // original GSL code. I'm not sure why, but an error is 00521 // sensible here. 00522 O2SCL_ERR_RET("Stepsize underflow in gsl_bsimp::step().", 00523 gsl_eundrflw); 00524 } 00525 00526 /* Save inputs */ 00527 o2scl::vector_copy(dim,y,y_extrap_save); 00528 o2scl::vector_copy(dim,y,y_save); 00529 o2scl::vector_copy(dim,yerr,yerr_save); 00530 00531 // Copy derivative 00532 o2scl::vector_copy(dim,dydx,yp); 00533 00534 // Evaluate the Jacobian for the system. */ 00535 ret=jac(t_local,dim,y,dfdy,dfdt,pa); 00536 if (ret != gsl_success) { 00537 return ret; 00538 } 00539 00540 /* Make a series of refined extrapolations, up to the specified 00541 maximum order, which was calculated based on the Deuflhard 00542 criterion in the deuf_kchoice() function (which is called by 00543 allocate() ). 00544 */ 00545 for (k = 0; k <= k_current; k++) { 00546 00547 const unsigned int N = bd_sequence[k]; 00548 const double r = (h / N); 00549 const double x_k = r * r; 00550 00551 // Each step computes a value of y_extrap_sequence, 00552 // using the number of sub-steps dictated by 00553 // the BD sequence 00554 int status=step_local(t_local,h,N,y_extrap_save,yp, 00555 dfdt,dfdy,y_extrap_sequence); 00556 00557 if (status == gsl_efailed) { 00558 /* If the local step fails, set the error to infinity in 00559 order to force a reduction in the step size 00560 */ 00561 for (i = 0; i < dim; i++) { 00562 yerr[i] = GSL_POSINF; 00563 } 00564 break; 00565 } else if (status != gsl_success) { 00566 return status; 00567 } 00568 00569 // Use the information in y_extrap_sequence to compute 00570 // the new value of y and yerr . 00571 ex_wk[k] = x_k; 00572 poly_extrap(d,ex_wk,k,x_k,y_extrap_sequence,y,yerr,extrap_work); 00573 } 00574 00575 /* Evaluate dydt_out[]. */ 00576 00577 ret=derivs(t_local+h,dim,y,dydx_out,pa); 00578 00579 // If we failed, copy the old values back to y and yerr 00580 if (ret != gsl_success) { 00581 o2scl::vector_copy(dim,y_save,y); 00582 o2scl::vector_copy(dim,yerr_save,yerr); 00583 return ret; 00584 } 00585 00586 return gsl_success; 00587 } 00588 00589 }; 00590 00591 #ifndef DOXYGENP 00592 } 00593 #endif 00594 00595 #endif
Documentation generated with Doxygen and provided under the GNU Free Documentation License. See License Information for details.
Project hosting provided by
,
O2scl Sourceforge Project Page