Actual source code: rk.c

  1: /*$Id: rk.c,v 0.1 2003/06/03 Asbjorn Hoiland Aarrestad$*/
  2: /*
  3:  * Code for Timestepping with Runge Kutta
  4:  *
  5:  * Written by
  6:  * Asbjorn Hoiland Aarrestad
  7:  * asbjorn@aarrestad.com
  8:  * http://asbjorn.aarrestad.com/
  9:  * 
 10:  */
 11:  #include src/ts/tsimpl.h

 13: typedef struct {
 14:    Vec                y1,y2;  /* work wectors for the two rk permuations */
 15:    int                nok,nnok; /* counters for ok and not ok steps */
 16:    PetscReal        maxerror; /* variable to tell the maxerror allowed */
 17:    PetscReal    ferror; /* variable to tell (global maxerror)/(total time) */
 18:    Vec                tmp,tmp_y,*k; /* two temp vectors and the k vectors for rk */
 19:    PetscScalar        a[7][6]; /* rk scalars */
 20:    PetscScalar        b1[7],b2[7]; /* rk scalars */
 21:    PetscReal        c[7]; /* rk scalars */
 22:    int          p,s; /* variables to tell the size of the runge-kutta solver */
 23: } TS_Rk;



 29: static int TSSetUp_Rk(TS ts)
 30: {
 31:   TS_Rk        *rk = (TS_Rk*)ts->data;
 32:   int        ierr;

 35:   rk->nok = 0;
 36:   rk->nnok = 0;
 37:   rk->maxerror = ts->time_step;

 39:   /* fixing maxerror: global vs local */
 40:   rk->ferror = rk->maxerror / (ts->max_time - ts->ptime);

 42:   /* 34.0/45.0 gives double precision division */
 43:   /* defining variables needed for Runge-Kutta computing */
 44:   /* when changing below, please remember to change a, b1, b2 and c above! */
 45:   /* Found in table on page 171: Dormand-Prince 5(4) */

 47:   /* are these right? */
 48:   rk->p=6;
 49:   rk->s=7;

 51:   rk->a[1][0]=1.0/5.0;
 52:   rk->a[2][0]=3.0/40.0;
 53:   rk->a[2][1]=9.0/40.0;
 54:   rk->a[3][0]=44.0/45.0;
 55:   rk->a[3][1]=-56.0/15.0;
 56:   rk->a[3][2]=32.0/9.0;
 57:   rk->a[4][0]=19372.0/6561.0;
 58:   rk->a[4][1]=-25360.0/2187.0;
 59:   rk->a[4][2]=64448.0/6561.0;
 60:   rk->a[4][3]=-212.0/729.0;
 61:   rk->a[5][0]=9017.0/3168.0;
 62:   rk->a[5][1]=-355.0/33.0;
 63:   rk->a[5][2]=46732.0/5247.0;
 64:   rk->a[5][3]=49.0/176.0;
 65:   rk->a[5][4]=-5103.0/18656.0;
 66:   rk->a[6][0]=35.0/384.0;
 67:   rk->a[6][1]=0.0;
 68:   rk->a[6][2]=500.0/1113.0;
 69:   rk->a[6][3]=125.0/192.0;
 70:   rk->a[6][4]=-2187.0/6784.0;
 71:   rk->a[6][5]=11.0/84.0;


 74:   rk->c[0]=0.0;
 75:   rk->c[1]=1.0/5.0;
 76:   rk->c[2]=3.0/10.0;
 77:   rk->c[3]=4.0/5.0;
 78:   rk->c[4]=8.0/9.0;
 79:   rk->c[5]=1.0;
 80:   rk->c[6]=1.0;
 81: 
 82:   rk->b1[0]=35.0/384.0;
 83:   rk->b1[1]=0.0;
 84:   rk->b1[2]=500.0/1113.0;
 85:   rk->b1[3]=125.0/192.0;
 86:   rk->b1[4]=-2187.0/6784.0;
 87:   rk->b1[5]=11.0/84.0;
 88:   rk->b1[6]=0.0;

 90:   rk->b2[0]=5179.0/57600.0;
 91:   rk->b2[1]=0.0;
 92:   rk->b2[2]=7571.0/16695.0;
 93:   rk->b2[3]=393.0/640.0;
 94:   rk->b2[4]=-92097.0/339200.0;
 95:   rk->b2[5]=187.0/2100.0;
 96:   rk->b2[6]=1.0/40.0;
 97: 
 98: 
 99:   /* Found in table on page 170: Fehlberg 4(5) */
100:   /*  
101:   rk->p=5;
102:   rk->s=6;

104:   rk->a[1][0]=1.0/4.0;
105:   rk->a[2][0]=3.0/32.0;
106:   rk->a[2][1]=9.0/32.0;
107:   rk->a[3][0]=1932.0/2197.0;
108:   rk->a[3][1]=-7200.0/2197.0;
109:   rk->a[3][2]=7296.0/2197.0;
110:   rk->a[4][0]=439.0/216.0;
111:   rk->a[4][1]=-8.0;
112:   rk->a[4][2]=3680.0/513.0;
113:   rk->a[4][3]=-845.0/4104.0;
114:   rk->a[5][0]=-8.0/27.0;
115:   rk->a[5][1]=2.0;
116:   rk->a[5][2]=-3544.0/2565.0;
117:   rk->a[5][3]=1859.0/4104.0;
118:   rk->a[5][4]=-11.0/40.0;

120:   rk->c[0]=0.0;
121:   rk->c[1]=1.0/4.0;
122:   rk->c[2]=3.0/8.0;
123:   rk->c[3]=12.0/13.0;
124:   rk->c[4]=1.0;
125:   rk->c[5]=1.0/2.0;

127:   rk->b1[0]=25.0/216.0;
128:   rk->b1[1]=0.0;
129:   rk->b1[2]=1408.0/2565.0;
130:   rk->b1[3]=2197.0/4104.0;
131:   rk->b1[4]=-1.0/5.0;
132:   rk->b1[5]=0.0;
133:   
134:   rk->b2[0]=16.0/135.0;
135:   rk->b2[1]=0.0;
136:   rk->b2[2]=6656.0/12825.0;
137:   rk->b2[3]=28561.0/56430.0;
138:   rk->b2[4]=-9.0/50.0;
139:   rk->b2[5]=2.0/55.0;
140:   */
141:   /* Found in table on page 169: Merson 4("5") */
142:   /*
143:   rk->p=4;
144:   rk->s=5;
145:   rk->a[1][0] = 1.0/3.0;
146:   rk->a[2][0] = 1.0/6.0;
147:   rk->a[2][1] = 1.0/6.0;
148:   rk->a[3][0] = 1.0/8.0;
149:   rk->a[3][1] = 0.0;
150:   rk->a[3][2] = 3.0/8.0;
151:   rk->a[4][0] = 1.0/2.0;
152:   rk->a[4][1] = 0.0;
153:   rk->a[4][2] = -3.0/2.0;
154:   rk->a[4][3] = 2.0;

156:   rk->c[0] = 0.0;
157:   rk->c[1] = 1.0/3.0;
158:   rk->c[2] = 1.0/3.0;
159:   rk->c[3] = 0.5;
160:   rk->c[4] = 1.0;

162:   rk->b1[0] = 1.0/2.0;
163:   rk->b1[1] = 0.0;
164:   rk->b1[2] = -3.0/2.0;
165:   rk->b1[3] = 2.0;
166:   rk->b1[4] = 0.0;

168:   rk->b2[0] = 1.0/6.0;
169:   rk->b2[1] = 0.0;
170:   rk->b2[2] = 0.0;
171:   rk->b2[3] = 2.0/3.0;
172:   rk->b2[4] = 1.0/6.0;
173:   */

175:   /* making b2 -> e=b1-b2 */
176:   /*
177:     for(i=0;i<rk->s;i++){
178:      rk->b2[i] = (rk->b1[i]) - (rk->b2[i]);
179:   }
180:   */
181:   rk->b2[0]=71.0/57600.0;
182:   rk->b2[1]=0.0;
183:   rk->b2[2]=-71.0/16695.0;
184:   rk->b2[3]=71.0/1920.0;
185:   rk->b2[4]=-17253.0/339200.0;
186:   rk->b2[5]=22.0/525.0;
187:   rk->b2[6]=-1.0/40.0;

189:   /* initializing vectors */
190:   VecDuplicate(ts->vec_sol,&rk->y1);
191:   VecDuplicate(ts->vec_sol,&rk->y2);
192:   VecDuplicate(rk->y1,&rk->tmp);
193:   VecDuplicate(rk->y1,&rk->tmp_y);
194:   VecDuplicateVecs(rk->y1,rk->s,&rk->k);

196:   return(0);
197: }

