End of file
Contents
Index

      SUBROUTINE IMRUKU (DES,N,MMAX,LUNIN,LUNOUT,LUNPR,IERR,EPSM,
     1                   EPS,G,X0,XEND,Y0,YQ,
     2                   FAC,DELTAK,HEPS,ALPHA,ALPHAQ,A,AQ,
     3                   F0,F1,DFDX,Y,YOLD,DFDY,
     4                   DBLEK,BETA,BETAQ,DBLEKQ,DB)
C
C*****************************************************************
C                                                                *
C IMRUKU solves an initial value problem (IVP) for systems of N  *
C given differential equations of 1st order.                     *
C The solution of the IVP is obtained with an implicit RUNGE-    *
C KUTTA method (IRKM), where we use step size control and control*
C the order of the IRKM as well.                                 *
C For this the subroutine IMRUKU needs IRKMs of orders 1 to MMAX.*
C The coefficients that define these implicit RUNGE-KUTTA methods*
C are assumed to be available in a file available at the input   *
C LUNIN. This file can be created using the SUBROUTINE IRKCOE.   *
C                                                                *
C Before each RUNGE-KUTTA step we precheck the efficiency AW in  *
C order to find the optimal order in relation to the number of   *
C functional evaluations according to                            *
C         AW(EPS,M) = (N+1+4*M**2)/H(EPS,M).                     *
C Here H(EPS,M) is the step size for the order M and the accuracy*
C bound EPS. For each step we chose an M for which the work AW   *
C required for the IRKMs of order 1 to M+1 satisfy:              *
C        AW(EPS,I) >  AW(EPS,I+1) for I=1, ..., M-1              *
C  and   AW(EPS,M) <= AW(EPS,M+1);                               *
C  or    M=MMAX-1, if there is no suitable M between 1 and MMAX-1*
C                                                                *
C For this M we chose a step size H which usually is taken equal *
C to the theoretical step size H(EPS,M).                         *
C The RUNGE-KUTTA step is performed for two IRKMs. One IRKM has  *
C the order M with coefficient A, ALPHA and BETA. The other IRKM *
C is of order M+1 for the coefficients AQ, ALPHAQ and BETAQ.     *
C Determining the KI, called DBLEK and DBLEKQ in the program, is *
C done iteratively.                                              *
C                                                                *
C If in an iteration step, the relative difference EREL of the   *
C two approximations Y and YQ, that were obtained by two         *
C different methods, exceeds EPS, then the step size H is reduced*
C to H * SF * (0.5 * EPS * E)**(1/(2*M+1)). Here SF is a safety  *
C factor and E is the absolute difference of Y and YQ. Then the  *
C last step is repeated with the new step size H.                *
C If in an iteration step, the difference between two successive *
C approximations YQ(ALT) and YQ(NEU) exceeds the estimated       *
C theoretical iteration error DK, no convergence can be expected.*
C In this case the step size is decreased to 6/10 of the old     *
C step size and the last integration step is repeated.           *
C Iteration is continued until the relative difference between   *
C two successive approximations becomes smaller than the required*
C accuracy EPS.                                                  *
C Based on theoretical considerations this should be the case    *
C after at most 2*M+1 iterations.                                *
C However, if this does not happen, the order is increased to    *
C M + 1 and the last step is recomputed. If this would exceed    *
C MMAX-1 we alter the step size to 0.8*H instead.                *
C If, due to our step size control, H becomes less than ten      *
C times the machine constant, we stop : no convergence can be    *
C expected on the computer used.                                 *
C                                                                *
C                                                                *
C INPUT PARAMETERS:                                              *
C =================                                              *
C DES     : name of a subroutine, that represents the system of  *
C           differential equations. This subroutine has to be    *
C           declared as EXTERNAL in the calling program. It has  *
C           the form:                                            *
C                 SUBROUTINE DES (N,X,Y,F)                       *
C                 INTEGER N                                      *
C                 DOUBLE PRECISION X, Y(N), F(N)                 *
C                 F(1) = F1(X,Y(1),Y(2),...,Y(N))                *
C                 F(2) = F2(X,Y(1),Y(2),...,Y(N))                *
C                 -------------------------------                *
C                 F(N) = FN(X,Y(1),Y(2),...,Y(N))                *
C                 RETURN                                         *
C                 END                                            *
C N       : The number of differential equations                 *
C MMAX    : maximally allowed order, i.e. the highest order for  *
C           which coefficients are available in an auxiliary     *
C           file addressed at LUNIN. MMAX has to be >= 5.        *
C           It is not advisable to chose the maximum order NMAX  *
C           too high, since the quality of this procedure        *
C           strongly depends on the machine constant. E.g. on a  *
C           CONTROL DATA CYBER 175 with a DOUBLE PRECISION       *
C           machine constant of 2.5D-29, chosing NMAX = 12 has   *
C           proved adequate at the Computer center of the RWTH   *
C           Aachen. For other machines a larger MMAX may well be *
C           meaningful.                                          *
C LUNIN   : number of the file that contains the nodes for all   *
C           IRKMs up to order MMAX.                              *
C           This file can be produced by the SUBROUTINE IRKCOE.  *
C LUNOUT  : if output of intermediate points is desired (as de-  *
C           termined by the algorithm), a file with number LUNOUT*
C           is created for any LUNOUT > 0. If LUNOUT=0, there is *
C           no output.                                           *
C LUNPR   : >0; create a log file under number LUNPR, which      *
C               contains intermediate results and the algorithm  *
C               flow log.                                        *
C           =0; no output                                        *
C EPSM    : DOUBLE PRECISION machine constant                    *
C EPS     : desired relative accuracy                            *
C G       : vector G(1:N); the weights G(I) allow varied weighing*
C                          of the components Y(I) with respect to*
C                          the machine constant EPS. If all com- *
C                          ponents are to have the same weight,  *
C                          then G(I)=1 is chosen for all I.      *
C                          W A R N I N G:                        *
C                          If G(I)=0 for one I, division by zero *
C                          could occur if the corresponding      *
C                          components of the partial derivatives *
C                          on the right hand side are equal to   *
C                          zero. The program will not cover for  *
C                          this terminal error!                  *
C X0      : lower limit of the integration interval              *
C XEND    : upper limit of the integration interval              *
C Y0      : vector Y0(1:N); initial values Y(X0) at X0           *
C                                                                *
C                                                                *
C INPUT PARAMETERS: only used to provide storage space.          *
C =================                                              *
C FAC     : vector FAC(1:MMAX); the factoriels FAC(I)=(2*I)!     *
C DELTAK  : vector DELTAK(0:2*MMAX-1); vector used to determine  *
C           the theoretically estimated iteration error DK for   *
C           each iteration step                                  *
C HEPS    : vector HEPS(1:MMAX); HEPS(M) contains the theoretical*
C           step size for the IRKM of order M and EPS            *
C ALPHA   : vector ALPHA(1:MMAX-1);   ) coefficients of          *
C BETA    : 2-dimensional array       ) the IRKM of              *
C           BETA(1:MMAX-1,1:MMAX-1);  ) order M                  *
C A       : vector A(1:MMAX-1);       )                          *
C                                                                *
C ALPHAQ  : vector ALPHAQ(1:MMAX);    ) coefficients of          *
C BETAQ   : 2-dimensional array       ) the IRKM of              *
C           BETAQ(1:MMAX,1:MMAX);     ) order M + 1              *
C AQ      : vector AQ(1:MMAX);        )                          *
C                                                                *
C DBLEK   : 2-dimensional array DBLEK(1:N,1:MMAX-1); containing  *
C           the KI of the IRKM of order M                        *
C DBLEKQ  : 2-dimensional array DBLEKQ(1:N,1:MMAX); contains the *
C           KI of the IRKM of order M+1                          *
C DB      : 2-dimensional array DB(1:N,1:MMAX); auxiliary array  *
C           used to compute the KI for both order IRKMs.         *
C           this intermediate storage is needed in order to      *
C           perform the  iteration.                              *
C Y       : vector Y(1:N); the approximate solution for the      *
C           method with order M                                  *
C YOLD    : vector YOLD(1:N); storage of the previous approximate*
C           solution YQ for accuracy estimate                    *
C DFDX    : vector DFDX(1:N); derivative DF/DX of the right-hand *
C           side                                                 *
C DFDY    : 2-dimensional array DFDY(1:N,1:N); derivative DF/DY  *
C           of the right-hand side                               *
C F0      : vector F0(1:N); before each step we evaluate the     *
C           right-hand side at (X0,Y0)                           *
C F1      : vector F1(1:N); evaluation of the right-hand side at *
C           intermediate points, also used when estimating       *
C           derivatives                                          *
C                                                                *
C                                                                *
C OUTPUT PARAMETERS:                                             *
C ==================                                             *
C IERR    : error parameter                                      *
C           =0; run was successful                               *
C           =1; no convergence. Possible remedy: increase        *
C               maximum order MMAX.                              *
C           =3; too many calls of DES (IFU > MXCALL)             *
C EPS     : estimate of the largest local relative error         *
C YQ      : vector YQ(1:N); approximation for the solution of    *
C           IVP. Obtained by the method of order M+1             *
C                                                                *
C                                                                *
C LOCAL VARIABLES:                                               *
C ================                                               *
C I, J, K : loop variables                                       *
C L       : loop variable for the iteration                      *
C LH      : auxiliary variable for the output of L               *
C FACLP1  : (L+1)!                                               *
C IT2     : auxiliary variable I*2                               *
C M       : currently used order                                 *
C MM2     : auxiliary variable M*2                               *
C MM2M1   : auxiliary variable M*2-1                             *
C MM2M2   : auxiliary variable M*2-2                             *
C MP1     : auxiliary variable M+1                               *
C MM2P1   : auxiliary variable M*2+1                             *
C MMAXM1  : auxiliary variable MMAX-1                            *
C IFU     : counter for the number of functional evaluations. The*
C           evaluation of a vector-valued function (N>1) in only *
C           counted as one evaluation.                           *
C IPOS    : read counter in the node file, or the most recently  *
C           read order                                           *
C IBSP    : ) positioning the read position in the node file     *
C IGET    : )                                                    *
C ISC     : counter for the number of intermediate steps         *
C DELTAG  : difference between two successive approximations     *
C           YQ(OLD) and YQ(NEW).                                 *
C DGREL   : relative difference between two successive           *
C           approximations YQ(OLD) and YQ(NEW).                  *
C E       : difference between the two approximations Y and YQ   *
C           for the methods of differing orders.                 *
C EREL    : relative difference between the two approximations Y *
C           and YQ for the method with differing orders.         *
C YQNORM  : L2-norm of YQ                                        *
C DK      : at first an auxiliry variable for determining        *
C           DELTAK(L), then used for estimating the iteration    *
C           error, derived from theoretical considerations in the*
C           L-th iteration as                                    *
C           H**(L+2)/(L+2)! *                                    *
C              * SQRT (G*(DF/DX*(DF/DY)**L)**2/WGTSUM) * 5,      *
C           where 5. acts as a safety factor.                    *
C ICAUSE  : documents the cause for a decrease in step size:     *
C           =0, no decrease of step size                         *
C           =1, EREL >= EPS                                      *
C           =2, DELTAG >= DK                                     *
C           =3, DGREL >= EPS                                     *
C MOLD    : order of the previous step. If the new order is equal*
C           to the old one, the coefficients do not have to be   *
C           read in again.                                       *
C IC      : IC serves for dynamic modification of the safety     *
C           factor. In IC we count the number of step size       *
C           decreases caused by E<EPS.                           *
C DELTA   : square root of the machine constant for estimating   *
C           derivatives with forward difference quotients.       *
C WGTSUM  : G(1) + G(2) + ... + G(N)                             *
C SG      : sign for the step size H, this determines the        *
C           direction of integration.                            *
C YJ      : auxiliary variable for estimating the partial        *
C           derivatives DF/DY(J)                                 *
C YDIFF   : auxiliary variable for determining the difference    *
C HBEG    : step size at the last step                           *
C SF      : safety factor, which is used to decrease the step    *
C           size, it follows from theoretical considerations.    *
C           SF is modified according to the behaviour of the     *
C           differential equation while integrating.             *
C X       : upper bound of the sub-interval of integration from  *
C           X0 to X0+H=X.                                        *
C X1      : nodes X0 + H*ALPHA(K) in the interval [X0, X].       *
C EPSERR  : for safety reasons, we use EPSERR = 10*EPSM as the   *
C           machine constant on occasion.                        *
C ERROR   : estimate of the accuracy of the approximate solution *
C EPSLOC  : estimate of the largest local error                  *
C SUM     : auxiliary variable for determining the derivatives   *
C           DF/DX                                                *
C AW1     : ) variables for determining the amount of work       *
C AW2     : ) AW(EPS,M) = (N+1+4*M*M)/H(EPS,M)                   *
C TPOW    : determining of powers of ten                         *
C ZERO    : logic variable                                       *
C           =.TRUE., if DF/DX=0 or DF/DY=0                       *
C           =.FALSE. otherwise                                   *
C ORDCH   : logic variable for changing the order                *
C           =.TRUE., if the order has to be increased            *
C           =.FALSE. otherwise                                   *
C STOP    : logic variable for stopping the integration          *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  subroutines required: IRKRT                                   *
C                                                                *
C                                                                *
C  sources : 1. G. Engeln-Muellges, F. Reutter:                  *
C               Numerische Mathematik für Ingenieure, 4th ed.    *
C               1985.                                            *
C            2. D. Sommer, see [SOMM67].                         *
C                                                                *
C*****************************************************************
C                                                                *
C  author   : Thomas Eul                                         *
C  date     : 08.29.1985                                         *
C  source   : FORTRAN 77                                         *
C                                                                *
C*****************************************************************
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     symbolic constants
C
      INTEGER*4 MXCALL,IFU
