End of file
Contents
Index



F 17.7.3 Gear's method for integrating stiff systems of DEs


      SUBROUTINE GEAR4 (XK, HK, YK, N, DES, XE, EPSABS,
     1                 EPSREL, NMAX, NUSED, IERR)
C
C*****************************************************************
C                                                                *
C  Starting from an approximation YK for the solution Y of a     *
C  system of ordinary differential equations of first order      *
C                    Y' = F(X,Y)                                 *
C  at XK, this program computes an approximate solution YE at XE.*
C  Here we compute internally with a step size control, that     *
C  ensures the error of the computed solution to be less than the*
C  given absolute or relative error bounds EPSABS and EPSREL.    *
C  These bounds must be specified small enough for good results. *
C  The method used is the multistep method of Gear of fourth     *
C  order which is highly capable of solving stiff DEs. (Stiff DEs*
C  are those DE systems which have solution components of very   *
C  disparate growths.)                                           *
C                                                                *
C                                                                *
C  INPUT PARAMETERS:                                             *
C  =================                                             *
C  XK    - starting value for X                                  *
C  HK    - proposed step size for first step                     *
C  YK    - vector YK(1:N); Y value of the solution to the DE     *
C          at XK                                                 *
C  N     - number of DEs  ( 1 <= N <= 20 )                       *
C  DES   - right hand side of the DE, given as a subroutine:     *
C             SUBROUTINE DES (X, Y, N, F)                        *
C          ( starting with: DOUBLE PRECISION Y(N), F(N), X ).    *
C          Here F is the value of the right hand side at (X,Y).  *
C          ( DES must be declared as EXTERNAL in the calling     *
C            program.)                                           *
C  XE    - X value for desired solution; XE > XK.                *
C EPSABS - error bound for absolute error; EPSABS >= 0; if       *
C          EPSABS = 0 the algorithm maintains only the relative  *
C          accuracy.                                             *
C EPSREL - error bound for relative error; EPSREL >= 0; if       *
C          EPSREL = 0 the algorithm maintains only the absolute  *
C          accuracy.                                             *
C  NMAX  - maximal number of evaluations of the right hand side  *
C                                                                *
C                                                                *
C  OUTPUT PARAMETERS:                                            *
C  ==================                                            *
C  XK    - final X value of the integration. If IERR = 0,        *
C          usually XK = XE (within machine precision).           *
C  HK    - terminal step size used; should be used for subsequent*
C          integrations                                          *
C  YK    - approximate value for the solution at XK              *
C  NUSED - number of actual evaluations of the right hand side   *
C  IERR  - error parameter:                                      *
C          = 0: all is o.k.                                      *
C          = 1: both error bounds  EPS...  too small             *
C                              (relative to the machine constant)*
C          = 2: XE <= XK       (relative to the machine constant)*
C          = 3: step size  HK <= 0  (rel. to machine precision)  *
C          = 4: N > 20   or   N <= 0                             *
C          = 5: NUSED > NMAX: Number of allowed function         *
C               evaluations was exceeded; try to restart with    *
C               XK, YK and HK.                                   *
C          = 6: The Jacobi matrix is singular; XK, YK, HK contain*
C               the values reached.                              *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  Subroutines used:  IVP, GAUSSP, GAUSSS, DVNORM, MACHPD        *
C                                                                *
C*****************************************************************
C                                                                *
C  Author      : Klaus Niederdrenk                               *
C  Date        : 1.22.1996                                       *
C  Source code : FORTRAN 77                                      *
C                                                                *
C*****************************************************************
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION YK(1:N)
      PARAMETER ( NDGL = 20 )
      DIMENSION ZJ(0:4,1:NDGL), ZJP1(0:4,1:NDGL), F(1:NDGL)
      DIMENSION FS(1:NDGL,1:NDGL), HELP(1:NDGL), Y0(1:NDGL)
      DIMENSION YKP1(1:NDGL), CON(1:NDGL)
      DIMENSION D(1:NDGL), IPIVOT(1:NDGL), FSG(1:NDGL,1:NDGL)
      LOGICAL IEND, LEPSI
      EXTERNAL DES
      SAVE EPS1, EPS2, LEPSI, Y0, HS
      DATA LEPSI / .TRUE. / , Y0 / NDGL * 0.0D0 /
