End of file
Contents
Index



F 17.4.3 The Predictor-Corrector Method of Adams-Moulton


      SUBROUTINE DESABM (X,Y,FCT,N,XEND,H,HMAX,ABSERR,RELERR,IND,
     1                   IERR,AUXF,LDF)
C
C*****************************************************************
C                                                                *
C  Numerical solution of a system of ordinary differential       *
C  equations                                                     *
C                                                                *
C      Y' = F(X,Y) with initial condition Y(X0) = Y0             *
C                                                                *
C  using the predictor-corrector method by ADAMS-BASHFORTH-      *
C  MOULTON. The starting values required are produced by the     *
C  RUNGE-KUTTA method with the same order as the A-B-M method.   *
C  An automatic step size control is used, that operates on the  *
C  principle of doubling or halving of the step size with sub-   *
C  sequent error estimation.                                     *
C                                                                *
C  INPUT PARAMETERS:                                             *
C  =================                                             *
C                                                                *
C  X     : starting x value.                                     *
C  Y     : DOUBLE PRECISION vector Y(1:N), the initial values    *
C          at location X.                                        *
C  FCT   : SUBROUTINE, that evaluates the right hand side of the *
C          differential equation. It has to be of the following  *
C          form:                                                 *
C                                                                *
C             SUBROUTINE FCT(X,Y,N,F)                            *
C             DOUBLE PRECISION Y(N), F(N)                        *
C                  .                                             *
C                  .                                             *
C                  .                                             *
C                                                                *
C          In the calling program it must be declared as         *
C          EXTERNAL. Its variables have the following meaning:   *
C             X   independent variable.                          *
C             Y   dependent variable.                            *
C             F   function value of the right hand side of the   *
C                 system of differential equations Y'=F(X,Y).    *
C  N     : number of differential equations in the system.       *
C  XEND  : location where the solution is desired; may be        *
C          smaller than X.                                       *
C  H     : step size for the next step, normally it is           *
C          determined by the program.                            *
C  HMAX  : maximum step size allowed, it has to be positive.     *
C  ABSERR:)                                                      *
C  RELERR:) error parameters, which have to be >= 0. A mixed test*
C           is used:                                             *
C              ABS (LOCAL ERROR) .LE. ABS(Y)*RELERR + ABSERR.    *
C           Thus, if RELERR = 0 is chosen, this corresponds to a *
C           test for the absolute error. If ABSERR = 0 is chosen *
C           this corresponds to a test for the relative error.   *
C           RELERR and ABSERR should be chosen to exceed ten     *
C           times the machine constant. If this is not the case, *
C           they are automatically set equal to this value.      *
C  IND   : indicator, which must be set equal to one on the      *
C          first call.                                           *
C  IERR  : error parameter, on first call it has to be set equal *
C          to  0.                                                *
C  AUXF  : DOUBLE PRECISION auxiliary array AUXF(1:LDF,12),      *
C          LDF .GE. N, where LDF is as defined in the calling    * 
C          program.                                              *
C  LDF   : leading dimension of AUXF.                            *
C                                                                *
C  OUTPUT PARAMETERS:                                            *
C  ==================                                            *
C                                                                *
C  X     : x value reached during last integration;              *
C          normally X < XEND.                                    *
C  Y     : value for the solution at location X.                 *
C  H     : step size used last, should remain unchanged for the  *
C          next step. If it is changed, IERR has to be reset to  *
C          zero.                                                 *
C  IND   : after the first call set equal to 2, should not be    *
C          changed.                                              *
C  IERR  : error parameter.                                      *
C          = 0: everything o.k., after resetting of XEND         *
C               DESABM can be called again.                      *
C          = 1: everything o.k., after resetting of XEND         *
C               DESABM can be called again.                      *
C               the starting values for the A-B-M-method are     *
C               known, the R-K set up procedure is omitted.      *
C          = 2: after ICTMAX function evaluations the procedure  *
C               did not reach XEND, a repeated call without any  *
C               change of the parameters may be successful.      *
C               (otherwise try to increase the error parameters).*
C               ICTMAX is defined locally as DATA with a preset  *
C               value of 500. Local changes can be made inside   *
C               the program.                                     *
C          = 3: the step size is less than eight times the       *
C               machine constant at an x value. Before further   *
C               calls, H and the error parameters need to be     *
C               increased.                                       *
C          = 4: ABSERR or RELERR is negative or both             *
C               ABSERR = 0.0 and RELERR = 0.0                    *
C          = 5: XEND equals X.                                   *
C          = 6: HMAX is negative.                                *
C                                                                *
C  NOTE:                                                         *
C  =====                                                         *
C                                                                *
C  The point XEND normally is not reached by the program, but due*
C  to the step size control a point X with XEND - H < X < XEND.  *
C  If the solution is required at XEND, DESABM has to be called  *
C  again with H = XEND - X and IERR = 0.                         *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  subroutines required: MACHPD                                  *
C                                                                *
C*****************************************************************
C                                                                *
C  author   : Jobst Hoffmann                                     *
C  date     : 07.25.1988 (revised 11.11.1994)                    *
C  source   : FORTRAN 77                                         *
C                                                                *
C*****************************************************************
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION X,XEND,H,HMAX,ABSERR,RELERR
      DIMENSION Y(N),AUXF(LDF,12)
      DIMENSION ALPHA(4),P(4),BETA(4),BETDER(4),FERR(2)