C
C     Attention: The value 200000 may be too big for an INTEGER-constant
C
      PARAMETER (MXCALL = 200000)
C
C     parameters
C
      INTEGER   N, MMAX, LUNIN, LUNOUT, LUNPR, IERR
      DIMENSION G(N), Y0(N), YQ(N)
      DOUBLE PRECISION EPSM, EPS, X0, XEND, IRKRT
C
C     parameters (providing storage space)
C
      DIMENSION FAC(MMAX), F0(N), F1(N), DFDX(N), DFDY(N,N),
     1          DELTAK(0:2*MMAX-1), HEPS(MMAX),
     2          ALPHA(MMAX-1), BETA(MMAX-1,MMAX-1), A(MMAX-1),
     3          ALPHAQ(MMAX),  BETAQ(MMAX,MMAX),    AQ(MMAX),
     4          DBLEK(N,MMAX-1), DBLEKQ(N,MMAX),
     5          Y(N), YOLD(N), DB(N,MMAX)
C
C     local variables
C
      INTEGER IT2, I, J, K, L, MM2M1, MM2M2, MP1, IPOS, IBSP,
     1        MM2P1, MM2, ISC, ICAUSE, MOLD, MMAXM1, IC, IGET, LH,
     2        M
      DOUBLE PRECISION SF, DELTA, WGTSUM, SG, YJ, TPOW, DK, DELTAG
     1                ,HBEG, X, X1, EPSERR, ERROR, SUM, E, FACLP1
     2                ,H, YDIFF, EPSLOC, EREL, DGREL, YQNORM
      REAL AW1, AW2
      LOGICAL ZERO, ORDCH, STOP