C
C** Using the machine constant FMACHP, we determine EPS1 in order
C** to avoid excessively small final steps near XE, EPS2 to check
C** for zero and HS as the optimal step size for approximating the
C** Jacobi matrix. (This is done only once at the start.)
C
      IF ( LEPSI ) THEN
        FMACHP = 1.0D0
  10    FMACHP = 0.5 * FMACHP
        IF ( MACHPD(1.0 + FMACHP) .EQ. 1) GOTO 10
        FMACHP = 2.0D0 * FMACHP
        EPS1   = FMACHP ** 0.75D0
        EPS2   = 100.0D0 * FMACHP
        HS     = 10.0D0 * SQRT(FMACHP)
        LEPSI  = .FALSE.
      ENDIF
C
C** Initialize
C
      SG    = DSIGN(1.0D0, XE)
      XEND  = (1.0D0 - SG*EPS2) * XE
      IERR  = 0
      NUSED = 0
      IEND  = .FALSE.
C
C** Check input parameters
C
      YMAX = DVNORM(YK, Y0, N)
      IF (EPSABS .LE. EPS2*YMAX .AND. EPSREL .LE. EPS2) THEN
        IERR = 1
      ELSE IF (XEND .LT. XK) THEN
        IERR = 2
      ELSE IF (HK .LT. EPS2*DABS(XK)) THEN
        IERR = 3
      ELSE IF ( N .LE. 0 .OR. N .GT. NDGL ) THEN
        IERR = 4
      ENDIF
      IF (IERR .NE. 0)  R E T U R N