C
      SAVE ALPHA,BETA,BETDER,P,FERR,FMACHP
C
      DATA ICTMAX/500/
C.
C     Initialize the constants. This is performed
C     during the first call of the program only, 
C     afterwards it is omitted.
C.
      IF ( IND .NE. 1 ) GOTO 10
C.
C     machine constant
C.
      FMACHP = 1.0D0
    5 FMACHP = 0.50D0 * FMACHP
      IF (MACHPD(1.0D0+FMACHP) .EQ. 1) GOTO 5
      FMACHP = FMACHP * 2.0D0
C.
C     RUNGE-KUTTA coefficients
C.
      ALPHA(1) = 1.0D0/6.0D0
      ALPHA(2) = 1.0D0/3.0D0
      ALPHA(3) = 1.0D0/3.0D0
      ALPHA(4) = 1.0D0/6.0D0
C
      P(1) = 0.0D0
      P(2) = 0.50D0
      P(3) = 0.50D0
      P(4) = 1.0D0
C.
C     ADAMS-BASHFORTH coefficients
C.
      BETA(1) = -9.0D0
      BETA(2) = 37.0D0
      BETA(3) = -59.0D0
      BETA(4) = 55.0D0
C.
C     ADAMS-MOULTON coefficients
C.
      BETDER(1) = 1.0D0
      BETDER(2) = -5.0D0 
      BETDER(3) = 19.0D0 
      BETDER(4) = 9.0D0
C.
C     factors for the error estimate (extrapolation) 
C.
      FERR(1) = 1.0D0/80.0D0
      FERR(2) = -19.0D0/270.0D0 
C 
      IND = 2 
C.
C     Input error check, Initialize variables 
C.
   10 IF ( ABSERR .LT. 0.0 .OR. RELERR .LT. 0.0 .OR.
     1     ABSERR + RELERR .LE. 0.0 ) THEN
         IERR = 4
         RETURN 
      ELSEIF ( XEND .EQ. X ) THEN
         IERR = 5
         RETURN 
      ELSEIF ( HMAX .LE. 0.0D0 ) THEN
         IERR = 6
         RETURN 
      ENDIF 
      IF ( ABSERR .LT. 10.0D0*FMACHP ) ABSERR = 10.0D0*FMACHP 
      IF ( RELERR .LT. 10.0D0*FMACHP ) RELERR = 10.0D0*FMACHP 
      ICOUNT = 0
      IF ( IERR .EQ. 2 ) GOTO 170
      IF ( IERR .EQ. 1 ) GOTO 210
      IERR = 0 
      CALL FCT (X,Y(1),N,AUXF(1,2))
      ICOUNT = ICOUNT + 1 
C.
C     store the starting step size
C.
      HLOC = H
C.
C     determine the current step size
C.
   20 IMETH = 1 
      IF ( HMAX .LT. H ) H = HMAX
      ABSH = DABS(H) 
      H = DSIGN(DMIN1(ABSH,DABS(XEND-X)/3.0D0),XEND - X) 
      ABSH = DABS(H) 
      IF ( ABSH .LE. 8.0D0*FMACHP*DABS(X) ) THEN
         H = HLOC 
         IERR = 0
         RETURN 
      ENDIF 
C.
C     RUNGE-KUTTA steps with error estimates, in order 
C     to determine the starting values for the multi-step 
C     method.
C     If  ISTART = 1:  step size  H. 
C     If  ISTART = 0:  step size 3H. 
C.
   30 ISTART = 1
   40 CONTINUE
C.
C     store the starting values
C.
      X0 = X
      XDUMMY = X 
      DO 50 I=1,N 
         AUXF(I,6) = Y(I)
         AUXF(I,7) = Y(I)
   50 CONTINUE
C.
C     Perform the three steps 
C.
      DO 120 JBEG=1,3 
         DO 60 I=1,N
            AUXF(I,9) = 0.0D0 
   60    CONTINUE 
         IRK = 1
   70    CALL FCT (X0,AUXF(1,7),N,AUXF(1,8))
         DO 80 I=1,N
            AUXF(I,9) = AUXF(I,9) + ALPHA(IRK)*AUXF(I,8) 
   80    CONTINUE 
         IF ( IRK .EQ. 4) GOTO 100
         IRK = IRK + 1
         X0 = XDUMMY + P(IRK)*H
         DO 90 I=1,N
            AUXF(I,7) = AUXF(I,6) + P(IRK)*H*AUXF(I,8) 
   90    CONTINUE 
         GOTO 70
  100    IF ( ISTART .EQ. 0 ) GOTO 130
         XDUMMY = XDUMMY + H
         X0 = XDUMMY 
         DO 110 I=1,N 
            AUXF(I,6) = AUXF(I,6) + H*AUXF(I,9)
            AUXF(I,7) = AUXF(I,6) 
            IF ( JBEG .EQ. 3 ) AUXF(I,11) = AUXF(I,6) 
  110    CONTINUE 
         CALL FCT (X0,AUXF(1,6),N,AUXF(1,JBEG+2)) 
  120 CONTINUE