C
      DATA SF/0.9D0/
C
C*****************************************************************
C*               i n i t i a l i z a t i o n                     *
C*****************************************************************
C
      IERR   = 0
      EPSERR = 10.0D0 * EPSM
      EPSLOC = 0.0D0
      DELTA  = DSQRT(EPSM)
      MMAXM1 = MMAX - 1
      X      = XEND - X0
      SG     = DSIGN(1.0D0,X)
      IFU    = 0
      ISC    = 0
      M      = 0
      IPOS   = 0
C
      REWIND (LUNIN)
      IF (LUNOUT .GT. 0) THEN
C
C        header for output file
C
         I = 1
         WRITE (LUNOUT,5100) X0,I,Y0(1)
         WRITE (LUNOUT,5200) (I,Y0(I),I=2,N)
         WRITE (LUNOUT,5300) XEND,EPS,MMAX
         WRITE (LUNOUT,7000) LUNPR
         WRITE (LUNOUT,7100)
      ENDIF
      IF (LUNPR .GT. 0) THEN
C
C        header for log file
C
         I = 1
         WRITE (LUNPR,5100) X0,I,Y0(1)
         WRITE (LUNPR,5200) (I,Y0(I),I=2,N)
         WRITE (LUNPR,5300) XEND,EPS,MMAX
         WRITE (LUNPR,5350)
         WRITE (LUNPR,5400) (I,G(I),I=1,N)
         WRITE (LUNPR,6000) LUNOUT
         WRITE (LUNPR,6100)
      ENDIF