201: static int TSStep_Rk(TS ts,int *steps,PetscReal *ptime)
202: {
203:   TS_Rk                *rk = (TS_Rk*)ts->data;
204:   int                ierr;
205:   PetscReal        dt = 0.001; /* fixed first step guess */
206:   PetscReal        norm=0.0,dt_fac=0.0,fac = 0.0,ttmp=0.0;


210:   ierr=VecCopy(ts->vec_sol,rk->y1);

212:   *steps = -ts->steps;
213:   /* trying to save the vector */
214:   TSMonitor(ts,ts->steps,ts->ptime,ts->vec_sol);
215:   /* while loop to get from start to stop */
216:   while (ts->ptime < ts->max_time){
217:    /* calling rkqs */
218:      /*
219:        -- input
220:        ts        - pointer to ts
221:        ts->ptime - current time
222:        dt        - try this timestep
223:        y1        - solution for this step

225:        --output
226:        y1        - suggested solution
227:        y2        - check solution (runge - kutta second permutation)
228:      */
229:      TSRkqs(ts,ts->ptime,dt);
230:    /* checking for maxerror */
231:      /* comparing difference to maxerror */
232:      /* CHECK THE NEXT LINE!!!!!!!!! */
233:      VecNorm(rk->y2,NORM_2,&norm);
234:      /* modifying maxerror to satisfy this timestep */
235:      rk->maxerror = rk->ferror * dt;
236:      /* PetscPrintf(PETSC_COMM_WORLD,"norm err: %f maxerror: %f dt: %f",norm,rk->maxerror,dt); */

238:    /* handling ok and not ok */
239:      if(norm < rk->maxerror){
240:         /* if ok: */
241:         ierr=VecCopy(rk->y1,ts->vec_sol); /* saves the suggested solution to current solution */
242:         ts->ptime += dt; /* storing the new current time */
243:         rk->nok++;
244:         fac=5.0;
245:         /* trying to save the vector */
246:        /* calling monitor */
247:        TSMonitor(ts,ts->steps,ts->ptime,ts->vec_sol);
248:      }else{
249:         /* if not OK */
250:         rk->nnok++;
251:         fac=1.0;
252:         ierr=VecCopy(ts->vec_sol,rk->y1);  /* restores old solution */
253:      }

255:      /*Computing next stepsize. See page 167 in Solving ODE 1
256:       *
257:       * h_new = h * min( facmax , max( facmin , fac * (tol/err)^(1/(p+1)) ) )
258:       * facmax set above
259:       * facmin
260:       */
261:      dt_fac = exp(log((rk->maxerror) / norm) / ((rk->p) + 1) ) * 0.9 ;

263:      if(dt_fac > fac){
264:         PetscPrintf(PETSC_COMM_WORLD,"changing fac %f\n",fac);
265:         dt_fac = fac;
266:      }

268:      /* computing new dt */
269:      dt = dt * dt_fac;

271:      if(ts->ptime+dt > ts->max_time){
272:         dt = ts->max_time - ts->ptime;
273:      }

275:      if(dt < 1e-12){
276:         PetscPrintf(PETSC_COMM_WORLD,"Very small steps: %f\n",dt);
277:         dt = 1e-12;
278:      }

280:      /* trying to purify h */
281:      /* (did not give any visible result) */
282:      ttmp = ts->ptime + dt;
283:      dt = ttmp - ts->ptime;
284: 
285:      /* counting steps */
286:      ts->steps++;
287:   }
288: 
289:   ierr=VecCopy(rk->y1,ts->vec_sol);
290:   *steps += ts->steps;
291:   *ptime  = ts->ptime;

293:   return(0);
294: }
295: /*------------------------------------------------------------*/
298: int TSRkqs(TS ts,PetscReal t,PetscReal h)
299: {
300:   TS_Rk                *rk = (TS_Rk*)ts->data;
301:   int                ierr,j,l;
302:   PetscReal        tmp_t=t;
303:   PetscScalar        null=0.0,hh=h;

305:   /*  printf("h: %f, hh: %f",h,hh); */
306: 
308: 
309:   /* k[0]=0  */
310:   VecSet(&null,rk->k[0]);
311: 
312:   /* k[0] = derivs(t,y1) */
313:   TSComputeRHSFunction(ts,t,rk->y1,rk->k[0]);
314:   /* looping over runge-kutta variables */
315:   /* building the k - array of vectors */
316:   for(j = 1 ; j < rk->s ; j++){

318:      /* rk->tmp = 0 */
319:      VecSet(&null,rk->tmp);

321:      for(l=0;l<j;l++){
322:         /* tmp += a(j,l)*k[l] */
323:         /* PetscPrintf(PETSC_COMM_WORLD,"a(%i,%i)=%f \n",j,l,rk->a[j][l]); */
324:         VecAXPY(&rk->a[j][l],rk->k[l],rk->tmp);
325:      }

327:      /* VecView(rk->tmp,PETSC_VIEWER_STDOUT_WORLD); */
328: 
329:      /* k[j] = derivs(t+c(j)*h,y1+h*tmp,k(j)) */
330:      /* I need the following helpers:
331:         PetscScalar  tmp_t=t+c(j)*h
332:         Vec          tmp_y=h*tmp+y1
333:      */

335:      tmp_t = t + rk->c[j] * h;

337:      /* tmp_y = h * tmp + y1 */
338:      VecWAXPY(&hh,rk->tmp,rk->y1,rk->tmp_y);

340:      /* rk->k[j]=0 */
341:      VecSet(&null,rk->k[j]);
342:      TSComputeRHSFunction(ts,tmp_t,rk->tmp_y,rk->k[j]);
343:   }

345:   /* tmp=0 and tmp_y=0 */
346:   VecSet(&null,rk->tmp);
347:   VecSet(&null,rk->tmp_y);
348: 
349:   for(j = 0 ; j < rk->s ; j++){
350:      /* tmp=b1[j]*k[j]+tmp  */
351:      VecAXPY(&rk->b1[j],rk->k[j],rk->tmp);
352:      /* tmp_y=b2[j]*k[j]+tmp_y */
353:      VecAXPY(&rk->b2[j],rk->k[j],rk->tmp_y);
354:   }

356:   /* y2 = hh * tmp_y */
357:   VecSet(&null,rk->y2);
358:   VecAXPY(&hh,rk->tmp_y,rk->y2);
359:   /* y1 = hh*tmp + y1 */
360:   VecAXPY(&hh,rk->tmp,rk->y1);
361:   /* Finding difference between y1 and y2 */

363:   return(0);
364: }