C
C****  compute first integration   ****
C
      IF (XK+HK .GT. XEND) THEN
        HK = XE - XK
        DUMMY = HK
        IEND = .TRUE.
      ENDIF
      DO 20 I = 1, N
        HELP(I) = YK(I)
  20  CONTINUE
      XKA = XK
      XKE = XKA
      HKA = 0.25*HK
      HK1 = HKA
      DO 40 K = 1, 4
        XKE = XKE + HKA
        CALL IVP (XKA, HK1, HELP, N, DES, XKE, EPSABS, EPSREL,
     #            1, NMAX-NUSED, NANL, IERR)
        NUSED = NUSED + NANL
        IF( IERR .NE. 0 ) R E T U R N
        DO 30 I = 1, N
          ZJP1(K,I) = HELP(I)
  30    CONTINUE
  40  CONTINUE
      CALL DES (XK, YK, N, F)
      NUSED = NUSED + 1
C
C** Determine first Gear-Nordsieck approximation
C
      DO 50 I = 1, N
        ZJ(0,I) = YK(I)
        ZJ(1,I) = HK*F(I)
        ZJ(2,I) = 1.0D0/24.0D0*(35.0D0*YK(I) - 104.0D0*ZJP1(1,I)
     #            + 114.0D0*ZJP1(2,I) - 56.0D0*ZJP1(3,I)
     #            +  11.0D0*ZJP1(4,I))
        ZJ(3,I) = 1.0D0/12.0D0*(-5.0D0*YK(I) + 18.0D0*ZJP1(1,I)
     #            - 24.0D0*ZJP1(2,I) + 14.0D0*ZJP1(3,I)
     #            -  3.0D0*ZJP1(4,I))
        ZJ(4,I) = 1.0D0/24.0D0*(YK(I) - 4.0D0*ZJP1(1,I)
     #            + 6.0D0*ZJP1(2,I) - 4.0D0*ZJP1(3,I) + ZJP1(4,I))
  50  CONTINUE
C
C
C****  S t e p  S i z e  A l g o r i t h m   ****
C
C
  75  CONTINUE
C
C** Compute implicit approximation using Newton method
C
      DO 90 I = 1, N
        YKP1(I) = ZJ(0,I)+ZJ(1,I)+ZJ(2,I)+ZJ(3,I)+ZJ(4,I)
  90  CONTINUE
      CALL DES (XK+HK, YKP1, N, F)
      DO 120 K = 1, N
        DO 100 I = 1, N
          HELP(I) = YKP1(I)
 100    CONTINUE
        HELP(K) = HELP(K) - HS
        CALL DES (XK+HK, HELP, N, FS(1,K))
        DO 110 I = 1, N
          FS(I,K) = -HK * 0.48D0 * (F(I) - FS(I,K)) / HS
 110    CONTINUE
        FS(K,K) = FS(K,K) + 1.0D0
 120  CONTINUE
      NUSED = NUSED + N + 1
      DO 190 I = 1, N
        CON(I) = YKP1(I) - 0.48D0 * ( ZJ(1,I) + 2.0D0*ZJ(2,I)
     #           + 3.0D0*ZJ(3,I) + 4.0D0*ZJ(4,I) )
        DO 180 K = 1, N
          FSG(K,I) = FS(K,I)
 180    CONTINUE
 190  CONTINUE
      CALL GAUSSP (N, FSG, NDGL, IPIVOT, MARK, D)
      IF ( MARK .EQ. 0 ) THEN
        IERR = 6
        R E T U R N
      ENDIF
      DO 220 ITER = 1, 3
        DO 210 I = 1, N
          HELP(I) = -YKP1(I)
          DO 200 K = 1, N
            HELP(I) = HELP(I) + FS(I,K)*YKP1(K)
 200      CONTINUE
          HELP(I) = HK*0.48D0*F(I) + HELP(I) + CON(I)
 210    CONTINUE
        CALL GAUSSS (N, FSG, NDGL, IPIVOT, HELP, YKP1)
        CALL DES (XK+HK, YKP1, N, F)
 220  CONTINUE
      NUSED = NUSED + 3
C
C** Determine corresponding Gear-Nordsieck approximation
C
      DO 230 I = 1, N
        HELP(I) = HK*F(I) - ZJ(1,I) - 2.0D0*ZJ(2,I)
     #              - 3.0D0*ZJ(3,I) - 4.0D0*ZJ(4,I)
 230  CONTINUE
      DO 250 I = 1, N
        ZJP1(0,I) = YKP1(I)
        ZJP1(1,I) = HK*F(I)
        ZJP1(2,I) = ZJ(2,I) + 3.0D0*ZJ(3,I) + 6.0D0*ZJ(4,I)
     #              + 0.7D0*HELP(I)
        ZJP1(3,I) = ZJ(3,I) + 4.0D0*ZJ(4,I) + 0.2D0*HELP(I)
        ZJP1(4,I) = ZJ(4,I) + 0.02D0*HELP(I)
 250  CONTINUE
C
C** Determine whether the last step should be accepted
C
      DO 260 I = 1, N
        HELP(I) = ZJP1(4,I)
        CON(I)  = ZJ(4,I)
 260  CONTINUE
      DIFF = DVNORM(HELP, CON, N)
      YMAX = DVNORM(YKP1, Y0, N)
      EPS = (EPSABS + EPSREL*YMAX) / 6.0D0
      Q = DSQRT(DSQRT(EPS/DIFF))/1.2
      IF ( DIFF .LT. EPS ) THEN
C
C** Accept last step; prepare for next integration step
C
        XK = XK + HK
        DO 270 I = 1, N
          YK(I) = YKP1(I)
 270    CONTINUE
C
C** Jump back if the interval endpoint XE has been reached or
C** if the right hand side has been called too often.
C
 275    IF ( IEND ) THEN
          HK = DUMMY
          R E T U R N
        ELSE IF ( NUSED .GT. NMAX ) THEN
          IERR = 5
          R E T U R N
        ENDIF
C
C** adapt step size for next step
C
        HALT = HK
        HK = DMIN1(Q, 2.0D0) * HK
        IF ( XK + HK .GE. XEND ) THEN
          DUMMY = HK
          HK = XE - XK
          IEND = .TRUE.
C
C** jump back if sufficiently close to XE
C
          IF ( HK .LT. EPS1*DABS(XE) ) GOTO 275
        ENDIF
C
C** Set up the Gera-Nordsieck approximation for the next
C** integration
C
        QUOT1 = HK / HALT
        QUOT2 = QUOT1 * QUOT1
        QUOT3 = QUOT2 * QUOT1
        QUOT4 = QUOT3 * QUOT1
        DO 280 I = 1, N
          ZJ(0,I) = ZJP1(0,I)
          ZJ(1,I) = QUOT1 * ZJP1(1,I)
          ZJ(2,I) = QUOT2 * ZJP1(2,I)
          ZJ(3,I) = QUOT3 * ZJP1(3,I)
          ZJ(4,I) = QUOT4 * ZJP1(4,I)
 280    CONTINUE
      ELSE
C
C** Repeat last step for a smaller step size
C** and modify the Gear-Nordsieck approximation accordingly
C
        HALT = HK
        HK = DMAX1(0.5D0, Q) * HK
        QUOT1 = HK / HALT
        QUOT2 = QUOT1 * QUOT1
        QUOT3 = QUOT2 * QUOT1
        QUOT4 = QUOT3 * QUOT1
        DO 290 I = 1, N
          ZJ(1,I) = QUOT1 * ZJ(1,I)
          ZJ(2,I) = QUOT2 * ZJ(2,I)
          ZJ(3,I) = QUOT3 * ZJ(3,I)
          ZJ(4,I) = QUOT4 * ZJ(4,I)
 290    CONTINUE
        IEND = .FALSE.
      ENDIF
C
      GOTO 75
C
      END


Begin of file
Contents
Index