C
C     determine the factorials, which
C     are required   FAC(I) = (2*I)!
C
      FAC(1) = 2.0D0
      DO 10 I = 2,MMAX
         IT2 = I * 2
         FAC(I) = FAC(I-1) * DBLE(IT2*(IT2-1))
   10 CONTINUE
C
C     determine the sum of the weights
C
      WGTSUM = 0.0D0
      DO 20 I = 1,N
         WGTSUM = WGTSUM + G(I)
   20 CONTINUE
C
C*****************************************************************
C*                   i n t e g r a t i o n                       *
C*****************************************************************
C
C     in the following REPEAT-loop, one integration step is
C     performed in each loop
C
 1000 CONTINUE
         ISC  = ISC + 1
         MOLD = M
         STOP = .FALSE.
C
C        check number of function calls
C
         IF (IFU .GT. MXCALL) THEN
C
C          if necessary stop and set error number
C
            STOP = .TRUE.
            IERR = 3
         ENDIF
C
C        determine approximations for the partial derivatives
C        of the right-hand side with respect to Y at
C        (X0,Y0) with forward difference quotients
C
         CALL DES (N,X0,Y0,F0)
         DO 40 J = 1,N
            YJ    = Y0(J)
            Y0(J) = YJ + DELTA
            CALL DES (N,X0,Y0,F1)
            DO 30 I = 1,N
               DFDY(I,J) = (F1(I)-F0(I))/DELTA
   30       CONTINUE
            Y0(J) = YJ
   40    CONTINUE
C
C        determine approximations for the partial derivatives
C        of the right-hand side with respect to X at
C        (X0,Y0) with forward difference quotients
C
         CALL DES (N,X0+DELTA,Y0,DFDX)
         DO 50 I = 1,N
            DFDX(I) = (DFDX(I)-F0(I))/DELTA
   50    CONTINUE
         DO 70 I = 1,N
            SUM = 0.0D0
            DO 60 J = 1,N
               SUM = SUM + DFDY(I,J)*F0(J)
   60       CONTINUE
            DFDX(I) = DFDX(I) + SUM
   70    CONTINUE
C
         IFU = IFU + N + 2
C
C        check whether all partial derivatives with
C        respect to Y are equal to 0
C
         ZERO = .TRUE.
         I    = 0
         J    = 0
   80    CONTINUE
            I = I + 1
   90       CONTINUE
               J = J + 1
               IF (DFDY(I,J) .NE. 0.0D0) ZERO = .FALSE.
            IF (ZERO .AND. J .LT. N) GO TO 90
         IF (ZERO .AND. I .LT. N) GO TO 80
C
C        check whether all partial derivatives
C        with respect to X are equal to 0
C
         IF (.NOT. ZERO) THEN
            ZERO = .TRUE.
            I = 0
  100       CONTINUE
               I = I + 1
               IF (DFDX(I) .NE. 0.0D0) ZERO = .FALSE.
            IF (ZERO .AND. I .LT. N) GO TO 100
         ENDIF
C
C*****************************************************************
C*   d e t e r m i n e  t h e  a m o u n t  o f  w o r k
C*****************************************************************
C
C        estimate the average iteration error, determine
C        the step size and the amount of work AW
C
C        the estimated average iteration error at the L-th
C        iteration is given as
C        H**(L+2)/(L+2)! * SQRT(G*(DF/DX*(DF/DY)**L)**2/WGTSUM).
C        Here the square root is determined by function IRKRT and it is
C        stored in DELTAK(L). The iteration error is given as
C        DK = H**(L+2) * DELTAK(L) / (L+2)! .
C
C        The step size for the method of order M is HEPS(M)=
C        EPS*(2*M)! / SQRT(G*(DF/DX*(DF/DY)**(2*M-2))**2/WGTSUM)
C        **(1/(2*M))
C
C        The amount of work AW is given as AW(EPS,M) =
C        (N+1+4*M*M) / HEPS(M). We use the order for which the
C        amount of work per functional evaluations needed is minimal.
C        This is the case for the first time for M,
C        for which   AW(EPS,M) < AW(EPS,M+1).
C
         IF (.NOT. ZERO) THEN
C
C           determine the order, the step size, as well as
C           estimate  the average iteration error if none of the
C           derivatives is equal to zero
C
            M  = 1
            DK = 0.0D0
            DO 110 I = 1,N
               DK = DK + G(I)*DFDX(I)*DFDX(I)
  110       CONTINUE
            DELTAK(0) = DSQRT(DK/WGTSUM)
            HEPS(1)   = DSQRT (EPS * FAC(1) / DELTAK(0))
            AW2       = REAL(N+5) / REAL(HEPS(1))
            M         = 2
 2000       CONTINUE
               AW1           = AW2
               MM2M2         = M*2 - 2
               DELTAK(2*M-3) = IRKRT (N,DFDY,DFDX,WGTSUM,G,F1)
               DELTAK(MM2M2) = IRKRT (N,DFDY,DFDX,WGTSUM,G,F1)
               IF (DELTAK(MM2M2) .NE. 0.0D0) THEN
                  HEPS(M) = (EPS * FAC(M) / DELTAK(MM2M2))
     1                       ** (1.0D0 / DBLE(2*M))
                  AW2     = REAL(N+1+4*M*M) / REAL(HEPS(M))
                  M       = M + 1
               ELSE
                  ZERO = .TRUE.
               ENDIF
            IF (M .LE. MMAX .AND. AW2 .LT. AW1 .AND.
     1                                         .NOT. ZERO) GOTO 2000
            M = M - 2
         ENDIF
         IF (ZERO) THEN