366: /*------------------------------------------------------------*/
369: static int TSDestroy_Rk(TS ts)
370: {
371:   TS_Rk *rk = (TS_Rk*)ts->data;
372:   int      i,ierr;

374:   /* REMEMBER TO DESTROY ALL */
375: 
377:   if (rk->y1) {VecDestroy(rk->y1);}
378:   if (rk->y2) {VecDestroy(rk->y2);}
379:   if (rk->tmp) {VecDestroy(rk->tmp);}
380:   if (rk->tmp_y) {VecDestroy(rk->tmp_y);}
381:   for(i=0;i<rk->s;i++){
382:      if (rk->k[i]) {VecDestroy(rk->k[i]);}
383:   }
384:   PetscFree(rk);
385:   return(0);
386: }
387: /*------------------------------------------------------------*/

391: static int TSSetFromOptions_Rk(TS ts)
392: {
394:   return(0);
395: }

399: static int TSView_Rk(TS ts,PetscViewer viewer)
400: {
401:    TS_Rk *rk = (TS_Rk*)ts->data;
404:    PetscPrintf(PETSC_COMM_WORLD,"  number of ok steps: %d\n",rk->nok);
405:    PetscPrintf(PETSC_COMM_WORLD,"  mumber of rejected steps: %d\n",rk->nnok);
406:    return(0);
407: }

409: /* ------------------------------------------------------------ */
410: EXTERN_C_BEGIN
413: int TSCreate_Rk(TS ts)
414: {
415:   TS_Rk    *rk;
416:   int      ierr;

419:   ts->ops->setup           = TSSetUp_Rk;
420:   ts->ops->step            = TSStep_Rk;
421:   ts->ops->destroy         = TSDestroy_Rk;
422:   ts->ops->setfromoptions  = TSSetFromOptions_Rk;
423:   ts->ops->view            = TSView_Rk;

425:   PetscNew(TS_Rk,&rk);
426:   PetscLogObjectMemory(ts,sizeof(TS_Rk));
427:   ts->data = (void*)rk;

429:   return(0);
430: }
431: EXTERN_C_END