C.
C     After three steps with step size H, perform one step  
C     with step size 3H 
C.
      ISTART = 1 - ISTART 
      HDUMMY = H 
      H = H + H + H 
      GOTO 40 
  130 ICOUNT = ICOUNT + 13
      DO 140 I=1,N
         AUXF(I,10) = AUXF(I,6) + H*AUXF(I,9)
  140 CONTINUE
      X0 = X + H
C.
C     continue calculations with the original step size
C.
      H = HDUMMY 
  150 IF ( ICOUNT .GE. ICTMAX ) THEN
C.
C        return with message about excessive function calls
C.
         X = X0 
         DO 160 I=1,N 
            Y(I) = AUXF(I,11)
  160    CONTINUE 
         IERR = 2
         RETURN 
      ENDIF 
C.
C     error estimate 
C.
  170 DMAX = 0.0D0 
      YMAX = 0.0D0 
      DO 180 I=1,N
         AUXF(I,12) = FERR(IMETH)*(AUXF(I,11) - AUXF(I,10))
         DMAX = DMAX1(DMAX,DABS(AUXF(I,12)))
         YMAX = DMAX1(YMAX,DABS(AUXF(I,11)))
  180 CONTINUE
      IF ( DMAX .GE. RELERR*YMAX + ABSERR ) THEN
C.
C        unsuccessful run, the step is repeated with half the step size
C.
         H = 0.5D0*H
         IF ( DABS(H) .GT. 8.0D0*FMACHP*DABS(X0) ) GOTO 30 
         IERR = 3
         RETURN 
      ENDIF 
C.
C     the step was successful, calculation is continued with the
C     old step size
C.
      X = X0
      DO 190 I=1,N
         AUXF(I,11) = AUXF(I,11) + AUXF(I,12)
         Y(I) = AUXF(I,11) 
  190 CONTINUE
      CALL FCT (X0,Y(1),N,AUXF(1,5)) 
      ICOUNT = ICOUNT + 1 
      IF ( DMAX .LE. 0.02D0*( RELERR*YMAX + ABSERR ) ) THEN 
C.
C        The precision obtained is too high, the step size is 
C        doubled, continue with the RUNGE-KUTTA starting procedure
C.
         H = 2.0D0*H 
         HLOC = DMAX1(H,HLOC) 
         DO 200 I=1,N 
            AUXF(I,2) = AUXF(I,5) 
  200    CONTINUE 
         IF ( H .GT. 0. .AND. X0 .LT. XEND .OR. 
     1        H .LT. 0. .AND. X0 .GT. XEND ) GOTO 20
         IERR = 0
         RETURN 
      ENDIF 
      IF ( H .GT. 0. .AND. X0 + H .GE. XEND .OR.
     1     H .LT. 0. .AND. X0 + H .LE. XEND ) THEN
C.
C        We are at the end of the interval. For further calls IERR is set to 
C        1, so that on repeated calls the calculations can be continued
C        with ADAMS-BASHFORTH-MOULTON steps
C.
         IF ( ABSH .LE. 8.0D0*FMACHP*DABS(X0) ) THEN
            H = HLOC
            IERR = 0 
            RETURN
         ENDIF
         IERR = 1
         RETURN 
      ENDIF 
C.
C     start of the ADAMS-BASHFORTH-MOULTON steps
C.
  210 IMETH = 2 
      DO 230 J=1,4
         DO 220 I=1,N 
            AUXF(I,J) = AUXF(I,J+1) 
  220    CONTINUE 
  230 CONTINUE
C.
C     predictor-step 
C.
      DO 240 I=1,N
         AUXF(I,8) = 0.0D0
  240 CONTINUE
      DO 260 J=1,4
         DO 250 I=1,N
            AUXF(I,8) = AUXF(I,8) + BETA(J)*AUXF(I,J)
  250    CONTINUE 
  260 CONTINUE
      DO 270 I=1,N
         AUXF(I,10) = AUXF(I,11) + H*AUXF(I,8)/24.0D0 
  270 CONTINUE
C.
C     new node
C.
      X0 = X0 + H 
      CALL FCT (X0,AUXF(1,10),N,AUXF(1,5))
C. 
C     corrector step
C.
      DO 280 I=1,N
         AUXF(I,8) = 0.0D0
  280 CONTINUE
      DO 300 J=1,4
         DO 290 I=1,N 
            AUXF(I,8) = AUXF(I,8) + BETDER(J)*AUXF(I,J+1)
  290    CONTINUE 
  300 CONTINUE
      DO 310 I=1,N
         AUXF(I,11) = AUXF(I,11) + H*AUXF(I,8)/24.0D0 
  310 CONTINUE
C.
C     function value of the corrector 
C.
      CALL FCT (X0,AUXF(1,11),N,AUXF(1,5))
      ICOUNT = ICOUNT + 2 
      GOTO 150
      END 


Begin of file
Contents
Index