C
C           when determining the step size HEPS(M) we encountered
C           division by zero. Then we chose the order 3 is chosen and
C           set DELTAK(L) = EPS * 10**(5-L), for L=1, ..., 5.
C           For the initial step size  we chose 0.1 .
C
            M    = 3
            TPOW = 1.0D0
            DO 120 I = 1,6
               DELTAK(6-I) = EPS * TPOW
               TPOW        = TPOW * 10.0D0
  120       CONTINUE
            H = SG * 0.1D0
         ELSE
C
C           determine the ultimate step size
C
            H = SG * SF * HEPS(M)
         ENDIF
C
C        initializations for the new step
C
         IC = 0
         X  = X0 + H
         IF (SG*(XEND-X) .LT. 0.0D0) THEN
            H = XEND - X0
            X = XEND
         ENDIF
         ORDCH = .FALSE.
         IF (M .NE. MOLD) THEN
C
C*****************************************************************
C*              r e a d   c o e f f i c i e n t s                *
C*****************************************************************
C
C           if the new order is different from the one in the old
C           step, the coefficients have to be read in again
C
            IBSP = IPOS - M
            IGET = M - IPOS
            IF (IBSP .EQ. 0) THEN
C
C              new order is 1 larger than the old one
C
               BACKSPACE (LUNIN)
            ELSEIF (IBSP .GT. 0) THEN
C
C              new order is smaller than the old one
C
               DO 130 I = 1,IBSP
                  BACKSPACE (LUNIN)
  130          CONTINUE
               BACKSPACE (LUNIN)
               IGET = 0
            ELSE
C
C              new order is larger by at least 2
C
               IGET = IGET - 1
            ENDIF
            DO 140 I = 1,IGET
               READ (LUNIN)
  140       CONTINUE
            READ (LUNIN) IPOS,(ALPHA(J),J=1,IPOS),
     1                        ((BETA(J,K),J=1,IPOS),K=1,IPOS),
     2                         (A(J),J=1,IPOS)
            READ (LUNIN) IPOS,(ALPHAQ(J),J=1,IPOS),
     1                        ((BETAQ(J,K),J=1,IPOS),K=1,IPOS),
     2                         (AQ(J),J=1,IPOS)
C
C           determining frequently used constants
C
            MP1   = M + 1
            MM2   = M * 2
            MM2P1 = MM2 + 1
            MM2M1 = MM2 - 1
            MM2M2 = MM2 - 2
         ENDIF
C
C*****************************************************************
C*            P E R F O R M I N G  O N E  S T E P                *
C*****************************************************************
C
C        the following REPEAT-loop is executed until the required
C        accuracy is achieved, i.e., until the step was executed
C        successfully. Exception: step width H falls below EPSERR,
C        which indicates that the procedure does not converge
C
 3000    CONTINUE
            IF (ORDCH) THEN
C
C              the order is increased by 1. ALPHA, BETA and A
C              are overwritten with the coefficients ALPHAQ,
C              BETAQ and AQ
C
               ORDCH = .FALSE.
               M     = M + 1
               MP1   = M + 1
               DO 160 I = 1,M
                  ALPHA(I) = ALPHAQ(I)
                  DO 150 J = 1,M
                     BETA(J,I) = BETAQ(J,I)
  150             CONTINUE
                  A(I) = AQ(I)
  160          CONTINUE
C
C              the new coefficients for ALPHAQ, BETAQ and AQ
C              are read in
C
               READ (LUNIN) IPOS,(ALPHAQ(J),J=1,IPOS),
     1                       ((BETAQ(J,K),J=1,IPOS),K=1,IPOS),
     2                        (AQ(J),J=1,IPOS)
C
C              determining frequently used constants
C
               MM2   = M * 2
               MM2P1 = MM2 + 1
               MM2M1 = MM2 - 1
               MM2M2 = MM2 - 2
               IF (.NOT. ZERO) THEN
C
C                 DELTAK and HEPS have to be determined for the
C                 new order. The old values may be used in part.
C
                  DELTAK(MM2M1) = IRKRT (N,DFDY,DFDX,WGTSUM,G,F1)
                  DELTAK(MM2)   = IRKRT (N,DFDY,DFDX,WGTSUM,G,F1)
                  IF (DELTAK(MM2M2) .NE. 0.0D0) THEN
                     HEPS(M) = (EPS * FAC(M) / DELTAK(MM2M2))
     1                          ** (1.0D0 / DBLE(MM2))
                     H       = SG * SF * HEPS(M)
                  ELSE
                     ZERO = .TRUE.
                  ENDIF
               ENDIF
               IF (ZERO) THEN
C
C                 When determining the step size HEPS(M) we have
C                 encountered division by zero. In this case we set
C                 DELTAK(L) = EPS * 10**(5-L), for L = 1, ..., 2*M-1
C                 and chose 0.1 as the initial step size.
C
                  TPOW = 1.0D0
                  DO 170 I = 1,MM2
                     DELTAK(MM2-I) = EPS * TPOW
                     TPOW          = TPOW * 10.0D0
  170             CONTINUE
                  H = SG * 0.1D0
               ENDIF
            ENDIF
C
C*****************************************************************
C*                      i t e r a t i o n                        *
C*****************************************************************
C
C           Initializing the weights KI and KIQ, i.e., DBLEK and
C           DBLEKQ to be equal to the value H*F0 for the iteration
C
            DO 190 I = 1,N
               DO 180 J = 1,M
                  DBLEK(I,J)  = H*F0(I)
                  DBLEKQ(I,J) = H*F0(I)
  180          CONTINUE
               DBLEKQ(I,MP1) = H*F0(I)
  190       CONTINUE
C
C           store the old approximation,
C           in order to be able to find an error
C           estimate after the first iteration
C
            DO 200 I = 1,N
               YOLD(I) = Y0(I) + H*F0(I)
  200       CONTINUE
C
C           In the following REPEAT-loop we perform a complete
C           iteration until the required accuracy is achieved
C           or until the number of iterations exceeds 2*M+1.
C           If the latter is the case, the order is increased
C           and the step is repeated. If a convergence of this
C           iteration is not occuring, or if the order cannot
C           be increased further, the whole step is repeated
C           with a lower step size
C
            L = 0
            FACLP1 = 1.0D0
 4000       CONTINUE
C
C              check number of function calls
C
               IF (IFU .GT. MXCALL) THEN
C
C                 if necessary stop and set error number
C
                  STOP = .TRUE.
                  IERR = 3
               ENDIF
               L      = L + 1
               FACLP1 = FACLP1 * (L+1)
               ICAUSE = 0
C
C*****************************************************************
C*           L-th full iteration to find the weights DBLEK     *
C*****************************************************************
C
               DO 240 K = 1,M
C
C                 determine intermediate points in the
C                 interval [X0, X0+H]
C
                  X1 = X0 + H*ALPHA(K)
                  DO 220 I = 1,N
                     Y(I) = Y0(I)
                     DO 210 J = 1,M
                        Y(I) = Y(I) + DBLEK(I,J)*BETA(J,K)
  210                CONTINUE
  220             CONTINUE
C
C                 insert the intermediate points into the
C                 right-hand side of the differential equation
C
                  CALL DES (N,X1,Y,F1)
C
C                 perform the full step
C
                  DO 230 I = 1,N
                     DB(I,K) = H*F1(I)
  230             CONTINUE
  240          CONTINUE
C
C              store the new weights DBLEK after the
C              full step
C
               DO 260 I = 1,N
                  DO 250 J = 1,M
                     DBLEK(I,J) = DB(I,J)
  250             CONTINUE
  260          CONTINUE
C
C*****************************************************************
C*           L-th iteration for the weights DBLEKQ using a       *
C*           complete step                                       *
C*****************************************************************
C
               DO 300 K = 1,MP1
C
C                 determine the intermediate points in the
C                 interval [X0, X0+H]
C
                  X1 = X0 + H*ALPHAQ(K)
                  DO 280 I = 1,N
                     YQ(I) = Y0(I)
                     DO 270 J = 1,MP1
                        YQ(I) = YQ(I) + DBLEKQ(I,J)*BETAQ(J,K)
  270                CONTINUE
  280             CONTINUE
C
C                 insert the intermediate points into the
C                 right-hand side of the differential equation
C
                  CALL DES (N,X1,YQ,F1)
C
C                 perform one full step
C
                  DO 290 I = 1,N
                     DB(I,K) = H*F1(I)
  290             CONTINUE
  300          CONTINUE
C
C              store the new weights DBLEK after the
C              complete step
C
               DO 320 I = 1,N
                  DO 310 J = 1,MP1
                     DBLEKQ(I,J) = DB(I,J)
  310             CONTINUE
  320          CONTINUE
C
               IFU = IFU + MM2P1
C
C*****************************************************************
C*           approximations  from  the  L-th  iteration          *
C*****************************************************************
C
C              determine new approximations Y with
C              order M, and YQ with order M+1, in the L-th
C              iteration using RUNGE-KUTTA
C
               DO 340 I = 1,N
                  Y(I)  = Y0(I)
                  YQ(I) = Y0(I)
                  DO 330 J = 1,M
                     Y(I)  = Y(I) + A(J)  * DBLEK(I,J)
                     YQ(I) = YQ(I)+ AQ(J) * DBLEKQ(I,J)
  330             CONTINUE
                  YQ(I) = YQ(I) + AQ(MP1) * DBLEKQ(I,MP1)
  340          CONTINUE
C
C              determine the absolute and relative average
C              difference DELTAG and DGREL between two
C              successive iterations, as well as the absolute
C              or relative average difference E or EREL
C              between the two approximative solutions
C              obtained using methods of different order
C
               DELTAG = 0.0D0
               E      = 0.0D0
               YQNORM = 0.0D0
               DO 350 I = 1,N
                  YQNORM  = YQNORM + YQ(I)*YQ(I)
                  YDIFF   = YQ(I) - YOLD(I)
                  DELTAG  = DELTAG + G(I) * YDIFF*YDIFF
                  YDIFF   = Y(I) - YQ(I)
                  E       = E + G(I) * YDIFF*YDIFF
                  YOLD(I) = YQ(I)
  350          CONTINUE
               DELTAG = DSQRT(DELTAG/WGTSUM)
               E      = DSQRT(E/WGTSUM)
               IF (YQNORM .GT. 0.0D0) THEN
                   YQNORM = DSQRT(YQNORM)
                   DGREL  = DELTAG/YQNORM
                   EREL   = E/YQNORM
               ELSE
                   DGREL = DELTAG
                   EREL  = E
               ENDIF
               ERROR  = DMAX1(EREL,DGREL)
               EPSLOC = DMAX1(EPSLOC,ERROR)
C
C*****************************************************************
C*             test  for  stopping the  iteration                *
C*****************************************************************
C
               LH = L
               IF (EREL .GE. EPS) THEN
C
C                 the difference between two approximations for
C                 different orders differ by a term of the same
C                 order 2*M+1 when using full steps as that of the
C                 approximate solution.
C                 If this is not the case the step size is decreased
C                 according to the theory.
C
                  ICAUSE = 1
                  IF (IC .NE. 0) SF = SF * 0.9D0
                  IC   = IC + 1
                  HBEG = H
                  H    = H * SF * (0.5D0*EPS/E)**(1.0D0/DBLE(MM2P1))
                  L    = 0
               ELSE
C
C                 compute the estimated average iteration error
C
                  IF (ZERO) THEN
                     DK = DELTAK(L-1)
                  ELSE
                     DK = 5.0D0 * H**(L+1) * DELTAK(L-1) / FACLP1
                  ENDIF
C
C                 When computing H only the local error is considered,
C                 hence we need to test for convergence of the
C                 iteration procedure
C
                  IF (DELTAG .GE. DK) THEN
                     ICAUSE = 2
                     HBEG   = H
                     H      = 0.6D0 * H
                     SF     = 0.8D0 * SF
                     L      = 0
                  ELSE
                     IF (DGREL .GE. EPS .AND. M .GE. MMAXM1 .AND.
     1                       L .GE. MM2M1) THEN
C
C                       if the maximum number of iterations is
C                       reached but without the desired accuracy,
C                       then the order should be increased. If this
C                       is not possible, since e.g. no more nodes
C                       are available, we attempt to come to a successful
C                       end by decreasing the step size
C
                        ICAUSE = 3
                        HBEG   = H
                        H      = 0.8D0 * H
                        L      = 0
                     ENDIF
                  ENDIF
               ENDIF
               IF (L .EQ. 0) THEN
C
C                 L=0 indicates that the step  cannot be
C                 completed successfully
C
                  IF (LUNPR .GT. 0) THEN
                     WRITE (LUNPR,6200) ISC,M,HBEG,X,YQ(1),ERROR,
     1                                  IFU,LH,ICAUSE
                     WRITE (LUNPR,6300) (YQ(I),I=2,N)
                  ENDIF
                  IF (H .LT. EPSERR) THEN
C
C                    the procedure does not converge
C
                     STOP = .TRUE.
                     IERR = 1
                  ELSE
C
C                    the calculations of the last step are
C                    cancelled and the step is repeated
C
                     FACLP1 = 1.0D0
                     X      = X0 + H
                     IF (SG*(XEND-X) .LT. 0.0D0) THEN
                        H = XEND - X0
                        X = XEND
                     ENDIF
                     DO 370 I = 1,N
                        DO 360 J = 1,M
                           DBLEK(I,J)  = H * F0(I)
                           DBLEKQ(I,J) = H * F0(I)
  360                   CONTINUE
                        DBLEKQ(I,MP1) = H * F0(I)
  370                CONTINUE
                     DO 380 I = 1,N
                        YOLD(I)  = Y0(I) + H*F0(I)
  380                CONTINUE
                  ENDIF
               ENDIF
C
C*****************************************************************
C*                l o o p    i n q u i r i e s                   *
C*****************************************************************
C
            IF (((L .LT. MM2M1 .AND. DGREL .GE. EPS) .OR. L .EQ. 0)
     1                         .AND. .NOT. STOP) GOTO 4000
            IF (DGREL .GE. EPS .AND. MP1 .LT. MMAX
     1                         .AND. .NOT. STOP) THEN
C
C              the desired accuracy has not been reached after
C              the theoretically maximal number of iterations. The
C              order is increased and the step is repeated
C
               ORDCH  = .TRUE.
               ICAUSE = 4
               IF (LUNPR .GT. 0) THEN
                  WRITE (LUNPR,6200) ISC,M,H,X,YQ(1),ERROR,IFU,
     1                               L,ICAUSE
                  WRITE (LUNPR,6300) (YQ(I),I=2,N)
               ENDIF
            ELSE
C
C              prevent from overstep the maximal order
C
               ORDCH = .FALSE.
            ENDIF
         IF (ORDCH) GOTO 3000
         IF (.NOT. STOP) THEN
C
C           the step was successfully completed
C
            IF (LUNPR .GT. 0) THEN
               WRITE (LUNPR,6200) ISC,M,H,X,YQ(1),ERROR,IFU,L,
     1                            ICAUSE
               WRITE (LUNPR,6300) (YQ(I),I=2,N)
            ENDIF
            IF (LUNOUT .GT. 0) THEN
                  I = 1
                  WRITE (LUNOUT,7200) ISC,X,I,YQ(1),ERROR
                  WRITE (LUNOUT,7300) (I,YQ(I),I=2,N)
            ENDIF
         ENDIF
C
         IF (X .NE. XEND .AND. .NOT. STOP) THEN
C
C           the end of the integration interval has not
C           been reached
C
            IF (IC .GT. 1) SF = SF / 0.97D0
            X0 = X
            DO 390 I = 1,N
               Y0(I) = YQ(I)
  390       CONTINUE
         ELSE
C
C           program stop since the initial value problem was
C           solved (IERR=0), or because the procedure does not
C           converge (IERR=1)
C
            STOP  = .TRUE.
            EPS   = EPSLOC
         ENDIF
      IF (.NOT. STOP) GOTO 1000
C
C*****************************************************************
C*           f o r m a t  s t a t e m e n t s                    *
C*****************************************************************
C
 5100 FORMAT ('1','INITIAL CONDITION:',//,
     1        1X,10X,'X0',10X,2X,'COMP.',2X,10X,'Y0',/,
     2        1X,E22.15,      1X,I4,1X  ,2X,E22.15)
 5200 FORMAT (1X,            23X,I4,1X  ,2X,E22.15)
 5300 FORMAT ('0','RIGHT ENDPOINT OF THE INTERVAL OF INTEGRATION: ',
     1        E22.15,/,30X,'DESIRED ACCURACY: ',E22.15,/
     2         ,25X,'LARGEST ORDER ALLOWED:',I4)
 5350 FORMAT ('0','REASON FOR DECREASE IN STEP SIZE' ,/,5X
     2        ,'0  NO DECREASE',/,5X
     3        ,'1  EREL >= EPS',/,5X,'2  DELTAG >= DK',/,5X
     4        ,'3  DGREL >= EPS')
 5400 FORMAT ('0','WEIGHTS G:       COMP.  ',10X,'G',/,
     1         (17X,I4,3X,E22.15))
 6000 FORMAT ('0','NUMBER OF THE OUTPUT FILE (0=NONE):',I4)
 6100 FORMAT ('0',' STEP  ORDER STEP SIZE  UPPER BOUND APPROXIMATION',
     1        ' ERROR      FUNCTION ITERATION CAUSE',/,18X,'H',24X,
     2        'Y',7X,'ESTIMATE',3X,'CALLS',4X,'STEPS')
 6200 FORMAT (1X,I6,2X,I3,2X,E10.3,1X,E10.3,2X,E13.6,1X,E10.3,1X,
     1        I8,1X,I9,3X,I1)
 6300 FORMAT (36X,E13.6)
 7000 FORMAT ('0','NUMBER OF THE LOG FILE (0=NONE):',I4)
 7100 FORMAT ('0',' STEP  BOUND FOR UPPER LIMIT  COMP.',2X,
     1        'APPROXIMATE SOLUTION     ERROR ESTIMATE',/,7X,
     2        ' OF INTEGRATIONINTERVAL ')
 7200 FORMAT (1X,I6,1X,E22.15,1X,I4,2X,D24.17,1X,E18.11)
 7300 FORMAT (31X,I4,2X,D24.17)
C
      RETURN
      END
C
C

      DOUBLE PRECISION FUNCTION IRKRT (N,DFDY,DFDX,WGTSUM,G,DFDXH)
C
C*****************************************************************
C                                                                *
C The DOUBLE PRECISION FUNCTION IRKRT determines square roots,   *
C that occur in SUBROUTINE IMRUKU when determining the step size *
C H and the estimated average iteration error DK or DELTAK(L),   *
C L=0, 1, ...., 2*M+1.                                           *
C                                                                *
C IRKRT = SQRT(G*(DF/DX*(DF/DY)**K))**2/WGTSUM), for K=1,..,2*M-1*
C                                                                *
C Here we determine (DF/DY)**K during each call of IRKRT, by     *
C storing (DF/DY)**(K-1)*DF/DX in vector previously used for     *
C DF/DX and DFDX.                                                *
C                                                                *
C                                                                *
C INPUT PARAMETERS: (compare description of variables in IMRUKU) *
C =================                                              *
C N       : dimension                                            *
C DFDY    : 2-dimensional array DFDY(1:N,1:N); the derivative    *
C           DF/DY of the right-hand side of the differential     *
C           equation with respect to Y from IMRUKU at (X0,Y0).   *
C DFDX    : vector DFDX(1:N); the derivative DF/DX of the right- *
C           hand side of the differential equation with respect  *
C           to X from IMRUKU or (DF/DY)**(K-1) * DF/DX at (X0,Y0)*
C G       : vector G(1:N) of weights                             *
C WGTSUM  : G(1) + G(2) + ... + G(N)                             *
C DFDXH   : vector DFDXH(1:N); auxiliary storage                 *
C                                                                *
C                                                                *
C OUTPUT PARAMETERS:                                             *
C ==================                                             *
C IRKRT   : computed square root (compare program description)   *
C DFDX    : vector DFDX(1:N);  (DF/DY)**K * DF/DX                *
C                                                                *
C                                                                *
C LOCAL VARIABLES:                                               *
C ================                                               *
C I,J     : control variables                                    *
C SUM     : scalar products DFDY(I,..)*DFDX                      *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  subroutines required: none                                    *
C                                                                *
C*****************************************************************
C                                                                *
C  author   : Thomas Eul                                         *
C  date     : 08.12.1985                                         *
C  source   : FORTRAN 77                                         *
C                                                                *
C*****************************************************************
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     parameter
C
      INTEGER N
      DIMENSION DFDX(N), DFDY(N,N), G(N), DFDXH(N)
      DOUBLE PRECISION  WGTSUM
C
C     local variables
C
      INTEGER I, J
      DOUBLE PRECISION  SUM
C
      DO 20 I = 1,N
         SUM = 0.0D0
         DO 10 J = 1,N
            SUM = SUM + DFDY(I,J) * DFDX(J)
   10    CONTINUE
         DFDXH(I) = SUM
   20 CONTINUE
      SUM = 0.0D0
      DO 30 J = 1,N
         DFDX(J) = DFDXH(J)
         SUM = SUM + DFDX(J)**2 * G(J)
   30 CONTINUE
      IRKRT = DSQRT(SUM/WGTSUM)
C
      RETURN
      END


Begin of file
Contents
Index