C      ALGORITHM 690, COLLECTED ALGORITHMS FROM ACM.
C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 17, NO. 2, PP. 178-206.  JUNE, 1991.
c
c  file containg example programs and PDECHEB software.
c
c  This file contains
c       example problem 1
c       example problem 2
c       example problem 3
c       example problem 4
c       example problem 5
c       dassl time integration routine
c       pdecheb spatial discretisation routine
c       interface to AND the linpack full and banded routines
c
c
C     C0 COLLOCATION PARAMETERS
        PARAMETER ( IBK   = 21, NEL  = IBK-1 , NPDE = 1, NV = 1,
     1              NPOLY =  2,  NPTS = NEL*NPOLY+1,     NXI = 1,
     2              NEQ   = NPTS * NPDE + NV,
     3              NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) +
     4                       NPDE * 8 + 3 + NV + NXI,
C     DDASSL TIME INTEGRATION PARAMETERS
     5              MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2,
     6              LIW = 20 + NEQ )
C
        INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID, IRESWK,
     1          IDEV, ITRACE
        DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ),
     1          WKRES(NWKRES), RWORK(LRW), XI(1), T, TOUT, RTOL, ATOL,
     2          ENORM, GERR, VERROR, CTIME, TOL
        EXTERNAL PDECHB, DGEJAC
        COMMON /SDEV2/ ITRACE, IDEV
        COMMON /PROB1/ TOL
        TOL  = 0.1D-5/50.D0
C N.B. CPU TIMER COMMENTED OUT FOR PORTABILITY
C       CALL TIMER( CTIME, 1)
        M    = 0
        T    = TOL
        IDEV = 4
        ITRACE = 1
        WRITE(IDEV,9)NPOLY, NEL
 9      FORMAT(' TEST PROBLEM 1'/' ***********'/' POLY OF DEGREE =',I4,
     1         ' NO OF ELEMENTS = ',I4)
        XI(1)  = 1.0D0
        DO 10 I = 1,IBK
 10       XBK(I) = (I-1.0D0)/(IBK-1.0D0)
C           INITIALISE THE P.D.E. WORKSPACE
        ITIME  = 1
        CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND,
     1              ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV)
        IF(ITIME .EQ. -1)THEN
           WRITE(IDEV, 15)
 15        FORMAT(' INITCC ROUTINE RETURNED ITIME = -1 - RUN HALTED ')
           GOTO 100
        END IF
C         SETUP DASSL PARAMETERS
       RTOL = TOL
       ATOL = TOL
       DO 20 I = 1,11
 20      INFO(I) = 0
C
C         BANDED MATRIX OPTION WHEN INFO(6) = 1
       IF(INFO(6) .EQ. 1)THEN
          IWORK(1) = IBAND
          IWORK(2) = IBAND
       END IF
 30    TOUT = T * 10.0D0
       IF(TOUT .GE. 2.D0)TOUT =2.0D0
       CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL,
     1              IDID, RWORK, LRW, IWORK, LIW, WKRES, IRESWK, DGEJAC)
       IF( IDID .LT. 0 )THEN
C          DASSL FAILED TO FINISH INTEGRATION.
           WRITE(IDEV,40)T,IDID
 40        FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3)
           GOTO 100
       ELSE
C        DASSL INTEGRATED TO T = TOUT
C        CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION.
         ITRACE = 1
         CALL ERROR( Y, NPDE, NPTS, X, M, ENORM, GERR, T, RTOL, ATOL,
     1               ITRACE, WKRES, NWKRES)
         ITRACE = 0
         VERROR  = Y(NEQ) - T
         WRITE(IDEV,50)Y(NEQ),VERROR
 50      FORMAT(' MOVING BOUNDARY IS AT ',D12.4,' WITH ERROR=',D12.4)
         IF(TOUT .LT. 1.99D0 ) GOTO 30
       END IF
100    CONTINUE
C      CALL TIMER(CTIME, 2)
       WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13), CTIME
110    FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4,' CPU=',D11.3)
       STOP
       END
C**********************************************************************
C EXAMPLE  PROBLEM 1
C SOLUTION OF MOVING BOUNDARY  PROBLEM BY CO-ORDINATE TRANSFORMATION.
C********************************************************************
C  THIS PROBLEM IS THE ONE PHASE STEFAN PROBLEM (HOFFMAN (1977) ) SEE
C  FURZELAND R.M. A COMPARATIVE STUDY OF NUMERICAL METHODS FOR MOVING
C  BOUNDARY PROBLEMS. J.I.M.A. (1977) ,26, PP 411 - 429.
C  THE PROBLEM HAS  MELTING DUE TO HEAT INPUT AT THE FIXED
C  BOUNDARY . THE P.D.E. IS DEFINED BY THE EQUATIONS
C         U  =  U        0 < Y < S(T) , 0.1 < T < 1
C          T     YY
C            U  = - EXP(T) , Y = 0
C             Y            .
C            U  =  0  AND  S(T) = - U   ON THE MOVING BOUNDARY Y = S(T).
C                                    Y
C  AND THE INITIAL SOLUTION VALUES AT T = 0.1 ARE GIVEN BY THE ANALYTIC
C  SOLUTION
C            U = EXP(T-Y) - 1 , S(T) = T.
C  THE PROBLEM IS REWRITTEN BY USING THE CO-ORDINATE TRANSFORMATION
C  GIVEN BY  X(T)  =  Y / S(T)  . THE EQUATIONS THEN READ
C                      .
C     S * S * U  - S * S  * X * U   =  U     , X IN (0,1).
C              T                 X      XX
C  WITH THE NEUMANN TYPE BOUNDARY CONDITIONS
C                                               .
C     U  = - EXP(T)  AT X=0  AND  U  = - S(T) * S(T) AT X = 1
C      X                           X
C  AND THE O.D.E. COUPLING POINT EQUATION AT X = 1 WHICH IMPLICITLY
C  DEFINES S(T) IS GIVEN  BY
C     U(1,T) = 0
C  THE EXACT SOLUTION IS NOW DEFINED BY
C     U(X,T) = EXP((T - X*S(T))  , S(T) = T
C
C WE SHALL NOW DETAIL THE ROUTINES NEEDED TO DESCRIBE THIS PROBLEM.
C        PROBLEM DESCRIPTION ROUTINES
C       ******************************
C EXACT SOLUTION
       SUBROUTINE EXACT( TIME, NPDE, NPTS, X, U)
C      ROUTINE FOR P.D.E. EXACT VALUES  (IF KNOWN)
       INTEGER NPDE, NPTS
       DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME
       DO 10 I = 1,NPTS
 10       U(1,I) = DEXP( TIME * (1 - X(I))) - 1.0D0
       RETURN
       END
       SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV, V)
C      ROUTINE FOR O.D.E. AND P.D.E. INITIAL VALUES.
       INTEGER NPDE, NPTS, NV
       DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME, V(NV)
       COMMON /PROB1/ TOL
       TIME= TOL
       V(1)= TOL
       CALL EXACT(TIME,NPDE,NPTS,X,U)
       RETURN
       END
C
       SUBROUTINE SPDEFN(T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R,
     1                   NV, V, VDOT, IRES)
C      PROBLEM INTERFACE  FOR THE MOVING BOUNDARY PROBLEM.
       INTEGER NPTL, NPDE, NV, I, IRES
       DOUBLE PRECISION X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL), T,
     1         V(1), VDOT(1), Q(NPDE,NPTL) ,R(NPDE,NPTL),
     2         UDOT(NPDE,NPTL), UTDX(NPDE,NPTL)
       DO 10 I = 1,NPTL
          R(1,I) = DUDX(1,I)
          Q(1,I) = V(1)*V(1)*UDOT(1,I) -X(I)*VDOT(1)*DUDX(1,I) * V(1)
 10    CONTINUE
       RETURN
       END
       SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE,
     1                   LEFT, NV, V, VDOT, IRES)
C  THIS SUBROUTINE PROVIDES THE LEFT AND RIGHT BOUNDARY VALUES
C  FOR THE MOVING BOUNDARY PROBLEM IN THE FORM.
C           BETA(I) * DU/DX(I) = GAMMA(I)
C  WHERE I = 1,NPDE AND GAMMA IS A FUNCTION OF U,X AND T
C
       INTEGER NPDE, NV, IRES
       LOGICAL LEFT
       DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE)
     -                  ,T, V(1), VDOT(1), UDOT(NPDE), UTDX(NPDE)
       BETA(1) = 1.0D0
       IF(LEFT)THEN
          GAMMA(1) = -V(1)*DEXP(T)
       ELSE
          GAMMA(1) = -V(1)*VDOT(1)
       END IF
       RETURN
       END
C
       SUBROUTINE SODEFN(T, NV, V, VDOT, NPDE, NXI, XI, UI, UXI, RI,
     1                    UTI, UTXI, VRES, IRES)
C      ROUTINE TO PROVIDE RESIDUAL OF COUPLED ODE SYSTEM FOR THE
C      MOVING BOUNDARY PROBLEM.
C      NOTE HOW IRES CAN BE RESET TO COPE WIH ILLEGAL VALUES OF THE
C           MOVING BOUNDARY POSITION V(1).
       INTEGER NPDE, NXI, NV, IRES
       DOUBLE PRECISION T, XI(NXI), UI(NPDE,NXI), UXI(NPDE,NXI),
     1         RI(NPDE,NXI), UTI(NPDE,NXI), UTXI(NPDE,NXI), VRES(NV),
     2         V(NV), VDOT(NV)
       VRES(1) = UI(1,1)
       IF(V(1) .LT. 0.0D0)IRES = -1
       RETURN
       END
C     C0 COLLOCATION PARAMETERS
        PARAMETER ( IBK   =  2, NEL  = IBK-1 , NPDE = 1, NV = 0,
     1              NPOLY = 10, NPTS = NEL*NPOLY+1,     NXI = 0,
     2              NEQ   = NPTS * NPDE + NV,
C    C              NWKRES= 2*(NPOLY+1)*(NPOLY+NEL+2) + 2 + NV +
     3              NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) +
     4                       NPDE * 8 + 3 + NV + NXI,
C    C                       NPDE * (7 * (NPOLY+1+NXI) + 8),
C     DDASSL TIME INTEGRATION PARAMETERS
     5              MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2,
     6              LIW = 20 + NEQ )
C
        INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID, IRESWK,
     1          IDEV, ITRACE
        DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ),
     1          WKRES(NWKRES), RWORK(LRW), XI(1), T, TOUT, RTOL, ATOL,
     2          ENORM, GERR, CTIME
        EXTERNAL PDECHB, DGEJAC
        COMMON /SDEV2/ ITRACE, IDEV
C  CPU TIMER COMMENTED OUT FOR PORTABILITY
C       CALL TIMER(CTIME ,1)
        M    = 2
        T    = 0.0D0
        IDEV = 4
        ITRACE = 1
        WRITE(IDEV,9)NPOLY, NEL
 9      FORMAT(' TEST PROBLEM 1'/' ***********'/' POLY OF DEGREE =',I4,
     1         ' NO OF ELEMENTS = ',I4)
        DO 10 I = 1,IBK
 10       XBK(I) =          (I-1.0D0) / (IBK - 1.0D0)
C           INITIALISE THE P.D.E. WORKSPACE
        ITIME = 1
        CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND,
     1              ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV)
        IF(ITIME .EQ. -1)THEN
           WRITE(IDEV, 15)
 15        FORMAT(' INITCC ROUTINE RETURNED ITIME = -1 - RUN HALTED ')
           GOTO 100
        END IF
C         SETUP DASSL PARAMETERS
       RTOL = 1.0D-8
       ATOL = 1.0D-8
       DO 20 I = 1,11
 20      INFO(I) = 0
C      INFO(11)= 1
C         BANDED MATRIX OPTION WHEN INFO(6) = 1
       IF(INFO(6) .EQ. 1)THEN
          IWORK(1) = IBAND
          IWORK(2) = IBAND
       END IF
 30    TOUT = T + 0.1D0
       CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL,
     1              IDID, RWORK, LRW, IWORK, LIW, WKRES, IRESWK, DGEJAC)
       IF( IDID .LT. 0 )THEN
C          DASSL FAILED TO FINISH INTEGRATION.
           WRITE(IDEV,40)T,IDID
 40        FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3)
           GOTO 100
       ELSE
C        DASSL INTEGRATED TO T = TOUT
C        CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION.
         CALL ERROR( Y, NPDE, NPTS, X, M, ENORM, GERR, T, RTOL, ATOL,
     1               ITRACE, WKRES, NWKRES)
         IF(TOUT .LT. 0.99D0 ) GOTO 30
       END IF
100    CONTINUE
C      CALL TIMER(CTIME, 2)
       WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13), CTIME
110    FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4,' CPU=',D11.3)
       STOP
       END
C EXAMPLE PROBLEM TWO
C ********************
C     THIS PROBLEM IS DEFINED BY
C             -2    2               2
C     U U  = X   ( X  U U  )   + 5 U  + 4 X U U     ,  X IN (0,1)
C        T                X  X                 X
C
C     THE LEFT BOUNDARY CONDITION AT X = 0 (LEFT = .TRUE. ) IS GIVEN BY
C        U (0,T)  = 0.0
C         X
C     THE RIGHT BOUNDARY CONDITION IS  (LEFT = .FALSE.)
C         U( 1,T) = EXP ( -T )
C
C      THE INITIAL CONDITION IS GIVEN BY THE EXACT SOLUTION ;
C        U( X, T )  = EXP ( 1 - X*X - T )  , X IN ( 0,1)
C                            2
C**********************************************************************
       SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV,V)
C      ROUTINE FOR P.D.E. INITIAL VALUES.
       INTEGER NPDE, NPTS, NV
       DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), V(1), T
         T = 0.0D0
C        V(1) IS A DUMMY VARIABLE AS THERE ARE NO COUPLED O.D.E.S
         CALL EXACT( T, NPDE, NPTS, X, U )
       RETURN
       END
C
       SUBROUTINE SPDEFN( T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R,
     1                    NV, V, VDOT, IRES)
C      ROUTINE TO DESCRIBE THE BODY OF THE P.D.E.
C      THE P.D.E. IS WRITEN AS       -M   M
C         Q(X,T,U, U  , U  , U  ) = X   (X  R(X,T,U,U , U , U  ))
C                   X    T    TX                     X   T   TX  X
C      THE FUNCTIONS Q AND R MUST BE DEFINED IN THIS ROUTINE.
C      DEFINITIONS FOR THE MODEL PROBLEM ARE GIVEN
C      NOTE NV = 0 : THERE IS NO O.D.E PART.
       INTEGER NPDE, NPTL, I, J, NV, IRES
       DOUBLE PRECISION T, X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL),
     1         UDOT(NPDE,NPTL), Q(NPDE,NPTL), R(NPDE,NPTL), V, VDOT,
     2         UTDX(NPDE,NPTL)
       DO 10 I = 1,NPTL
          R(1,I) = U(1,I) * DUDX(1,I)
          Q(1,I) = U(1,I) * UDOT(1,I) - 5.0D0 * U(1,I)**2
     1                                - 4.0D0 * U(1,I)*DUDX(1,I)*X(I)
 10    CONTINUE
       RETURN
       END
C
       SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, LEFT,
     1                   NV, V, VDOT, IRES)
C      BOUNDARY CONDITIONS ROUTINE
       INTEGER NPDE, NV, IRES
       DOUBLE PRECISION T, BETA(NPDE), GAMMA(NPDE), U(NPDE), C2,
     1                  UX(NPDE), V, VDOT, UDOT(NPDE), UTDX(NPDE)
       LOGICAL LEFT
       IF(LEFT) THEN
          BETA (1) = 1.0D0
          GAMMA(1) = 0.0D0
       ELSE
C         BETA (1) = 0.0D0
C         GAMMA(1) = U(1) - DEXP( -T )
          BETA (1) = 1.0D0
          GAMMA(1) = - 2.D0 *U(1)**2
       END IF
       RETURN
       END
C
C      DUMMY O.D.E. ROUTINE AS NV IS ZERO
       SUBROUTINE SODEFN
       RETURN
       END
C EXACT SOLUTION
       SUBROUTINE EXACT( TIME, NPDE, NPTS, X, U)
C      ROUTINE FOR P.D.E. EXACT VALUES  (IF KNOWN)
       INTEGER NPDE, NPTS, I
       DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME
       DO 10 I = 1,NPTS
 10       U(1,I) = DEXP( 1.0D0 - X(I)**2 - TIME)
       RETURN
       END
c  problem 3
C     C0 COLLOCATION PARAMETERS
        PARAMETER ( IBK   = 3, NEL  = IBK-1 , NPDE = 1, NV = 0,
     1              NPOLY = 6, NPTS = NEL*NPOLY+1,     NXI = 0,
     2              NEQ   = NPTS * NPDE + NV,
     3              NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) +
     4                       NPDE * 8 + 3 + NV + NXI,
C    3              NWKRES= 2*(NPOLY+1)*(NPOLY+NEL+2) + 2 + NV +
C    4                       NPDE * (7 * (NPOLY+1+NXI) + 8),
C     DDASSL TIME INTEGRATION PARAMETERS
     5              MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2,
     6              LIW = 20 + NEQ )
C
        INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID, IRESWK,
     1          IDEV, ITRACE, IDERIV, IFL, ITYPE
        DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ), Z(NPTS),
     1          WKRES(NWKRES), RWORK(LRW), XI(1), T, TOUT, RTOL, ATOL,
     2          ENORM, GERR, CTIME, DYDX(NEQ), DYCALC(NPDE,NPTS,2)
        EXTERNAL PDECHB, DGEJAC
        COMMON /SDEV2/ ITRACE, IDEV
        COMMON /PROB3/IDERIV
C CPU TIMER COMMENTED OUT FOR PORTABILITY.
C       CALL TIMER ( CTIME, 1)
        M    = 0
        T    = 0.0D0
        IDEV = 4
        ITRACE = 1
        WRITE(IDEV,9)NPOLY, NEL
 9      FORMAT(' TEST PROBLEM 3'/' ***********'/' POLY OF DEGREE =',I4,
     1         ' NO OF ELEMENTS = ',I4)
        DO 10 I = 1,IBK
 10       XBK(I) = -1.0D0 + 2.0D0 * (I-1.0D0)/(IBK -1.0D0)
C           INITIALISE THE P.D.E. WORKSPACE
        ITIME = 1
        CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND,
     1              ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV)
        IF(ITIME .EQ. -1)THEN
           WRITE(IDEV, 15)
 15        FORMAT(' INITCC ROUTINE RETURNED ITIME = -1 - RUN HALTED ')
           GOTO 100
        END IF
C         SETUP DASSL PARAMETERS
       RTOL = 1.0D-5
       ATOL = 1.0D-5
       DO 20 I = 1,11
 20      INFO(I) = 0
C      INFO(11)= 1
C         BANDED MATRIX OPTION WHEN INFO(6) = 1
       IF(INFO(6) .EQ. 1)THEN
          IWORK(1) = IBAND
          IWORK(2) = IBAND
       END IF
       T = 0.0D0
 30    TOUT = T + 0.1D0
       CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL,
     1              IDID, RWORK, LRW, IWORK, LIW, WKRES, IRESWK, DGEJAC)
       IF( IDID .LT. 0 )THEN
C          DASSL FAILED TO FINISH INTEGRATION.
           WRITE(IDEV,40)T,IDID
 40        FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3)
           GOTO 100
       ELSE
C        DASSL INTEGRATED TO T = TOUT
C        CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION.
         IDERIV = 0
         CALL ERROR( Y, NPDE, NPTS, X, M, ENORM, GERR, T, RTOL, ATOL,
     1               ITRACE, WKRES, NWKRES)
         IFL   = 0
         ITYPE = 2
         DO 45 I = 1,NPTS
45         Z(I) = X(I)
         CALL INTERC(Z,DYCALC,NPTS,Y,NEQ,NPDE,IFL,ITYPE,WKRES,NWKRES)
         IDERIV = 1
         CALL EXACT(T, NPDE, NPTS, X, DYDX)
         DO 50 I = 1,NPTS
          GERRDX = ABS( DYDX(I) - DYCALC(1,I,2))
          WRITE(IDEV,49)X(I),DYDX(I),DYCALC(1,I,2),GERRDX
 49       FORMAT(' X =',D11.3,' TRUE = ',D11.3,' CALC= ',D11.3,' ERR=',
     1           D11.3)
 50      CONTINUE
         IF(TOUT .LT. 0.99D0 ) GOTO 30
       END IF
100    CONTINUE
C      CALL TIMER(CTIME, 2)
       WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13), CTIME
110    FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4,' CPU=',D11.3)
       STOP
       END
C EXAMPLE PROBLEM THREE
C *********************
C     THIS PROBLEM IS DEFINED BY
C               -1
C       U  = ( C   U  )  - C * EXP(-2U) + EXP(-U)  ,  X IN (-1,0)
C        T      1   X  X    1
C  AND
C               -1
C       U  = ( C   U  )  - C * EXP(-2U) + EXP(-U)  ,  X IN (0,1)
C        T      2   X  X    2
C  WHERE
C       C  = 0.1     AND    C   = 1.0
C        1                   2
C
C     THE LEFT BOUNDARY CONDITION AT X =-1 (LEFT = .TRUE. ) IS GIVEN BY
C         U(-1,T)  = LOG ( - C  + T + P)
C                       1
C     THE RIGHT BOUNDARY CONDITION IS  (LEFT = .FALSE.)
C         U( 1,T) + (C + T + P ) U  = LOG ( - C  + T + P) + 1.0D0
C                                 X
C
C      THE INITIAL CONDITION IS GIVEN BY THE EXACT SOLUTION ;
C        U( X, T )  = LOG ( C X + T + P )  , X IN ( -1, 0)
C                            1
C        U( X, T )  = LOG ( C X + T + P )  , X IN (  0, 1)
C                            2
C**********************************************************************
       SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV,V)
C      ROUTINE FOR P.D.E. INITIAL VALUES.
       INTEGER NPDE, NPTS, NV
       DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), V(1), T
         T = 0.0D0
C        V(1) IS A DUMMY VARIABLE AS THERE ARE NO COUPLED O.D.E.S
         CALL EXACT( T, NPDE, NPTS, X, U )
       RETURN
       END
C
       SUBROUTINE SPDEFN( T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R,
     1                    NV, V, VDOT, IRES)
C      ROUTINE TO DESCRIBE THE BODY OF THE P.D.E.
C      THE P.D.E. IS WRITEN AS       -M   M
C         Q(X,T,U, U  , U  , U  ) = X   (X  R(X,T,U,U , U , U  ))
C                   X    T    TX                     X   T   TX  X
C      THE FUNCTIONS Q AND R MUST BE DEFINED IN THIS ROUTINE.
C      DEFINITIONS FOR THE MODEL PROBLEM ARE GIVEN
C      NOTE NV = 0 : THERE IS NO O.D.E PART.
       INTEGER NPDE, NPTL, I, J, NV, IRES
       DOUBLE PRECISION T, X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL),
     1         UDOT(NPDE,NPTL), Q(NPDE,NPTL), R(NPDE,NPTL), V, VDOT,
     2         UTDX(NPDE,NPTL), C
       IF(X(1) .LT. 0.0D0 .AND. X(NPTL) .LE. 0.0D0)THEN
C        ELEMENT TO LEFT OF THE INTERFACE AT 0.0
         C  =  0.1D0
       ELSE
         C =   1.0D0
       END IF
       DO 10 I = 1,NPTL
          R(1,I) = DUDX(1,I) /C
          Q(1,I) = UDOT(1,I) - DEXP(-U(1,I))- DEXP(-2.0D0*U(1,I))* C
 10    CONTINUE
       RETURN
       END
C
       SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, LEFT,
     1                   NV, V, VDOT, IRES)
C      BOUNDARY CONDITIONS ROUTINE
       INTEGER NPDE, NV, IRES
       DOUBLE PRECISION T, BETA(NPDE), GAMMA(NPDE), U(NPDE), C2,
     1                  UX(NPDE), V, VDOT, UDOT(NPDE), UTDX(NPDE)
       LOGICAL LEFT
       IF(LEFT) THEN
          BETA (1) = 0.0D0
          GAMMA(1) = U(1) - DLOG( -0.1 + T + 1.0D0)
       ELSE
          C2 = 1.0D0
          BETA (1) = C2 * ( C2 + T + 1.0D0)
          GAMMA(1) = U(1) - DLOG( C2 + T + 1.0D0) + 1.0D0
       END IF
       RETURN
       END
C
C      DUMMY O.D.E. ROUTINE AS NV IS ZERO
       SUBROUTINE SODEFN
       RETURN
       END
C EXACT SOLUTION
       SUBROUTINE EXACT( TIME, NPDE, NPTS, X, U)
C      ROUTINE FOR P.D.E. EXACT VALUES  (IF KNOWN)
       INTEGER NPDE, NPTS, I, IDERIV
       DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME, C
       COMMON /PROB3/ IDERIV
       IF(IDERIV .EQ. 0)THEN
          DO 10 I = 1,NPTS
             C = 1.0D0
             IF(X(I) .LT. 0.0D0)C = 0.1D0
 10          U(1,I) = DLOG( TIME + 1.0D0 + C * X(I))
       ELSE
          DO 20 I = 1,NPTS
             C = 1.0D0
             IF(X(I) .LT. 0.0D0)C = 0.1D0
             U(1,I) = C / ( TIME + 1.0D0 + C * X(I))
             IF(X(I) .EQ. 0.0D0) U(1,I) = 0.55D0 / ( TIME + 1.0D0 )
 20       CONTINUE
       END IF
       RETURN
       END
c  problem 4
C     ***********************************************************
C     BP PROBLEM - VAPOUR EVAPORATION OVER POOL
C     REGION OF INTEGRATION CONSISTS OF 2 AREAS A VISCOUS SUB-LAYER AND
C     A TURBULENT REGION, (THE DIVISION OCCURS AT X=0.508D-03).
C     THE PDE IS DIFFERENT IN EACH REGION.
C     ***********************************************************
C     C0 COLLOCATION PARAMETERS
        PARAMETER ( IBK   = 8, NEL  = IBK-1 , NPDE = 1, NV = 3,
     1              NPOLY = 03, NPTS = NEL*NPOLY+1,     NXI = NPTS,
     2              NEQ   = NPTS * NPDE + NV,
     3              NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) +
     4                       NPDE * 8 + 3 + NV + NXI,
C     DDASSL TIME INTEGRATION PARAMETERS
     5              MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2,
     6              LIW = 20 + NEQ )
C
        INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID,
     1          IDEV, ITRACE, GRNPTS, IFL, NOUT, KTIME, ITYPE
        DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ), TINC(11),
     1          WKRES(NWKRES), RWORK(LRW), XI(NXI), T, TOUT, RTOL, ATOL,
     2          U0,VM,DTX1,DTX2,DM1,DM2,K,SCM,PE,MW,RHO,RT,Q3
     3         ,TEND,W Q1,Q2,TEMP, XOUT(100), UOUT(100,1), CPU, XBAR
        REAL  GRX(800), GRY(800), GRZ(800)
        EXTERNAL PDECHB, DGEJAC
C
C       COMMON BLOCKS  TO PASS ACROSS PROBLEM DEPENDENT CONSTANTS.
        COMMON /C0/     PE,MW,RHO,RT,W
        COMMON /PDES/   U0,VM,DTX1,DTX2,DM1,DM2,K
        COMMON /SDEV2/ ITRACE, IDEV
C IBM CALL TO SWITCH OFF UNDERFLOW COMMENTED OUT
C       CALL ERRSET(208, 256, -1, -1, 0)
C CPU TIMER COMMENTED OUT FOR  PORTABILITY
C       CALL TIMER (CPU, 1)
        PE = 0.39005D+4
        MW = 0.92142D+2
        RHO = 0.3767D+1
        RT = 0.8317D+4*0.29815D+3
        U0 = 0.3164D+0
        VM = 0.147D-04
        DTX1 = 0.0D+0
        SCM = 1.7D+0
        DM1 = VM/SCM
        K = 0.41D+0
        DM2 = 0.0D+0
        DTX2 = U0*K
        W = 0.25D0
        GRNPTS = 1
        WRITE(IDEV,9)NPOLY, NEL
 9      FORMAT(' TEST PROBLEM 4'/' ***********'/' POLY OF DEGREE =',I4,
     1         ' NO OF ELEMENTS = ',I4)
         RTOL = 0.1D-4
         ATOL = 0.1D-4
         ITRACE = 0
         IDEV = 4
         WRITE(IDEV,104)RTOL, ATOL, ITRACE, IDEV
104      FORMAT(//' RTOL=',D12.3,' ATOL=',D12.3,' ITRACE AND IDEV=',2I4)
C
         WRITE(4,55)ATOL, RTOL, NPTS
55       FORMAT(//' SOLUTION TO B.P. POOL EVAPORATION PROBLEM USING
     1   DASSL INTEGRATOR WITH FULL MATRIX ROUTINES '/
     2   '   ATOL = ',D11.3,'  RTOL = ',D11.3,'  NPTS = ',I5/)
         NOUT = 20
         XOUT(1) = 0.0D0
         XOUT(2) = 0.127D-3
         XOUT(3) = 0.254D-3
         XOUT(4) = 0.381D-3
         XOUT(5) = 0.508D-3
         XOUT(6) = 0.635D-3
         XOUT(7) = 0.762D-3
         XOUT(8) = 0.889D-3
         XOUT(9) = 0.1D-2
         XOUT(10)= 0.3D-2
         XOUT(11)= 0.5D-2
         XOUT(12)= 0.75D-2
         XOUT(13)= 0.1D-1
         XOUT(14)= 0.3D-1
         XOUT(15)= 0.5D-1
         XOUT(16)= 0.75D-1
         XOUT(17)= 0.1D0
         XOUT(18)= 0.15D0
         XOUT(19)= 0.2D0
         XOUT(20)= 0.22D0
         XBAR = XOUT(5)
         DO 1000 I = 1,NOUT
            TEMP = DLOG10( 1.0D0 + XOUT(I)/XBAR *2.0D0)
            WRITE(IDEV,999)I,XOUT(I),TEMP
999         FORMAT('   I=',I3,' XOUT=',D13.5,'    LOG10=',D13.5)
1000     CONTINUE
C
C      TEMPORARY VALUES OF XI FOR FIRST CALL TO INICHB
         DO 291 I = 1,NPTS
 291       XI(I) =(I-1.0D0) /(NPTS-1.0D0)
C
          XBK(1) = 0.0D0
          XBK(2) = XBAR* 0.5D0
          XBK(3) = XBAR
          XBK(4) = XBAR * 1.5D0
          XBK(5) = XBAR * 2.0D0
          XBK(6) = XBAR*11.0
          XBK(7) = XBAR * 121
          XBK(8) = 1.0D0
          ITIME = 1
C           INITIALISE THE P.D.E. WORKSPACE
        CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND,
     1              ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV)
        DO 292 I = 1,NPTS
C            FINAL VALUES OF XI
 292       XI(I) = X(I)
        CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND,
     1              ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV)
        IF(ITIME .EQ. -1)THEN
           WRITE(IDEV, 15)
 15        FORMAT(' INITCC ROUTINE RETURNED ITIME = -1 - RUN HALTED ')
           GOTO 900
         ELSE
           WRITE(IDEV,16)(Y(I), I = 1,NPTS)
  16       FORMAT(' INITIAL VALUES ARE =',5D11.3)
        END IF
C         SETUP DASSL PARAMETERS
       DO 20 I = 1,11
 20      INFO(I) = 0
C      INFO(11)= 1
C         BANDED MATRIX OPTION WHEN INFO(6) = 1
       IF(INFO(6) .EQ. 1)THEN
          IWORK(1) = IBAND
          IWORK(2) = IBAND
       END IF
      T    = 0.0D0
      TINC(1) = 0.0001D0
      TINC(2) = 0.0010
      TINC(3) = 0.01D0
      TINC(4) = 0.050D0
      TINC(5) = 0.1D0
      TINC(6) = 0.15D0
      TINC(7) = 0.25D0
      TINC(8) = 0.50D0
      TINC(9) = 0.65D0
      TINC(10)= 0.80D0
      TINC(11)= 1.00D0
      TEND = 1.0D0
      KTIME = 1
      ITYPE = 1
      CALL INTERC(XOUT,UOUT,NOUT,Y,NEQ,NPDE,IFL,ITYPE,WKRES,NWKRES)
      WRITE (IDEV,82) T, (UOUT(I,1),I=1,NOUT,3)
      GRNPTS = 0
      DO 800 I = 1,NOUT
         GRNPTS = GRNPTS + 1
         GRX(GRNPTS) = T
         GRZ(GRNPTS) = UOUT(I,1)/UOUT(1,1)
         GRY(GRNPTS) = DLOG10( 1.D0+XOUT(I)/XBAR * 2.0D0)
         IF(ITRACE .GE.0)WRITE(IDEV,899)GRY(GRNPTS),GRZ(GRNPTS)
 800  CONTINUE
      WRITE(IDEV,81)(XOUT(I), I = 1,NOUT,2)
 81   FORMAT (/'  T/X', 4X,9D11.3)
C TIME LOOP:
100   TOUT = TINC(KTIME)
       CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL,
     1              IDID, RWORK, LRW, IWORK, LIW, WKRES, NWKRES, DGEJAC)
C          DASSL FAILED TO FINISH INTEGRATION.
       WRITE(IDEV,40)T,IDID
 40    FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3)
       IF( IDID .LT. 0 )GOTO 900
C        DASSL INTEGRATED TO T = TOUT
C        CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION.
       CALL INTERC(XOUT,UOUT,NOUT,Y,NEQ,NPDE,IFL,ITYPE,WKRES,NWKRES)
 82    FORMAT(1X,F3.1,' U   ',9D11.3/)
       WRITE (IDEV,82) TOUT, (UOUT(I,1),I=1,NOUT,3)
       WRITE (6,82) TOUT, (UOUT(I,1),I=1,NOUT,3)
C
C COMPARE RATE OF EVAPORATION Q1 AT SURFACE OF POOL WITH QUANTITY OF
C VAPOUR Q2 WHICH PASSES ABOVE END OF POOL
       Q1 = Y(NEQ-2)
       Q2 = Y(NEQ-1)
       Q3 = Y(NEQ)
       WRITE(IDEV,83) Q1,Q2,Q3
 83    FORMAT(' Q1 , Q2 AND Q3 ARE ',3D13.5)
C
C        PUT INTERPOLATED RESULTS IN ARRAY.
C
      I =(KTIME/2) * 2
      IF (I .EQ. KTIME)GOTO 91
      DO 90 I = 1,NOUT
         GRNPTS = GRNPTS + 1
         GRX(GRNPTS) = TOUT
         GRZ(GRNPTS) = UOUT(I,1)/UOUT(1,1)
         GRY(GRNPTS) = DLOG10( 1.D0+XOUT(I)/XBAR * 2.0D0)
         IF(ITRACE .GE.0)WRITE(IDEV,899)GRY(GRNPTS),GRZ(GRNPTS)
 899     FORMAT(' X AND Y VALUES ARE ',2E12.4)
 90   CONTINUE
 91   KTIME = KTIME + 1
C
C     CHECK IF INTEGRATION WAS SUCCESSFUL AND WHETHER FURTHER TIME
C     STEPS NEEDED
      IF(TOUT.LT.TEND.AND.(IDID.EQ.2 .OR. IDID .EQ. 3)) GO TO 100
      WRITE(IDEV,2112)Q1,Q2,DABS(Q3)
 2112 FORMAT(' RATE OF EVAPORATION AT SURFACE OF POOL Q1 = ',D14.7,/
     -  ' QUANTITY OF VAPOUR ABOVE END OF POOL   Q2 = ',D14.7,/
     -  ' ABSOLUTE DIFFERENCE Q3 = ',D11.4,/
     -  '********************************************************',/)
80    CONTINUE
C     CALL TIMER(CPU,2)
900    WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13), CPU
110    FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4,' CPU=',D11.3)
       STOP
       END
C EXAMPLE PROBLEM FOUR
C *********************
C     THIS PROBLEM IS DEFINED BY
C
C            C X  U  = ( C   U  )            ,  X IN (0 , XBAR)
C             1    T      2   X  X
C  AND
C
C  (C  LOG(X) +C ) U = ( C   X U  )          ,  X IN (XBAR , 1)
C    3          4   T      5    X  X
C
C  WHERE                   -6
C   C = 6810.0  C = 8.65 10    C  =0.7717   C = 9.313  C = 0.1297
C    1           2              3            4          5
C
C     THE LEFT BOUNDARY CONDITION AT X =-1 (LEFT = .TRUE. ) IS GIVEN BY
C         U(0,T) = 0.038475
C
C     THE RIGHT BOUNDARY CONDITION IS  (LEFT = .FALSE.)
C         U (1,T) = 0
C          X
C
C      THE INITIAL CONDITION IS GIVEN BY
C         U(X,0)  = 0
C
C      THE ALGEBRAIC VARIABLES Q (T)  , Q (T)  AND Q (T)  ARE DEFINED BY
C                               1        2          3
C
C      .                  -7
C      Q     =   -7.983 10    U (0 , T)
C       1                      X
C
C                         -2   1
C      Q     =   9.4175 10    I  P(X) U(X,T) DX
C       2                    0
C
C            WHERE     P(X) = C  X               FOR  X IN (0, XBAR)
C                              1
C
C                      P(X) = C  LOG(X) + C      FOR X IN (XBAR, 1)
C                              3           4
C            AND THE VALUES OF THE CONSTANTS ARE GIVEN ABOVE.
C
C       Q (T)    =   Q (T)  - Q (T)
C        3            2        1
C
C**********************************************************************
       SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV,V)
C      ROUTINE FOR P.D.E. INITIAL VALUES.
       INTEGER NPDE, NPTS, NV, I
       DOUBLE PRECISION X(NPTS), U(NPDE,NPTS),PE,MW,RHO,RT,W,V(3)
       COMMON/C0/PE,MW,RHO,RT,W
       DO 10 I= 2,NPTS
 10       U(1,I) = 0.0D+0
       U(1,1) = (PE*MW)/(RHO*RT)
       V(1) = 0.0D0
       V(2) = 0.0D0
       V(3) = 0.0D0
       RETURN
       END
C
       SUBROUTINE SPDEFN( T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R,
     1                    NV, V, VDOT, IRES)
C**********************************************************************
C      ROUTINE TO DESCRIBE THE BODY OF THE P.D.E.
C      THE P.D.E. IS WRITEN AS       -M   M
C         Q(X,T,U, U  , U  , U  ) = X   (X  R(X,T,U,U , U , U  ))
C                   X    T    TX                     X   T   TX  X
C      THE FUNCTIONS Q AND R MUST BE DEFINED IN THIS ROUTINE.
C**********************************************************************
       INTEGER NPDE, NPTL, I, NV, IRES
       DOUBLE PRECISION T, X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL),
     1    DM2, UDOT(NPDE,NPTL), Q(NPDE,NPTL), R(NPDE,NPTL), V(3),
     2    K, UTDX(NPDE,NPTL), U0, VM, DTX1, DTX2, DM1, VDOT(3)
      COMMON /PDES/  U0,VM,DTX1,DTX2,DM1,DM2,K
      DO 100 I = 1,NPTL
        IF(X(1) .LT. 0.506D-3 .AND. X(NPTL) .LT. 0.600D-3)THEN
C         ELEMENT TO LEFT OF THE INTERFACE AT 0.508D-3
          Q(1,I) = (X(I)*U0**2)/VM * UDOT(1,I)
          R(1,I) = (DTX1 + DM1)*DUDX(1,I)
        ELSE
          Q(1,I) = ((U0/K)*DLOG(U0*X(I)/VM) + 5.1*U0) * UDOT(1,I)
          R(1,I) = ((DTX2*X(I)) + DM2)*DUDX(1,I)
        ENDIF
 100  CONTINUE
      RETURN
      END
C
       SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, LEFT,
     1                   NV, V, VDOT, IRES)
C      BOUNDARY CONDITIONS ROUTINE
       INTEGER NPDE, NV, IRES
       DOUBLE PRECISION T, BETA(NPDE), GAMMA(NPDE), U(NPDE), PE,MW,RHO,
     1         UX(NPDE), V(3), VDOT(3), UDOT(NPDE), UTDX(NPDE), RT, W
      LOGICAL LEFT
      COMMON/C0/PE,MW,RHO,RT,W
      IF(LEFT) THEN
          GAMMA(1) = U(1)- (PE*MW)/(RHO*RT)
          BETA(1) = 0.0D+0
      ELSE
          GAMMA(1) = 0.0D0
          BETA(1) = 1.0D0
      END IF
      RETURN
      END
      SUBROUTINE SODEFN(T, NV, V, VDOT, NPDE, NXI, X, Y, UXI, RI,
     1                  UTI, UTXI, VRES, IRES)
C ROUTINE FOR AUXILIARY O.D.E.S (IF ANY) IN MASTER EQN. FORM (4.3)
      INTEGER NPDE, NXI, NV, IRES, NPTL, L, J, I
      DOUBLE PRECISION T, X(NXI), Y(NXI), UXI(NPDE,NXI),
     1        RI(NPDE,NXI), UTI(NPDE,NXI), UTXI(NPDE,NXI), VRES(NV),
     2        V(3), VDOT(3), PE,MW,RHO,RT,W,U0,VM,DTX1,DTX2,DM2,K
     3       ,DM1, Q2, H, CCRULE
      COMMON  /C0/     PE,MW,RHO,RT,W
      COMMON  /PDES/   U0,VM,DTX1,DTX2,DM1,DM2,K
      COMMON  /SCHSZ5/ NPTL
      COMMON  /SCHSZ6/ CCRULE(50)
C
      VRES(1) = VDOT(1) + W*RHO*DM1*UXI(1,1)
      Q2 = 0.0D0
      DO 3 I = 1,2
        J = (NPTL-1) * (I-1) + 1
        L = (NPTL-1) *  I    + 1
        H = ( X(L) - X(J)) * 0.5D0
      DO 3 II = 1,NPTL
         IK = J + II - 1
C        CLENSHAW - CURTIS QUADRATURE UP TO INTERFACE POINT.
         Q2 = Q2 + (W*RHO*U0**2)/VM * X(IK) * Y(IK) * CCRULE(II) * H
 3    CONTINUE
C
C        CLENSHAW - CURTIS QUADRATURE BEYOND THE INTERFACE POINT.
      DO 5 I = 3,7
        J = (NPTL-1) * (I-1) + 1
        L = (NPTL-1) *  I    + 1
        H = ( X(L) - X(J)) * 0.5D0
        DO 5 II = 1, NPTL
         IK = J + II - 1
         Q2=Q2 + H* ((U0/K)*DLOG(U0*X(IK)/VM)+5.1*U0) * Y(IK)*CCRULE(II)
     1            * W * RHO
  5   CONTINUE
      VRES(2) = V(2) - Q2
      VRES(3) = V(3) - (V(2)-V(1))
      RETURN
      END
c  problem 5
C     ***********************************************************
C     FOURTH ORDER P.D.E. PROBLEM WRITTEN AS ELLIPTIC-PARABOLIC SYSTEM.
C
C     U     =  K U     + UU    - U U
C      XXT        XXXX     XXX    X XX
C
C     ***********************************************************
C
C     C0 COLLOCATION PARAMETERS
        PARAMETER ( IBK   = 21, NEL  = IBK-1 , NPDE = 2, NV = 0,
     1              NPOLY = 02, NPTS = NEL*NPOLY+1,     NXI = 0,
     2              NEQ   = NPTS * NPDE + NV,
     3              NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) +
     4                       NPDE * 8 + 3 + NV + NXI,
C     DDASSL TIME INTEGRATION PARAMETERS
     5              MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2,
     6              LIW = 20 + NEQ )
C
        INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID,
     1          IDEV, ITRACE, GRNPTS, IFL, NOUT, KTIME, ITYPE, NP
        DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ), TINC(15),
     1          WKRES(NWKRES), RWORK(LRW), XI, T, TOUT, RTOL, ATOL,
     3          TEND, K, XOUT(6), UOUT(2,6)
        EXTERNAL PDECHB, DGEJAC
C
C       COMMON BLOCKS  TO PASS ACROSS PROBLEM DEPENDENT CONSTANTS.
        COMMON /PDES/   K
        COMMON /SDEV2/ ITRACE, IDEV
        DATA XOUT(1)/-1.0D+0/, XOUT(2)/-0.6D+0/, XOUT(3)/-0.2D+0/,
     *  XOUT(4)/0.2D+0/, XOUT(5)/0.6D+0/, XOUT(6)/1.0D+0/
        WRITE(IDEV,9)NPOLY, NEL
 9      FORMAT(' TEST PROBLEM 4'/' ***********'/' POLY OF DEGREE =',I4,
     1         ' NO OF ELEMENTS = ',I4)
         RTOL = 0.1D-4
         ATOL = 0.1D-4
         ITRACE = 0
         IDEV = 4
         WRITE(IDEV,104)RTOL, ATOL, ITRACE, IDEV
104      FORMAT(//' RTOL=',D12.3,' ATOL=',D12.3,' ITRACE AND IDEV=',2I4)
C
         WRITE(4,55)ATOL, RTOL, NPTS
55       FORMAT(//' SOLUTION TO FOURTH ORDER P.D.E. PROBLEM USING
     1   DASSL INTEGRATOR WITH BANDED MATRIX ROUTINES '/
     2   '   ATOL = ',D11.3,'  RTOL = ',D11.3,'  NPTS = ',I5/)
C
C    EQUALLY SPACED BREAKPOINTS.
C
         DO 105 I = 1,IBK
          XBK(I) = -1.0D0 + (I -1.0D0)* 2.D0 / (IBK-1.D0)
 105     CONTINUE
          K      =  1.00D0
          ITIME = 1
          T     = 0.0D0
C           INITIALISE THE P.D.E. WORKSPACE
        CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND,
     1              ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV)
        IF(ITIME .EQ. -1)THEN
           WRITE(IDEV, 15)
 15        FORMAT(' INICHB ROUTINE RETURNED ITIME = -1 - RUN HALTED ')
           GOTO 900
        END IF
C         SETUP DASSL PARAMETERS
       DO 20 I = 1,11
 20      INFO(I) = 0
       INFO(6)= 1
       INFO(9)= 1
       INFO(7)= 1
       IWORK(3)= 4
C         BANDED MATRIX OPTION WHEN INFO(6) = 1
       IF(INFO(6) .EQ. 1)THEN
          IWORK(1) = IBAND
          IWORK(2) = IBAND
       END IF
      T    = 0.0D0
      TINC(1) = 0.0001D0
      RWORK(2)= TINC(1) * 0.1D0
      TINC(2) = 0.0010
      TINC(3) = 0.01D0
      TINC(4) = 0.1D0
      TINC(5) = 1.0D0
      TINC(6) = 1.00D1
      TINC(7) = 2.00D1
      TINC(8) = 4.00D1
      TINC(9 )= 6.00D1
      TINC(10)= 8.00D1
      TINC(11)= 1.00D2
      TINC(12)= 1.00D3
      TEND = 1.0D3
      KTIME = 1
      WRITE(IDEV,83)(XOUT(I),I = 1,6)
C TIME LOOP:
100   TOUT = TINC(KTIME)
      IF(KTIME.GT.1)RWORK(2) = 0.05D0 *(TOUT- TINC(KTIME-1))
      IF(KTIME .EQ.12)THEN
         INFO(4) = 1
         RWORK(1) = TEND
       END IF
C
       CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL,
     1              IDID, RWORK, LRW, IWORK, LIW, WKRES, NWKRES, DGEJAC)
C          DASSL FAILED TO FINISH INTEGRATION.
       WRITE(IDEV,40)T,IDID,Y(1),Y(2),Y(NEQ-1), Y(NEQ)
 40    FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3/
     1        ' LEFT SOL=',2D11.3,' RIGHT SOL=',2D11.3)
       IF( IDID .LT. 0 )GOTO 900
C        DASSL INTEGRATED TO T = TOUT
C        CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION.
         ITYPE = 1
         NP    = 6
         CALL INTERC( XOUT, UOUT, NP, Y, NEQ, NPDE, IFLAG,
     1                      ITYPE, WKRES, NWKRES)
       WRITE(IDEV,82)(UOUT(1,I),I = 1,6)
       WRITE(IDEV,84)(UOUT(2,I),I = 1,6)
 83    FORMAT(1X,'X',9D11.3/)
 82    FORMAT(1X,'U',9D11.3/)
 84    FORMAT(1X,'V',9D11.3/)
C
 91   KTIME = KTIME + 1
C
C     CHECK IF INTEGRATION WAS SUCCESSFUL AND WHETHER FURTHER TIME
C     STEPS NEEDED
      IF(TOUT.LT.TEND.AND.(IDID.EQ.2 .OR. IDID .EQ. 3)) GO TO 100
80    CONTINUE
900    WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13)
110    FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4)
       STOP
       END
C EXAMPLE PROBLEM FIVE
C *********************
C     THIS PROBLEM IS DEFINED BY
C
C       V  =   U
C               XX
C  AND
C
C       V  = ( K   V  )  + U V  - U V              ,  X IN (-1 , 1)
C        T          X  X      X    X
C  WHERE
C       K  = 0.15
C
C     THE LEFT BOUNDARY CONDITION AT X =-1 (LEFT = .TRUE. ) ARE GIVEN BY
C
C       U = 1    U  = 0.0
C                 X
C     THE RIGHT BOUNDARY CONDITION ARE (LEFT = .FALSE.)
C
C       U = -1   U  = 0.0D0
C                 X
C      THE INITIAL CONDITION IS GIVEN BY
C
C         U(X,0) = -SIN ( PI /2  X )
C**********************************************************************
       SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV,V)
C      ROUTINE FOR P.D.E. INITIAL VALUES.
       PARAMETER (PIBY2 = 1.5707963D0)
       INTEGER NPDE, NPTS, NV, I
       DOUBLE PRECISION X(NPTS), U(NPDE,NPTS),V
       DO 10 I= 1,NPTS
          U(1,I) = -SIN( PIBY2 * X(I) )
 10       U(2,I) = - PIBY2**2 * U(1,I)
       RETURN
       END
C
       SUBROUTINE SPDEFN( T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R,
     1                    NV, V, VDOT, IRES)
C**********************************************************************
C      ROUTINE TO DESCRIBE THE BODY OF THE P.D.E.
C      THE P.D.E. IS WRITEN AS       -M   M
C         Q(X,T,U, U  , U  , U  ) = X   (X  R(X,T,U,U , U , U  ))
C                   X    T    TX                     X   T   TX  X
C      THE FUNCTIONS Q AND R MUST BE DEFINED IN THIS ROUTINE.
C**********************************************************************
       INTEGER NPDE, NPTL, I, NV, IRES
       DOUBLE PRECISION T, X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL),
     1    UDOT(NPDE,NPTL), Q(NPDE,NPTL), R(NPDE,NPTL), V,
     2    K, UTDX(NPDE,NPTL), VDOT
      COMMON /PDES/ K
      DO 100 I = 1,NPTL
          Q(1,I) = U(2,I)
          R(1,I) = DUDX(1,I)
          Q(2,I) = UDOT(2,I) - U(1,I)*DUDX(2,I) + DUDX(1,I)*U(2,I)
          R(2,I) = K*DUDX(2,I)
 100  CONTINUE
      RETURN
      END
C
       SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, LEFT,
     1                   NV, V, VDOT, IRES)
C      BOUNDARY CONDITIONS ROUTINE
       INTEGER NPDE, NV, IRES
       DOUBLE PRECISION T, BETA(NPDE), GAMMA(NPDE), U(NPDE),
     1         UX(NPDE), V, VDOT, UDOT(NPDE), UTDX(NPDE)
      LOGICAL LEFT
      IF(LEFT) THEN
          GAMMA(1) = 0.0D0
          BETA(1) = 1.0D+0
          GAMMA(2) = U(1) - 1.0D0
          BETA(2) = 0.0D+0
      ELSE
          GAMMA(1) = 0.0D0
          BETA(1) = 1.0D+0
          GAMMA(2) = U(1) + 1.0D0
          BETA(2) = 0.0D+0
      END IF
      RETURN
      END
      SUBROUTINE SODEFN(T, NV, V, VDOT, NPDE, NXI, X, Y, UXI, RI,
     1                  UTI, UTXI, VRES, IRES)
C ROUTINE FOR AUXILIARY O.D.E.S (IF ANY) IN MASTER EQN. FORM (4.3)
      INTEGER NPDE, NXI, NV, IRES, NPTL, L, J, I
      DOUBLE PRECISION T, X(NXI), Y(NXI), UXI(NPDE,NXI),
     1        RI(NPDE,NXI), UTI(NPDE,NXI), UTXI(NPDE,NXI), VRES(NV),
     2        V, VDOT
C                     DUMMY ROUTINE AS THERE ARE NO O.D.E.S
      RETURN
      END
c
c  main body of the software follows................
c
      SUBROUTINE DDASSL (RES,NEQ,T,Y,YPRIME,TOUT,
     *  INFO,RTOL,ATOL,IDID,
     *  RWORK,LRW,IWORK,LIW,RPAR,IPAR,
     *  JAC)
C
C***BEGIN PROLOGUE  DDASSL
C***DATE WRITTEN   830315   (YYMMDD)
C***REVISION DATE  830315   (YYMMDD)
C***CATEGORY NO.  D2A2
C***KEYWORDS  DIFFERENTIAL/ALGEBRAIC,BACKWARD DIFFERENTIATION FORMULAS
C             IMPLICIT DIFFERENTIAL SYSTEMS
C***AUTHOR  PETZOLD,LINDA R.
C             APPLIED MATHEMATICS DIVISION 8331
C             SANDIA NATIONAL LABORATORIES
C             LIVERMORE, CA.    94550
C***PURPOSE  DIFFERENTIAL/ALGEBRAIC SYSTEM SOLVER
C***DESCRIPTION
C  ---------------------------------------------------------------------
C
C  this code solves a system of differential/
C  algebraic equations of the form
C  g(t,y,yprime) = 0.
C
C  subroutine ddassl uses the backward
C  differentiation formulas of orders one
C  through five to solve a system of the above
C  form for y and yprime. values for y
C  and yprime at the initial time must
C  be given as input. these values must
C  be consistent, (that is. if t,y,yprime
C  are the given initial values, they must
C  satisfy g(t,y,yprime) = 0.)
C  the subroutine solves the system from t to tout. it is
C  easy to continue the solution to get results
C  at additional tout. this is the interval
C  mode of operation. intermediate results can
C  also be obtained easily by using the intermediate-
C  output capability.
C
C
C  ------------description of arguments to ddassl-----------------------
C  ------------(an overview)--------------------------------------------
C
C  the parameters are
C
C  res -- this is a subroutine which you provide
C         to define the differential/algebraic
C         system
C
C  neq -- this is the number of equations
C         to be solved
C
C  t -- this is the current value of the
C       independent variable.
C
C  tout -- this is a point at which a solution
C      is desired.
C
C  info(*) -- the basic task of the code is
C             to solve the system from t to
C             tout and return an answer at tout.
C             info(*) is an integer array which is
C             used to communicate exactly how you
C             want this task to be carried out.
C
C  y(*) -- this array contains the solution
C          components at t
C
C  yprime(*) -- this array contains the derivatives
C               of the solution components at t
C
C  rtol,atol -- these quantities represent
C               absolute and relative error
C               tolerances which you provide to indicate
C               how accurately you wish the solution
C               to be computed. you may choose them
C               to be both scalars or else both
C               vectors.
C
C  idid -- this scalar quantity is an indicator reporting
C          what the code did. you must monitor this
C          integer variable to decide what action to
C          take next.
C
C  rwork(*),lrw -- rwork(*) is a real work array of
C                  length lrw which provides the code
C                  with needed storage space.
C
C  iwork(*),liw -- iwork(*) is an integer work array
C                  of length liw which provides the code
C                  with needed storage space.
C
C  rpar,ipar -- these are real and integer parameter
C               arrays which you can use for
C               communication between your calling
C               program and the res subroutine
C               (and the jac subroutine)
C
C  jac -- this is the name of a subroutine which you
C         may choose to provide for defining
C         a matrix of partial derivatives
C         described below.
C
C  quantities which are used as input items are
C     neq,t,y(*),yprime(*),tout,info(*),
C     rtol,atol,rwork(1),rwork(2),rwork(3),lrw,iwork(1),
C     iwork(2),iwork(3),and liw.
C
C  quantities which may be altered by the code are
C     t,y(*),yprime(*),info(1),rtol,atol,
C     idid,rwork(*) and iwork(*)
C
C  ----------input-what to do on the first call to ddassl---------------
C
C
C  the first call of the code is defined to be the start of each new
C  problem. read through the descriptions of all the following items,
C  provide sufficient storage space for designated arrays, set
C  appropriate variables for the initialization of the problem, and
C  give information about how you want the problem to be solved.
C
C
C  res -- provide a subroutine of the form
C             subroutine res(t,y,yprime,delta,ires,rpar,ipar)
C         to define the system of differential/algebraic
C         equations which is to be solved. for the given values
C         of t,y and yprime, the subroutine should
C         return the residual of the differential/algebraic
C         system
C             delta = g(t,y,yprime)
C         (delta(*) is a vector of length neq which is
C         output for res.)
C
C         subroutine res must not alter t,y or yprime.
C         you must declare the name res in an external
C         statement in your program that calls ddassl.
C         you must dimension y,yprime and delta in res.
C
C         ires is an integer flag which is always equal to
C         zero on input.  subroutine res should alter ires
C         only if it encounters an illegal value of y or
C         a stop condition.  set ires = -1 if an input value
C         is illegal, and ddassl will try to solve the problem
C         without getting ires = -1.  if ires = -2, ddassl
C         will return control to the calling program
C         with idid = -11.
C
C         rpar and ipar are real and integer parameter arrays which
C         you can use for communication between your calling program
C         and subroutine res. they are not altered by ddassl. if you
C         do not need rpar or ipar, ignore these parameters by treat-
C         ing them as dummy arguments. if you do choose to use them,
C         dimension them in your calling program and in res as arrays
C         of appropriate length.
C
C  neq -- set it to the number of differential equations.
C         (neq .ge. 1)
C
C  t -- set it to the initial point of the integration.
C       t must be defined as a variable.
C
C  y(*) -- set this vector to the initial values of the neq solution
C          components at the initial point. you must dimension y of
C          length at least neq in your calling program.
C
C  yprime(*) -- set this vector to the initial values of
C               the neq first derivatives of the solution
C               components at the initial point. you
C               must dimension yprime at least neq
C               in your calling program.  if you do not
C               know initial values of some of the solution
C               components, see the explanation of info(11).
C
C  tout - set it to the first point at which a solution
C         is desired. you can not take tout = t.
C         integration either forward in t (tout .gt. t) or
C         backward in t (tout .lt. t) is permitted.
C
C         the code advances the solution from t to tout using
C         step sizes which are automatically selected so as to
C         achieve the desired accuracy. if you wish, the code will
C         return with the solution and its derivative at
C         intermediate steps (intermediate-output mode) so that
C         you can monitor them, but you still must provide tout in
C         accord with the basic aim of the code.
C
C         the first step taken by the code is a critical one
C         because it must reflect how fast the solution changes near
C         the initial point. the code automatically selects an
C         initial step size which is practically always suitable for
C         the problem. by using the fact that the code will not step
C         past tout in the first step, you could, if necessary,
C         restrict the length of the initial step size.
C
C         for some problems it may not be permissable to integrate
C         past a point tstop because a discontinuity occurs there
C         or the solution or its derivative is not defined beyond
C         tstop. when you have declared a tstop point (see info(4)
C         and rwork(1)), you have told the code not to integrate
C         past tstop. in this case any tout beyond tstop is invalid
C         input.
C
C  info(*) - use the info array to give the code more details about
C            how you want your problem solved. this array should be
C            dimensioned of length 15, though ddassl uses
C            only the first nine entries. you must respond to all of
C            the following items which are arranged as questions. the
C            simplest use of the code corresponds to answering all
C            questions as yes ,i.e. setting all entries of info to 0.
C
C       info(1) - this parameter enables the code to initialize
C              itself. you must set it to indicate the start of every
C              new problem.
C
C          **** is this the first call for this problem ...
C                yes - set info(1) = 0
C                 no - not applicable here.
C                      see below for continuation calls.  ****
C
C       info(2) - how much accuracy you want of your solution
C              is specified by the error tolerances rtol and atol.
C              the simplest use is to take them both to be scalars.
C              to obtain more flexibility, they can both be vectors.
C              the code must be told your choice.
C
C          **** are both error tolerances rtol, atol scalars ...
C                yes - set info(2) = 0
C                      and input scalars for both rtol and atol
C                 no - set info(2) = 1
C                      and input arrays for both rtol and atol ****
C
C       info(3) - the code integrates from t in the direction
C              of tout by steps. if you wish, it will return the
C              computed solution and derivative at the next
C              intermediate step (the intermediate-output mode) or
C              tout, whichever comes first. this is a good way to
C              proceed if you want to see the behavior of the solution.
C              if you must have solutions at a great many specific
C              tout points, this code will compute them efficiently.
C
C          **** do you want the solution only at
C                tout (and not at the next intermediate step) ...
C                 yes - set info(3) = 0
C                  no - set info(3) = 1 ****
C
C       info(4) - to handle solutions at a great many specific
C              values tout efficiently, this code may integrate past
C              tout and interpolate to obtain the result at tout.
C              sometimes it is not possible to integrate beyond some
C              point tstop because the equation changes there or it is
C              not defined past tstop. then you must tell the code
C              not to go past.
C
C           **** can the integration be carried out without any
C                restrictions on the independent variable t ...
C                 yes - set info(4)=0
C                  no - set info(4)=1
C                       and define the stopping point tstop by
C                       setting rwork(1)=tstop ****
C
C       info(5) - to solve differential/algebraic problems it is
C              necessary to use a matrix of partial derivatives of the
C              system of differential equations.  if you do not
C              provide a subroutine to evaluate it analytically (see
C              description of the item jac in the call list), it will
C              be approximated by numerical differencing in this code.
C              although it is less trouble for you to have the code
C              compute partial derivatives by numerical differencing,
C              the solution will be more reliable if you provide the
C              derivatives via jac. sometimes numerical differencing
C              is cheaper than evaluating derivatives in jac and
C              sometimes it is not - this depends on your problem.
C
C           **** do you want the code to evaluate the partial
C                  derivatives automatically by numerical differences ..
C                   yes - set info(5)=0
C                    no - set info(5)=1
C                  and provide subroutine jac for evaluating the
C                  matrix of partial derivatives ****
C
C       info(6) - ddassl will perform much better if the matrix of
C              partial derivatives, dg/dy + cj*dg/dyprime,
C              (here cj is a scalar determined by ddassl)
C              is banded and the code is told this. in this
C              case, the storage needed will be greatly reduced,
C              numerical differencing will be performed much cheaper,
C              and a number of important algorithms will execute much
C              faster. the differential equation is said to have
C              half-bandwidths ml (lower) and mu (upper) if equation i
C              involves only unknowns y(j) with
C                             i-ml .le. j .le. i+mu
C              for all i=1,2,...,neq. thus, ml and mu are the widths
C              of the lower and upper parts of the band, respectively,
C              with the main diagonal being excluded. if you do not
C              indicate that the equation has a banded matrix of partial
C                 derivatives
C              the code works with a full matrix of neq**2 elements
C              (stored in the conventional way). computations with
C              banded matrices cost less time and storage than with
C              full matrices if  2*ml+mu .lt. neq.  if you tell the
C              code that the matrix of partial derivatives has a banded
C              structure and you want to provide subroutine jac to
C              compute the partial derivatives, then you must be careful
C              to store the elements of the matrix in the special form
C              indicated in the description of jac.
C
C          **** do you want to solve the problem using a full
C               (dense) matrix (and not a special banded
C               structure) ...
C                yes - set info(6)=0
C                 no - set info(6)=1
C                       and provide the lower (ml) and upper (mu)
C                       bandwidths by setting
C                       iwork(1)=ml
C                       iwork(2)=mu ****
C
C
C        info(7) -- you can specify a maximum (absolute value of)
C              stepsize, so that the code
C              will avoid passing over very
C              large regions.
C
C          ****  do you want the code to decide
C                on its own maximum stepsize?
C                yes - set info(7)=0
C                 no - set info(7)=1
C                      and define hmax by setting
C                      rwork(2)=hmax ****
C
C        info(8) -- differential/algebraic problems
C              may occaisionally suffer from
C              severe scaling difficulties on the
C              first step. if you know a great deal
C              about the scaling of your problem, you can
C              help to alleviate this problem by
C              specifying an initial stepsize ho.
C
C          ****  do you want the code to define
C                its own initial stepsize?
C                yes - set info(8)=0
C                 no - set info(8)=1
C                      and define ho by setting
C                      rwork(3)=ho ****
C
C        info(9) -- if storage is a severe problem,
C              you can save some locations by
C              restricting the maximum order maxord.
C              the default value is 5. for each
C              order decrease below 5, the code
C              requires neq fewer locations, however
C              it is likely to be slower. in any
C              case, you must have 1 .le. maxord .le. 5
C          ****  do you want the maximum order to
C                default to 5?
C                yes - set info(9)=0
C                 no - set info(9)=1
C                      and define maxord by setting
C                      iwork(3)=maxord ****
C
C        info(10) --if you know that the solutions to your equations wil
C               always be nonnegative, it may help to set this
C               parameter.  however, it is probably best to
C               try the code without using this option first,
C               and only to use this option if that doesn't
C               work very well.
C           ****  do you want the code to solve the problem without
C                 invoking any special nonnegativity constraints?
C                  yes - set info(10)=0
C                   no - set info(10)=1
C
C        info(11) --ddassl normally requires the initial t,
C               y, and yprime to be consistent.  that is,
C               you must have g(t,y,yprime) = 0 at the initial
C               time.  if you do not know the initial
C               derivative precisely, you can let ddassl try
C               to compute it.
C          ****   are the initial t, y, yprime consistent?
C                 yes - set info(11) = 0
C                  no - set info(11) = 1,
C                       and set yprime to an initial approximation
C                       to yprime.  (if you have no idea what
C                       yprime should be, set it to zero. note
C                       that the initial y should be such
C                       that there must exist a yprime so that
C                       g(t,y,yprime) = 0.)
C
C   rtol, atol -- you must assign relative (rtol) and absolute (atol
C               error tolerances to tell the code how accurately you wan
C               the solution to be computed. they must be defined as
C               variables because the code may change them. you have two
C               choices --
C                     both rtol and atol are scalars. (info(2)=0)
C                     both rtol and atol are vectors. (info(2)=1)
C               in either case all components must be non-negative.
C
C               the tolerances are used by the code in a local error tes
C               at each step which requires roughly that
C                     abs(local error) .le. rtol*abs(y)+atol
C               for each vector component.
C               (more specifically, a root-mean-square norm is used to
C               measure the size of vectors, and the error test uses the
C               magnitude of the solution at the beginning of the step.)
C
C               the true (global) error is the difference between the tr
C               solution of the initial value problem and the computed
C               approximation. practically all present day codes.
C               including this one, control the local error at each step
C               and do not even attempt to control the global error
C               directly.
C               usually, but not always, the true accuracy of
C               the computed y is comparable to the error tolerances. th
C               code will usually, but not always, deliver a more accura
C               solution if you reduce the tolerances and integrate agai
C               by comparing two such solutions you can get a fairly
C               reliable idea of the true error in the solution at the
C               bigger tolerances.
C
C               setting atol=0. results in a pure relative error test on
C               that component. setting rtol=0. results in a pure absolu
C               error test on that component. a mixed test with non-zero
C               rtol and atol corresponds roughly to a relative error
C               test when the solution component is much bigger than ato
C               and to an absolute error test when the solution componen
C               is smaller than the threshold atol.
C
C               the code will not attempt to compute a solution at an
C               accuracy unreasonable for the machine being used. it wil
C               advise you if you ask for too much accuracy and inform
C               you as to the maximum accuracy it believes possible.
C
C  rwork(*) -- dimension this real work array of length lrw in your
C               calling program.
C
C  lrw -- set it to the declared length of the rwork array.
C               you must have
C                    lrw .ge. 40+(maxord+4)*neq+neq**2
C               for the full (dense) jacobian case (when info(6)=0),  or
C                    lrw .ge. 40+(maxord+4)*neq+(2*ml+mu+1)*neq
C               for the banded user-defined jacobian case
C               (when info(5)=1 and info(6)=1), or
C                     lrw .ge. 40+(maxord+4)*neq+(2*ml+mu+1)*neq
C                           +2*(neq/(ml+mu+1)+1)
C               for the banded finite-difference-generated jacobian case
C               (when info(5)=0 and info(6)=1)
C
C  iwork(*) -- dimension this integer work array of length liw in
C             your calling program.
C
C  liw -- set it to the declared length of the iwork array.
C               you must have liw .ge. 20+neq
C
C  rpar, ipar -- these are parameter arrays, of real and integer
C               type, respectively. you can use them for communication
C               between your program that calls ddassl and the
C               res subroutine (and the jac subroutine). they are not
C               altered by ddassl. if you do not need rpar or ipar, igno
C               these parameters by treating them as dummy arguments. if
C               you do choose to use them, dimension them in your callin
C               program and in res (and in jac) as arrays of appropriate
C               length.
C
C  jac -- if you have set info(5)=0, you can ignore this parameter
C               by treating it as a dummy argument. otherwise, you must
C               provide a subroutine of the form
C               jac(t,y,yprime,pd,cj,rpar,ipar)
C               to define the matrix of partial derivatives
C               pd=dg/dy+cj*dg/dyprime
C               cj is a scalar which is input to jac.
C               for the given values of t,y,yprime, the
C               subroutine must evaluate the non-zero partial
C               derivatives for each equation and each solution
C               compowent, and store these values in the
C               matrix pd. the elements of pd are set to zero
C               before each call to jac so only non-zero elements
C               need to be defined.
C
C               subroutine jac must not alter t,y,(*),yprime(*),or cj.
C               you must declare the name jac in an
C               external statement in your program that calls
C               ddassl. you must dimension y, yprime and pd
C               in jac.
C
C               the way you must store the elements into the pd matrix
C               depends on the structure of the matrix which you
C               indicated by info(6).
C               *** info(6)=0 -- full (dense) matrix ***
C                   when you evaluate the (non-zero) partial derivative
C                   of equation i with respect to variable j, you must
C               store it in pd according to
C                   pd(i,j) = * dg(i)/dy(j)+cj*dg(i)/dyprime(j)*
C               *** info(6)=1 -- banded jacobian with ml lower and mu
C                   upper diagonal bands (refer to info(6) description o
C                   ml and mu) ***
C                   when you evaluate the (non-zero) partial derivative
C                   of equation i with respect to variable j, you must
C                   store it in pd according to
C                   irow = i - j + ml + mu + 1
C                   pd(irow,j) = *dg(i)/dy(j)+cj*dg(i)/dyprime(j)*
C               rpar and ipar are real and integer parameter arrays whic
C               you can use for communication between your calling
C               program and your jacobian subroutine jac. they are not
C               altered by ddassl. if you do not need rpar or ipar, igno
C               these parameters by treating them as dummy arguments. if
C               you do choose to use them, dimension them in your callin
C               program and in jac as arrays of appropriate length.
C
C
C
C  optionally replaceable norm routine:
C  ddassl uses a weighted norm ddanrm to measure the size
C  of vectors such as the estimated error in each step.
C  a function subprogram
C    double precision function ddanrm(neq,v,wt,rpar,ipar)
C    dimension v(neq),wt(neq)
C  is used to define this norm.  here, v is the vector
C  whose norm is to be computed, and wt is a vector of
C  weights.  a ddanrm routine has been included with ddassl
C  which computes the weighted root-mean-square norm
C  given by
C    ddanrm=sqrt((1/neq)*sum(v(i)/wt(i))**2)
C  this norm is suitable for most problems.  in some
C  special cases, it may be more convenient and/or
C  efficient to define your own norm by writing a function
C  subprogram to be called instead of ddanrm.  this should
C  however, be attempted only after careful thought and
C  consideration.
C
C
C------output-after any return from ddassl----
C
C  the principal aim of the code is to return a computed solution at
C  tout, although it is also possible to obtain intermediate results
C  along the way. to find out whether the code achieved its goal
C  or if the integration process was interrupted before the task was
C  completed, you must check the idid parameter.
C
C
C   t -- the solution was successfully advanced to the
C               output value of t.
C
C   y(*) -- contains the computed solution approximation at t.
C
C   yprime(*) -- contains the computed derivative
C               approximation at t
C
C   idid -- reports what the code did
C
C                     *** task completed ***
C                reported by positive values of idid
C
C           idid = 1 -- a step was successfully taken in the
C                   intermediate-output mode. the code has not
C                   yet reached tout.
C
C           idid = 2 -- the integration to tout was successfully
C                   completed (t=tout) by stepping exactly to tout.
C
C           idid = 3 -- the integration to tout was successfully
C                   completed (t=tout) by stepping past tout.
C                   y(*) is obtained by interpolation.
C                   yprime(*) is obtained by interpolation.
C
C                    *** task interrupted ***
C                reported by negative values of idid
C
C           idid = -1 -- a large amount of work has been expended.
C                   (about 500 steps)
C
C           idid = -2 -- the error tolerances are too stringent.
C
C           idid = -3 -- the local error test cannot be satisfied
C                   because you specified a zero component in atol
C                   and the corresponding computed solution
C                   component is zero. thus, a pure relative error
C                   test is impossible for this component.
C
C           idid = -6 -- ddassl had repeated error test
C                   failures on the last attempted step.
C
C           idid = -7 -- the corrector could not converge.
C
C           idid = -8 -- the matrix of partial derivatives
C                   is singular.
C
C           idid = -9 -- the corrector could not converge.
C                   there were repeated error test failures
C                   in this step.
C
C           idid =-10 -- the corrector could not converge
C                   because ires was equal to minus one.
C
C           idid =-11 -- ires equal to -2 was encountered
C                   and control is being returned to the
C                   calling program.
C
C           idid =-12 -- ddassl failed to compute the initial
C                   yprime.
C
C
C
C           idid = -13,..,-32 -- not applicable for this code
C
C                    *** task terminated ***
C                reported by the value of idid=-33
C
C           idid = -33 -- the code has encountered trouble from which
C                   it cannot recover. a message is printed
C                   explaining the trouble and control is returned
C                   to the calling program. for example, this occurs
C                   when invalid input is detected.
C
C   rtol, atol -- these quantities remain unchanged except when
C               idid = -2. in this case, the error tolerances have been
C               increased by the code to values which are estimated to b
C               appropriate for continuing the integration. however, the
C               reported solution at t was obtained using the input valu
C               of rtol and atol.
C
C   rwork, iwork -- contain information which is usually of no
C               interest to the user but necessary for subsequent calls.
C               however, you may find use for
C
C               rwork(3)--which contains the step size h to be
C                       attempted on the next step.
C
C               rwork(4)--which contains the current value of the
C                       independent variable, i.e. the farthest point
C                       integration has reached. this will be different
C                       from t only when interpolation has been
C                       performed (idid=3).
C
C               rwork(7)--which contains the stepsize used
C                       on the last successful step.
C
C               iwork(7)--which contains the order of the method to
C                       be attempted on the next step.
C
C               iwork(8)--which contains the order of the method used
C                       on the last step.
C
C               iwork(11)--which contains the number of steps taken so f
C
C               iwork(12)--which contains the number of calls to res
C                        so far.
C
C               iwork(13)--which contains the number of evaluations of
C                        the matrix of partial derivatives needed so far
C
C               iwork(14)--which contains the total number
C                        of error test failures so far.
C
C               iwork(15)--which contains the total number
C                        of convergence test failures so far.
C                        (includes singular iteration matrix
C                        failures.)
C
C
C
C   input -- what to do to continue the integration
C            (calls after the first)                **
C
C     this code is organized so that subsequent calls to continue the
C     integration involve little (if any) additional effort on your
C     part. you must monitor the idid parameter in order to determine
C     what to do next.
C
C     recalling that the principal task of the code is to integrate
C     from t to tout (the interval mode), usually all you will need
C     to do is specify a new tout upon reaching the current tout.
C
C     do not alter any quantity not specifically permitted below,
C     in particular do not alter neq,t,y(*),yprime(*),rwork(*),iwork(*)
C     or the differential equation in subroutine res. any such
C     alteration constitutes a new problem and must be treated as such,
C     i.e. you must start afresh.
C
C     you cannot change from vector to scalar error control or vice
C     versa (info(2)) but you can change the size of the entries of
C     rtol, atol. increasing a tolerance makes the equation easier
C     to integrate. decreasing a tolerance will make the equation
C     harder to integrate and should generally be avoided.
C
C     you can switch from the intermediate-output mode to the
C     interval mode (info(3)) or vice versa at any time.
C
C     if it has been necessary to prevent the integration from going
C     past a point tstop (info(4), rwork(1)), keep in mind that the
C     code will not integrate to any tout beyound the currently
C     specified tstop. once tstop has been reached you must change
C     the value of tstop or set info(4)=0. you may change info(4)
C     or tstop at any time but you must supply the value of tstop in
C     rwork(1) whenever you set info(4)=1.
C
C     do not change info(5), info(6), iwork(1), or iwork(2)
C     unless you are going to restart the code.
C
C                    *** following a completed task ***
C     if
C     idid = 1, call the code again to continue the integration
C                  another step in the direction of tout.
C
C     idid = 2 or 3, define a new tout and call the code again.
C                  tout must be different from t. you cannot change
C                  the direction of integration without restarting.
C
C                    *** following an interrupted task ***
C                  to show the code that you realize the task was
C                  interrupted and that you want to continue, you
C                  must take appropriate action and set info(1) = 1
C     if
C     idid = -1, the code has taken about 500 steps.
C                  if you want to continue, set info(1) = 1 and
C                  call the code again. an additional 500 steps
C                  will be allowed.
C
C
C     idid = -2, the error tolerances rtol, atol have been
C                  increased to values the code estimates appropriate
C                  for continuing. you may want to change them
C                  yourself. if you are sure you want to continue
C                  with relaxed error tolerances, set info(1)=1 and
C                  call the code again.
C
C     idid = -3, a solution component is zero and you set the
C                  corresponding component of atol to zero. if you
C                  are sure you want to continue, you must first
C                  alter the error criterion to use positive values
C                  for those components of atol corresponding to zero
C                  solution components, then set info(1)=1 and call
C                  the code again.
C
C     idid = -4,-5  --- cannot occur with this code
C
C     idid = -6, repeated error test failures occurred on the
C                  last attempted step in ddassl. a singularity in the
C                  solution may be present. if you are absolutely
C                  certain you want to continue, you should restart
C                  the integration.(provide initial values of y and
C                  yprime which are consistent)
C
C     idid = -7, repeated convergence test failures occurred
C                  on the last attempted step in ddassl. an inaccurate o
C                  illconditioned jacobian may be the problem. if you
C                  are absolutely certain you want to continue, you
C                  should restart the integration.
C
C     idid = -8, the matrix of partial derivatives is singular.
C                  some of your equations may be redundant.
C                  ddassl cannot solve the problem as stated.
C                  it is possible that the redundant equations
C                  could be removed, and then ddassl could
C                  solve the problem. it is also possible
C                  that a solution to your problem either
C                  does not exist or is not unique.
C
C     idid = -9, ddassl had multiple convergence test
C                  failures, preceeded by multiple error
C                  test failures, on the last attempted step.
C                  it is possible that your problem
C                  is ill-posed, and cannot be solved
C                  using this code.  or, there may be a
C                  discontinuity or a singularity in the
C                  solution.  if you are absolutely certain
C                  you want to continue, you should restart
C                  the integration.
C
C    idid =-10, ddassl had multiple convergence test failures
C                  because ires was equal to minus one.
C                  if you are absolutely certain you want
C                  to continue, you should restart the
C                  integration.
C
C    idid =-11, ires=-2 was encountered, and control is being
C                  returned to the calling program.
C
C    idid =-12, ddassl failed to compute the initial yprime.
C               this could happen because the initial
C               approximation to yprime was not very good, or
C               if a yprime consistent with the initial y
C               does not exist.  the problem could also be caused
C               by an inaccurate or singular iteration matrix.
C
C
C
C     idid = -13,..,-32 --- cannot occur with this code
C
C                       *** following a terminated task ***
C     if idid= -33, you cannot continue the solution of this
C                  problem. an attempt to do so will result in your
C                  run being terminated.
C
C  ---------------------------------------------------------------------
C
C***REFERENCES  A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC
C                  SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637,
C                  SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982.
C***ROUTINES CALLED  DDASTP,DDAINI,DDANRM,DDAWTS,DDATRP,XERRWV,D1MACH
C***COMMON BLOCKS    DDA001
C***END PROLOGUE DDASSL
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL DONE
      EXTERNAL RES,JAC
      DIMENSION Y(1),YPRIME(1)
      DIMENSION INFO(15)
      DIMENSION RWORK(1),IWORK(1)
      DIMENSION RTOL(1),ATOL(1)
      DIMENSION RPAR(1),IPAR(1)
      COMMON/SDEV2/ ITRACE, IDEV
      COMMON /SDDTR/ TERKP1, TERK, TERKM1, TERKM2
      COMMON/DDA001/NPD,NTEMP,
     *   LML,LMU,LMXORD,LMTYPE,
     *   LNST,LNRE,LNJE,LETF,LCTF,LIPVT
      DATA LTSTOP,LHMAX,LH,LTN,
     *   LCJ,LCJOLD,LHOLD,LS,LROUND,
     *   LALPHA,LBETA,LGAMMA,
     *   LPSI,LSIGMA,LDELTA
     *   /1,2,3,4,
     *   5,6,7,8,9,
     *   11,17,23,
     *   29,35,41/
      IF(INFO(1).NE.0)GO TO 100
C
C-----------------------------------------------------------------------
C     this block is executed for the initial call only.
C     it contains checking of inputs and initializations.
C-----------------------------------------------------------------------
C
C     first check info array to make sure all elements of info
C     are either zero or one.
      DO 10 I=2,11
         IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701
10       CONTINUE
C
      IF(NEQ.LE.0)GO TO 702
C
C     set pointers into iwork
      LML=1
      LMU=2
      LMXORD=3
      LMTYPE=4
      LJCALC=5
      LPHASE=6
      LK=7
      LKOLD=8
      LNS=9
      LNSTL=10
      LNST=11
      LNRE=12
      LNJE=13
      LETF=14
      LCTF=15
      LIPVT=21
      LIWM=1
C
C     check and compute maximum order
      MXORD=5
      IF(INFO(9).EQ.0)GO TO 20
         MXORD=IWORK(LMXORD)
         IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703
20       IWORK(LMXORD)=MXORD
C
C     compute mtype,lenpd,lenrw.check ml and mu.
      IF(INFO(6).NE.0)GO TO 40
         LENPD=NEQ**2
         LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD
         IF(INFO(5).NE.0)GO TO 30
            IWORK(LMTYPE)=2
            GO TO 60
30          IWORK(LMTYPE)=1
            GO TO 60
40    IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717
      IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718
      LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ
      IF(INFO(5).NE.0)GO TO 50
         IWORK(LMTYPE)=5
         MBAND=IWORK(LML)+IWORK(LMU)+1
         MSAVE=(NEQ/MBAND)+1
         LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE
         GO TO 60
50       IWORK(LMTYPE)=4
         LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD
C
C     check lengths of rwork and iwork
60    LENIW=20+NEQ
      IF(LRW.LT.LENRW)GO TO 704
      IF(LIW.LT.LENIW)GO TO 705
C
C     check to see that tout is different from t
      IF(TOUT .EQ. T)GO TO 719
C
C     check hmax
      IF(INFO(7).EQ.0)GO TO 70
         HMAX=RWORK(LHMAX)
         IF(HMAX.LE.0.0D0)GO TO 710
70    CONTINUE
C
C     initialize counters
      IWORK(LNST)=0
      IWORK(LNRE)=0
      IWORK(LNJE)=0
C
      IWORK(LNSTL)=0
      IDID=1
      GO TO 200
C
C-----------------------------------------------------------------------
C     this block is for continuation calls
C     only. here we check info(1),and if the
C     last step was interrupted we check whether
C     appropriate action was taken.
C-----------------------------------------------------------------------
C
100   CONTINUE
      IF(INFO(1).EQ.1)GO TO 110
      IF(INFO(1).NE.-1)GO TO 701
C     if we are here, the last step was interrupted
C     by an error condition from ddastp,and
C     appropriate action was not taken. this
C     is a fatal error.
      CALL XERRWV(
     *49HDASSL--  THE LAST STEP TERMINATED WITH A NEGATIVE,
     *49,201,0,0,0,0,0,0.0D0,0.0D0)
      CALL XERRWV(
     *47HDASSL--  VALUE (=I1) OF IDID AND NO APPROPRIATE,
     *47,202,0,1,IDID,0,0,0.0D0,0.0D0)
      CALL XERRWV(
     *41HDASSL--  ACTION WAS TAKEN. RUN TERMINATED,
     *41,203,1,0,0,0,0,0.0D0,0.0D0)
      RETURN
110   CONTINUE
      IWORK(LNSTL)=IWORK(LNST)
C
C-----------------------------------------------------------------------
C     this block is executed on all calls.
C     the error tolerance parameters are
C     checked, and the work array pointers
C     are set.
C-----------------------------------------------------------------------
C
200   CONTINUE
C     check rtol,atol
      NZFLG=0
      RTOLI=RTOL(1)
      ATOLI=ATOL(1)
      DO 210 I=1,NEQ
         IF(INFO(2).EQ.1)RTOLI=RTOL(I)
         IF(INFO(2).EQ.1)ATOLI=ATOL(I)
         IF(RTOLI.GT.0.0D0.OR.ATOLI.GT.0.0D0)NZFLG=1
         IF(RTOLI.LT.0.0D0)GO TO 706
         IF(ATOLI.LT.0.0D0)GO TO 707
210      CONTINUE
      IF(NZFLG.EQ.0)GO TO 708
C
C     set up rwork storage.iwork storage is fixed
C     in data statement.
      LE=LDELTA+NEQ
      LWT=LE+NEQ
      LPHI=LWT+NEQ
      LPD=LPHI+(IWORK(LMXORD)+1)*NEQ
      LWM=LPD
      NPD=1
      NTEMP=NPD+LENPD
      IF(INFO(1).EQ.1)GO TO 400
C
C-----------------------------------------------------------------------
C     this block is executed on the initial call
C     only. set the initial step size, and
C     the error weight vector, and phi.
C     compute initial yprime, if necessary.
C-----------------------------------------------------------------------
C
300   CONTINUE
      TN=T
      IDID=1
C
C     set error weight vector wt
      CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR)
      DO 305 I = 1,NEQ
         IF(RWORK(LWT+I-1).LE.0.0D0) GO TO 713
305      CONTINUE
C
C     compute unit roundoff and hmin
      UROUND = D1MACH(4)
      RWORK(LROUND) = UROUND
      HMIN = 4.0D0*UROUND*DMAX1(DABS(T),DABS(TOUT))
C
C     check initial interval to see that it is long enough
      TDIST = DABS(TOUT - T)
      IF(TDIST .LT. HMIN) GO TO 714
C
C     check ho, if this was input
      IF (INFO(8) .EQ. 0) GO TO 310
         HO = RWORK(LH)
         IF ((TOUT - T)*HO .LT. 0.0D0) GO TO 711
         IF (HO .EQ. 0.0D0) GO TO 712
         GO TO 320
310    CONTINUE
C
C     compute initial stepsize, to be used by either
C     ddastp or ddaini, depending on info(11)
      HO = 0.001D0*TDIST
      YPNORM = DDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR)
      IF (YPNORM .GT. 0.5D0/HO) HO = 0.5D0/YPNORM
      HO = DSIGN(HO,TOUT-T)
C     adjust ho if necessary to meet hmax bound
320   IF (INFO(7) .EQ. 0) GO TO 330
         RH = DABS(HO)/HMAX
         IF (RH .GT. 1.0D0) HO = HO/RH
C     compute tstop, if applicable
330   IF (INFO(4) .EQ. 0) GO TO 340
         TSTOP = RWORK(LTSTOP)
         IF ((TSTOP - T)*HO .LT. 0.0D0) GO TO 715
         IF ((T + HO - TSTOP)*HO .GT. 0.0D0) HO = TSTOP - T
         IF ((TSTOP - TOUT)*HO .LT. 0.0D0) GO TO 709
C
C     compute initial derivative, if applicable
340   IF (INFO(11) .EQ. 0) GO TO 350
      CALL DDAINI(T,Y,YPRIME,NEQ,
     *  RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR,
     *  RWORK(LPHI),RWORK(LDELTA),RWORK(LE),
     *  RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND),INFO(10))
      IF(ITRACE .GE. 1)WRITE(IDEV,349)IDID
349   FORMAT(' IDID FROM INIT SOLVER IS ',I3)
      IF (IDID .LT. 0) GO TO 390
C
C     load h with ho.  store h in rwork(lh)
350   H = HO
      RWORK(LH) = H
C
C     load y and h*yprime into phi(*,1) and phi(*,2)
360   ITEMP = LPHI + NEQ
      DO 370 I = 1,NEQ
         RWORK(LPHI + I - 1) = Y(I)
370      RWORK(ITEMP + I - 1) = H*YPRIME(I)
C
390   GO TO 500
C
C-------------------------------------------------------
C     this block is for continuation calls only. its
C     purpose is to check stop conditions before
C     taking a step.
C     adjust h if necessary to meet hmax bound
C-------------------------------------------------------
C
400   CONTINUE
      DONE = .FALSE.
      TN=RWORK(LTN)
      H=RWORK(LH)
      IF(INFO(7) .EQ. 0) GO TO 410
         RH = DABS(H)/HMAX
         IF(RH .GT. 1.0D0) H = H/RH
410   CONTINUE
      IF(T .EQ. TOUT) GO TO 719
      IF((T - TOUT)*H .GT. 0.0D0) GO TO 711
      IF(INFO(4) .EQ. 1) GO TO 430
      IF(INFO(3) .EQ. 1) GO TO 420
      IF((TN-TOUT)*H.LT.0.0D0)GO TO 490
      CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T=TOUT
      IDID = 3
      DONE = .TRUE.
      GO TO 490
420   IF((TN-T)*H .LE. 0.0D0) GO TO 490
      IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425
      CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T = TN
      IDID = 1
      DONE = .TRUE.
      GO TO 490
425   CONTINUE
      CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T = TOUT
      IDID = 3
      DONE = .TRUE.
      GO TO 490
430   IF(INFO(3) .EQ. 1) GO TO 440
      TSTOP=RWORK(LTSTOP)
      IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715
      IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709
      IF((TN-TOUT)*H.LT.0.0D0)GO TO 450
      CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
     *   RWORK(LPHI),RWORK(LPSI))
      T=TOUT
      IDID = 3
      DONE = .TRUE.
      GO TO 490
440   TSTOP = RWORK(LTSTOP)
      IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715
      IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709
      IF((TN-T)*H .LE. 0.0D0) GO TO 450
      IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445
      CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T = TN
      IDID = 1
      DONE = .TRUE.
      GO TO 490
445   CONTINUE
      CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
     *  RWORK(LPHI),RWORK(LPSI))
      T = TOUT
      IDID = 3
      DONE = .TRUE.
      GO TO 490
450   CONTINUE
C     check whether we are with in roundoff of tstop
      IF(DABS(TN-TSTOP).GT.100.0D0*UROUND*
     *   (DABS(TN)+DABS(H)))GO TO 460
      IDID=2
      T=TSTOP
      DONE = .TRUE.
      GO TO 490
460   TNEXT=TN+H*(1.0D0+4.0D0*UROUND)
      IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490
      H=(TSTOP-TN)*(1.0D0-4.0D0*UROUND)
      RWORK(LH)=H
C
490   IF (DONE) GO TO 590
C
C-------------------------------------------------------
C     the next block contains the call to the
C     one-step integrator ddastp.
C     this is a looping point for the integration
C     steps.
C     check for too many steps.
C     update wt.
C     check for too much accuracy requested.
C     compute minimum stepsize.
C-------------------------------------------------------
C
500   CONTINUE
C     check for failure to compute initial yprime
      IF (IDID .EQ. -12) GO TO 527
C
C     check for too many steps
      IF((IWORK(LNST)-IWORK(LNSTL)).LT.500)
     *   GO TO 510
           IDID=-1
           GO TO 527
C
C     update wt
510   CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI),
     *  RWORK(LWT),RPAR,IPAR)
      DO 520 I=1,NEQ
         IF(RWORK(I+LWT-1).GT.0.0D0)GO TO 520
           IDID=-3
           GO TO 527
520   CONTINUE
C
C     test for too much accuracy requested.
      R=DDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)*
     *   100.0D0*UROUND
C     IF(ITRACE.GE.1 .AND. R.GT.1.0D0)WRITE(IDEV,521)RTOL(1),ATOL(1),R,
C    *                                               UROUND
C521   FORMAT(' TOLS ',2D11.3,' MUST BE MULT BY R=',D11.3,' UR =',D11.3)
      IF(R.LE.1.0D0 )GO TO 525
C     multiply rtol and atol by r and return
      IF(INFO(2).EQ.1)GO TO 523
           RTOL(1)=R*RTOL(1)
           ATOL(1)=R*ATOL(1)
           IDID=-2
           GO TO 527
523   DO 524 I=1,NEQ
           RTOL(I)=R*RTOL(I)
524        ATOL(I)=R*ATOL(I)
      IDID=-2
      GO TO 527
525   CONTINUE
C
C     compute minimum stepsize
      HMIN=4.0D0*UROUND*DMAX1(DABS(TN),DABS(TOUT))
C
      CALL DDASTP(TN,Y,YPRIME,NEQ,
     *   RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR,
     *   RWORK(LPHI),RWORK(LDELTA),RWORK(LE),
     *   RWORK(LWM),IWORK(LIWM),
     *   RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA),
     *   RWORK(LPSI),RWORK(LSIGMA),
     *   RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),
     *   RWORK(LS),HMIN,RWORK(LROUND),
     *   IWORK(LPHASE),IWORK(LJCALC),IWORK(LK),
     *   IWORK(LKOLD),IWORK(LNS),INFO(10))
527   IF(IDID.LT.0)GO TO 600
C
C------------------------------------------------------
C     this block handles the case of a successful
C     return from ddastp (idid=1) test for
C     stop conditions.
C--------------------------------------------------------
C
       IF(ITRACE .GE. 1)WRITE(IDEV,528)TN,H, IWORK(LKOLD)
C      IF(ITRACE .GE. 1)WRITE(IDEV,5281)TERKP1, TERK, TERKM1, TERKM2
528    FORMAT(' AT T= ',D11.3,' H=',D11.3,'  ORDER=',I3)
5281   FORMAT(' ERRORS FOR DESCENDING ORDERS ARE ',4D11.3)
C      CALL DASMON(NEQ, TN, H, Y, YPRIME, IWORK(LKOLD))
      IF(INFO(4).NE.0)GO TO 540
           IF(INFO(3).NE.0)GO TO 530
             IF((TN-TOUT)*H.LT.0.0D0)GO TO 500
             CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,
     *         IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
             IDID=3
             T=TOUT
             GO TO 580
530          IF((TN-TOUT)*H.GE.0.0D0)GO TO 535
             T=TN
             IDID=1
             GO TO 580
535          CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,
     *         IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
             IDID=3
             T=TOUT
             GO TO 580
540   IF(INFO(3).NE.0)GO TO 550
      IF((TN-TOUT)*H.LT.0.0D0)GO TO 542
         CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,
     *     IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
         T=TOUT
         IDID=3
         GO TO 580
542   IF(DABS(TN-TSTOP).LE.100.0D0*UROUND*
     *   (DABS(TN)+DABS(H)))GO TO 545
      TNEXT=TN+H*(1.0D0+4.0D0*UROUND)
      IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500
      H=(TSTOP-TN)*(1.0D0-4.0D0*UROUND)
      GO TO 500
545   IDID=2
      T=TSTOP
      GO TO 580
550   IF((TN-TOUT)*H.GE.0.0D0)GO TO 555
      IF(DABS(TN-TSTOP).LE.100.0D0*UROUND*(DABS(TN)+DABS(H)))GO TO 552
      T=TN
      IDID=1
      GO TO 580
552   IDID=2
      T=TSTOP
      GO TO 580
555   CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,
     *   IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
      T=TOUT
      IDID=3
580   CONTINUE
C
C--------------------------------------------------------
C     all successful returns from ddassl are made from
C     this block.
C--------------------------------------------------------
C
590   CONTINUE
      RWORK(LTN)=TN
      RWORK(LH)=H
      RETURN
C
C-----------------------------------------------------------------------
C     this block handles all unsuccessful
C     returns other than for illegal input.
C-----------------------------------------------------------------------
C
600   CONTINUE
      ITEMP=-IDID
      GO TO (610,620,630,690,690,640,650,660,670,675,
     *  680,685), ITEMP
C
C     the maximum number of steps was taken before
C     reaching tout
610   CALL XERRWV(
     *38HDASSL--  AT CURRENT T (=R1)  500 STEPS,
     *38,610,0,0,0,0,1,TN,0.0D0)
      CALL XERRWV(48HDASSL--  TAKEN ON THIS CALL BEFORE REACHING TOUT,
     *48,611,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 690
C
C     too much accuracy for machine precision
620   CALL XERRWV(
     *47HDASSL--  AT T (=R1) TOO MUCH ACCURACY REQUESTED,
     *47,620,0,0,0,0,1,TN,0.0D0)
      CALL XERRWV(
     *48HDASSL--  FOR PRECISION OF MACHINE. RTOL AND ATOL,
     *48,621,0,0,0,0,0,0.0D0,0.0D0)
      CALL XERRWV(
     *45HDASSL--  WERE INCREASED TO APPROPRIATE VALUES,
     *45,622,0,0,0,0,0,0.0D0,0.0D0)
C
      GO TO 690
C     wt(i) .le. 0.0d0 for some i (not at start of problem)
630   CALL XERRWV(
     *38HDASSL--  AT T (=R1) SOME ELEMENT OF WT,
     *38,630,0,0,0,0,1,TN,0.0D0)
      CALL XERRWV(28HDASSL--  HAS BECOME .LE. 0.0,
     *28,631,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 690
C
C     error test failed repeatedly or with h=hmin
640   CALL XERRWV(
     *44HDASSL--  AT T (=R1) AND STEPSIZE H (=R2) THE,
     *44,640,0,0,0,0,2,TN,H)
      CALL XERRWV(
     *57HDASSL--  ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN,
     *57,641,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 690
C
C     corrector convergence failed repeatedly or with h=hmin
650   CALL XERRWV(
     *44HDASSL--  AT T (=R1) AND STEPSIZE H (=R2) THE,
     *44,650,0,0,0,0,2,TN,H)
      CALL XERRWV(
     *48HDASSL--  CORRECTOR FAILED TO CONVERGE REPEATEDLY,
     *48,651,0,0,0,0,0,0.0D0,0.0D0)
      CALL XERRWV(
     *28HDASSL--  OR WITH ABS(H)=HMIN,
     *28,652,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 690
C
C     the iteration matrix is singular
660   CALL XERRWV(
     *44HDASSL--  AT T (=R1) AND STEPSIZE H (=R2) THE,
     *44,660,0,0,0,0,2,TN,H)
      CALL XERRWV(
     *37HDASSL--  ITERATION MATRIX IS SINGULAR,
     *37,661,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 690
C
C     corrector failure preceeded by error test failures.
670   CALL XERRWV(
     *44HDASSL--  AT T (=R1) AND STEPSIZE H (=R2) THE,
     *44,670,0,0,0,0,2,TN,H)
      CALL XERRWV(
     *49HDASSL--  CORRECTOR COULD NOT CONVERGE.  ALSO, THE,
     *49,671,0,0,0,0,0,0.0D0,0.0D0)
      CALL XERRWV(
     *38HDASSL--  ERROR TEST FAILED REPEATEDLY.,
     *38,672,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 690
C
C     corrector failure because ires = -1
675   CALL XERRWV(
     *44HDASSL--  AT T (=R1) AND STEPSIZE H (=R2) THE,
     *44,675,0,0,0,0,2,TN,H)
      CALL XERRWV(
     *45HDASSL--  CORRECTOR COULD NOT CONVERGE BECAUSE,
     *455,676,0,0,0,0,0,0.0D0,0.0D0)
      CALL XERRWV(
     *36HDASSL--  IRES WAS EQUAL TO MINUS ONE,
     *36,677,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 690
C
C     failure because ires = -2
680   CALL XERRWV(
     *40HDASSL--  AT T (=R1) AND STEPSIZE H (=R2),
     *40,680,0,0,0,0,2,TN,H)
      CALL XERRWV(
     *36HDASSL--  IRES WAS EQUAL TO MINUS TWO,
     *36,681,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 690
C
C     failed to compute initial yprime
685   CALL XERRWV(
     *44HDASSL--  AT T (=R1) AND STEPSIZE H (=R2) THE,
     *44,685,0,0,0,0,2,TN,HO)
      CALL XERRWV(
     *45HDASSL--  INITIAL YPRIME COULD NOT BE COMPUTED,
     *45,686,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 690
690   CONTINUE
      INFO(1)=-1
      T=TN
      RWORK(LTN)=TN
      RWORK(LH)=H
      RETURN
C-----------------------------------------------------------------------
C     this block handles all error returns due
C     to illegal input, as detected before calling
C     ddastp. first the error message routine is
C     called. if this happens twice in
C     succession, execution is terminated
C
C-----------------------------------------------------------------------
701   CALL XERRWV(
     *55HDASSL--  SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE,
     *55,1,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 750
702   CALL XERRWV(25HDASSL--  NEQ (=I1) .LE. 0,
     *25,2,0,1,NEQ,0,0,0.0D0,0.0D0)
      GO TO 750
703   CALL XERRWV(34HDASSL--  MAXORD (=I1) NOT IN RANGE,
     *34,3,0,1,MXORD,0,0,0.0D0,0.0D0)
      GO TO 750
704   CALL XERRWV(
     *60HDASSL--  RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2),
     *60,4,0,2,LENRW,LRW,0,0.0D0,0.0D0)
      GO TO 750
705   CALL XERRWV(
     *60HDASSL--  IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2),
     *60,5,0,2,LENIW,LIW,0,0.0D0,0.0D0)
      GO TO 750
706   CALL XERRWV(
     *39HDASSL--  SOME ELEMENT OF RTOL IS .LT. 0,
     *39,6,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 750
707   CALL XERRWV(
     *39HDASSL--  SOME ELEMENT OF ATOL IS .LT. 0,
     *39,7,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 750
708   CALL XERRWV(
     *47HDASSL--  ALL ELEMENTS OF RTOL AND ATOL ARE ZERO,
     *47,8,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 750
709   CALL XERRWV(
     *54HDASSL--  INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2),
     *54,9,0,0,0,0,2,TSTOP,TOUT)
      GO TO 750
710   CALL XERRWV(28HDASSL--  HMAX (=R1) .LT. 0.0,
     *28,10,0,0,0,0,1,HMAX,0.0D0)
      GO TO 750
711   CALL XERRWV(34HDASSL--  TOUT (=R1) BEHIND T (=R2),
     *34,11,0,0,0,0,2,TOUT,T)
      GO TO 750
712   CALL XERRWV(29HDASSL--  INFO(8)=1 AND H0=0.0,
     *29,12,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 750
713   CALL XERRWV(39HDASSL--  SOME ELEMENT OF WT IS .LE. 0.0,
     *39,13,0,0,0,0,0,0.0D0,0.0D0)
      GO TO 750
714   CALL XERRWV(
     *61HDASSL--  TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION,
     *61,14,0,0,0,0,2,TOUT,T)
      GO TO 750
715   CALL XERRWV(
     *49HDASSL--  INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2),
     *49,15,0,0,0,0,2,TSTOP,T)
      GO TO 750
717   CALL XERRWV(
     *52HDASSL--  ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ,
     *52,17,0,1,IWORK(LML),0,0,0.0D0,0.0D0)
      GO TO 750
718   CALL XERRWV(
     *52HDASSL--  MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ,
     *52,18,0,1,IWORK(LMU),0,0,0.0D0,0.0D0)
      GO TO 750
719   CALL XERRWV(
     *39HDASSL--  TOUT (=R1) IS EQUAL TO T (=R2),
     *39,19,0,0,0,0,2,TOUT,T)
      GO TO 750
750   IF(INFO(1).EQ.-1) GO TO 760
      INFO(1)=-1
      IDID=-33
      RETURN
760   CALL XERRWV(
     *46HDASSL--  REPEATED OCCURRENCES OF ILLEGAL INPUT,
     *46,801,0,0,0,0,0,0.0D0,0.0D0)
770   CALL XERRWV(
     *47HDASSL--  RUN TERMINATED. APPARENT INFINITE LOOP,
     *47,802,1,0,0,0,0,0.0D0,0.0D0)
      RETURN
C-----------end of subroutine ddassl------------------------------------
      END
      SUBROUTINE DDAWTS(NEQ,IWT,RTOL,ATOL,Y,WT,RPAR,IPAR)
C
C***BEGIN PROLOGUE  DDAWTS
C***REFER TO  DDASSL
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   830315   (YYMMDD)
C***REVISION DATE  830315   (YYMMDD)
C***END PROLOGUE  DDAWTS
C-----------------------------------------------------------------------
C     this subroutine sets the error weight vector
C     wt according to wt(i)=rtol(i)*abs(y(i))+atol(i),
C     i=1,-,n.
C     rtol and atol are scalars if iwt = 0,
C     and vectors if iwt = 1.
C-----------------------------------------------------------------------
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION RTOL(1),ATOL(1),Y(1),WT(1)
      DIMENSION RPAR(1),IPAR(1)
      RTOLI=RTOL(1)
      ATOLI=ATOL(1)
      DO 20 I=1,NEQ
         IF (IWT .EQ.0) GO TO 10
           RTOLI=RTOL(I)
           ATOLI=ATOL(I)
10         WT(I)=RTOLI*DABS(Y(I))+ATOLI
20         CONTINUE
      RETURN
C-----------end of subroutine ddawts------------------------------------
      END
      SUBROUTINE DDASTP(X,Y,YPRIME,NEQ,
     *  RES,JAC,H,WT,JSTART,IDID,RPAR,IPAR,
     *  PHI,DELTA,E,WM,IWM,
     *  ALPHA,BETA,GAMMA,PSI,SIGMA,
     *  CJ,CJOLD,HOLD,S,HMIN,UROUND,
     *  IPHASE,JCALC,K,KOLD,NS,NONNEG)
C
C***BEGIN PROLOGUE  DDASTP
C***REFER TO  DDASSL
C***ROUTINES CALLED  DDANRM,DDAJAC,DDASLV,DDATRP
C***COMMON BLOCKS    DDA001
C***DATE WRITTEN   830315   (YYMMDD)
C***REVISION DATE  830315   (YYMMDD)
C***END PROLOGUE  DDASTP
C
C
C-----------------------------------------------------------------------
C     dastep solves a system of differential/
C     algebraic equations of the form
C     g(x,y,yprime) = 0,  for one step (normally
C     from x to x+h).
C
C     the methods used are modified divided
C     difference,fixed leading coefficient
C     forms of backward differentiation
C     formulas. the code adjusts the stepsize
C     and order to control the local error per
C     step.
C
C
C     the parameters represent
C     x  --        independent variable
C     y  --        solution vector at x
C     yprime --    derivative of solution vector
C                  after successful step
C     neq --       number of equations to be integrated
C     res --       external user-supplied subroutine
C                  to evaluate the residual.  the call is
C                  call res(x,y,yprime,delta,ires,rpar,ipar)
C                  x,y,yprime are input.  delta is output.
C                  on input, ires=0.  res should alter ires only
C                  if it encounters an illegal value of y or a
C                  stop condition.  set ires=-1 if an input value
C                  of y is illegal, and dastep will try to solve
C                  the problem without getting ires = -1.  if
C                  ires=-2, dastep returns control to the calling
C                  program with idid = -11.
C     jac --       external user-supplied routine to evaluate
C                  the iteration matrix (this is optional)
C                  the call is of the form
C                  call jac(x,y,yprime,pd,cj,rpar,ipar)
C                  pd is the matrix of partial derivatives,
C                  pd=dg/dy+cj*dg/dyprime
C     h --         appropriate step size for next step.
C                  normally determined by the code
C     wt --        vector of weights for error criterion.
C     jstart --    integer variable set 0 for
C                  first step, 1 otherwise.
C     idid --      completion code with the following meanings%
C                  idid= 1 -- the step was completed successfully
C                  idid=-6 -- the error test failed repeatedly
C                  idid=-7 -- the corrector could not converge
C                  idid=-8 -- the iteration matrix is singular
C                  idid=-9 -- the corrector could not converge.
C                             there were repeated error test
C                             failures on this step.
C                  idid=-10-- the corrector could not converge
C                             because ires was equal to minus one
C                  idid=-11-- ires equal to -2 was encountered,
C                             and control is being returned to
C                             the calling program
C     rpar,ipar -- real and integer parameter arrays that
C                  are used for communication between the
C                  calling program and external user routines
C                  they are not altered by dastep
C     phi --       array of divided differences used by
C                  dastep. the length is neq*(k+1),where
C                  k is the maximum order
C     delta,e --   work vectors for dastep of length neq
C     wm,iwm --    real and integer arrays storing
C                  matrix information such as the matrix
C                  of partial derivatives,permutation
C                  vector,and various other information.
C
C     the other parameters are information
C     which is needed internally by dastep to
C     continue from step to step.
C
C-----------------------------------------------------------------------
C
C
C
      IMPLICIT REAL*8(A-H,O-Z)
      LOGICAL CONVGD
      DIMENSION Y(1),YPRIME(1),WT(1)
      DIMENSION PHI(NEQ,1),DELTA(1),E(1)
      DIMENSION WM(1),IWM(1)
      DIMENSION PSI(1),ALPHA(1),BETA(1),GAMMA(1),SIGMA(1)
      DIMENSION RPAR(1),IPAR(1)
      EXTERNAL RES,JAC
      COMMON /SDEV2/ ITRACE, IDEV
      COMMON /SDDTR/ TERKP1, TERK, TERKM1, TERKM2
      COMMON/DDA001/NPD,NTEMP,
     *   LML,LMU,LMXORD,LMTYPE,
     *   LNST,LNRE,LNJE,LETF,LCTF,LIPVT
      COMMON /ERRCNT/ IEFAIL
      DATA MAXIT/4/
      DATA XRATE/0.25D0/
C
C
C
C
C
C-----------------------------------------------------------------------
C     block 1.
C     initialize. on the first call,set
C     the order to 1 and initialize
C     other variables.
C-----------------------------------------------------------------------
C
C     initializations for all calls
      IDID=1
      XOLD=X
      NCF=0
      NSF=0
      NEF=0
      IF(JSTART .NE. 0) GO TO 120
C
C     if this is the first step,perform
C     other initializations
      IWM(LETF) = 0
      IWM(LCTF) = 0
      K=1
      KOLD=0
      HOLD=0.0D0
      JSTART=1
      PSI(1)=H
      CJOLD = 1.0D0/H
      CJ = CJOLD
      S = 100.D0
      JCALC = -1
      DELNRM=1.0D0
      IPHASE = 0
      NS=0
120   CONTINUE
C
C
C
C
C
C-----------------------------------------------------------------------
C     block 2
C     compute coefficients of formulas for
C     this step.
C-----------------------------------------------------------------------
200   CONTINUE
      KP1=K+1
      KP2=K+2
      KM1=K-1
      XOLD=X
      IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0
      NS=MIN0(NS+1,KOLD+2)
      NSP1=NS+1
      IF(KP1 .LT. NS)GO TO 230
C
      BETA(1)=1.0D0
      ALPHA(1)=1.0D0
      TEMP1=H
      GAMMA(1)=0.0D0
      SIGMA(1)=1.0D0
      DO 210 I=2,KP1
         TEMP2=PSI(I-1)
         PSI(I-1)=TEMP1
         BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2
         TEMP1=TEMP2+H
         ALPHA(I)=H/TEMP1
         SIGMA(I)=DFLOAT(I-1)*SIGMA(I-1)*ALPHA(I)
         GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H
210      CONTINUE
      PSI(KP1)=TEMP1
230   CONTINUE
C
C     compute alphas, alpha0
      ALPHAS = 0.0D0
      ALPHA0 = 0.0D0
      DO 240 I = 1,K
        ALPHAS = ALPHAS - 1.0D0/DFLOAT(I)
        ALPHA0 = ALPHA0 - ALPHA(I)
240     CONTINUE
C
C     compute leading coefficient cj
      CJLAST = CJ
      CJ = -ALPHAS/H
C
C     compute variable stepsize error coefficient ck
      CK = DABS(ALPHA(KP1) + ALPHAS - ALPHA0)
      CK = DMAX1(CK,ALPHA(KP1))
C
C     decide whether new jacobian is needed
      TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE)
      TEMP2 = 1.0D0/TEMP1
      IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1
      IF (CJ .NE. CJLAST) S = 100.D0
C
C     change phi to phi star
      IF(KP1 .LT. NSP1) GO TO 280
      DO 270 J=NSP1,KP1
         DO 260 I=1,NEQ
260         PHI(I,J)=BETA(J)*PHI(I,J)
270      CONTINUE
280   CONTINUE
C
C     update time
      X=X+H
C
C
C
C
C
C-----------------------------------------------------------------------
C     block 3
C     predict the solution and derivative,
C     and solve the corrector equation
C-----------------------------------------------------------------------
C
C     first,predict the solution and derivative
300   CONTINUE
      DO 310 I=1,NEQ
         Y(I)=PHI(I,1)
310      YPRIME(I)=0.0D0
      DO 330 J=2,KP1
         DO 320 I=1,NEQ
            Y(I)=Y(I)+PHI(I,J)
320         YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J)
330   CONTINUE
      PNORM = DDANRM (NEQ,Y,WT,RPAR,IPAR)
C
C
C
C     solve the corrector equation using a
C     modified newton scheme.
      CONVGD= .TRUE.
      M=0
      IWM(LNRE)=IWM(LNRE)+1
      IRES = 0
      CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
      IF (IRES .LT. 0) GO TO 380
C
C
C     if indicated,reevaluate the
C     iteration matrix pd = dg/dy + cj*dg/dyprime
C     (where g(x,y,yprime)=0). set
C     jcalc to 0 as an indicator that
C     this has been done.
      IF(JCALC .NE. -1)GO TO 340
      IWM(LNJE)=IWM(LNJE)+1
      JCALC=0
      CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H,
     * IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR,IPAR)
      IF(ITRACE .GE. 1)WRITE(IDEV,331)
 331  FORMAT(' JAC EVAL')
      CJOLD=CJ
      S = 100.D0
      IF (IRES .LT. 0) GO TO 380
      IF(IER .NE. 0)GO TO 380
      NSF=0
C
C
C     initialize the error accumulation vector e.
340   CONTINUE
      DO 345 I=1,NEQ
345      E(I)=0.0D0
C
      S = 100.E0
C
C
C     corrector loop.
350   CONTINUE
C
C     multiply residual by temp1 to accelerate convergence
      TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD)
      DO 355 I = 1,NEQ
355     DELTA(I) = DELTA(I) * TEMP1
C
C     compute a new iterate (back-substitution).
C     store the correction in delta.
      CALL DDASLV(NEQ,DELTA,WM,IWM)
C
C     update y,e,and yprime
      DO 360 I=1,NEQ
         Y(I)=Y(I)-DELTA(I)
         E(I)=E(I)-DELTA(I)
360      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
C
C     test for convergence of the iteration
      DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      IF (DELNRM .LE. 100.D0*UROUND*PNORM) GO TO 375
      IF (M .GT. 0) GO TO 365
         OLDNRM = DELNRM
         GO TO 367
365   RATE = (DELNRM/OLDNRM)**(1.0D0/DFLOAT(M))
      IF (RATE .GT. 0.90D0) GO TO 370
      S = RATE/(1.0D0 - RATE)
367   IF (S*DELNRM .LE. 0.33D0) GO TO 375
C
C     the corrector has not yet converged.
C     update m and test whether the
C     maximum number of iterations have
C     been tried.
      M=M+1
      IF(M.GE.MAXIT)GO TO 370
C
C     evaluate the residual
C     and go back to do another iteration
      IWM(LNRE)=IWM(LNRE)+1
      IRES = 0
      CALL RES(X,Y,YPRIME,DELTA,IRES,
     *  RPAR,IPAR)
      IF (IRES .LT. 0) GO TO 380
      GO TO 350
C
C
C     the corrector failed to converge in maxit
C     iterations. if the iteration matrix
C     is not current,re-do the step with
C     a new iteration matrix.
370   CONTINUE
      IF(ITRACE .GE. 1)WRITE(IDEV,371)
371   FORMAT(' CONVERGENCE FAILURE 1')
      IF(JCALC.EQ.0)GO TO 380
      JCALC=-1
      GO TO 300
C
C
C     the iteration has converged.  if nonnegativity of solution is
C     required, set the solution nonnegative, if the perturbation
C     to do it is small enough.  if the change is too large, then
C     consider the corrector iteration to have failed.
375   IF(NONNEG .EQ. 0) GO TO 390
      DO 377 I = 1,NEQ
377      DELTA(I) = DMIN1(Y(I),0.0D0)
      DELNRM = DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      IF(DELNRM .GT. 0.33D0) GO TO 380
      DO 378 I = 1,NEQ
378      E(I) = E(I) - DELTA(I)
      GO TO 390
C
C
C     exits from block 3
C     no convergence with current iteration
C     matrix,or singular iteration matrix
380   CONVGD= .FALSE.
      IF(ITRACE .GE. 1)WRITE(IDEV,381)
381   FORMAT(' CONVERGENCE FAILURE 2')
390   JCALC = 1
      IF(.NOT.CONVGD)GO TO 600
C
C
C
C
C
C-----------------------------------------------------------------------
C     block 4
C     estimate the errors at orders k,k-1,k-2
C     as if constant stepsize was used. estimate
C     the local error at order k and test
C     whether the current step is successful.
C-----------------------------------------------------------------------
C
C     estimate errors at orders k,k-1,k-2
      ENORM = DDANRM(NEQ,E,WT,RPAR,IPAR)
      ERK = SIGMA(K+1)*ENORM
      TERK = FLOAT(K+1)*ERK
      EST = ERK
      KNEW=K
      IF(K .EQ. 1)GO TO 430
      DO 405 I = 1,NEQ
405     DELTA(I) = PHI(I,KP1) + E(I)
      ERKM1=SIGMA(K)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      TERKM1 = FLOAT(K)*ERKM1
      IF(K .GT. 2)GO TO 410
      IF(TERKM1 .LE. 0.5*TERK)GO TO 420
      GO TO 430
410   CONTINUE
      DO 415 I = 1,NEQ
415     DELTA(I) = PHI(I,K) + DELTA(I)
      ERKM2=SIGMA(K-1)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      TERKM2 = FLOAT(K-1)*ERKM2
      IF(DMAX1(TERKM1,TERKM2).GT.TERK)GO TO 430
C     lower the order
420   CONTINUE
      KNEW=K-1
      EST = ERKM1
C
C
C     calculate the local error for the current step
C     to see if the step was successful
430   CONTINUE
      ERR = CK * ENORM
      IF(ITRACE .GE. 1)WRITE(IDEV,431)ERR
431   FORMAT(' SCALED LOCAL ERROR IS ',D12.3)
      IF(ERR .GT. 1.0D0)GO TO 600
C
C
C
C
C
C-----------------------------------------------------------------------
C     block 5
C     the step is successful. determine
C     the best order and stepsize for
C     the next step. update the differences
C     for the next step.
C-----------------------------------------------------------------------
      IDID=1
      IWM(LNST)=IWM(LNST)+1
      KDIFF=K-KOLD
      KOLD=K
      HOLD=H
C
C
C     estimate the error at order k+1 unless%
C        already decided to lower order, or
C        already using maximum order, or
C        stepsize not constant, or
C        order raised in previous step
      IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1
      IF(IPHASE .EQ. 0)GO TO 545
      IF(KNEW.EQ.KM1)GO TO 540
      IF(K.EQ.IWM(LMXORD)) GO TO 550
      IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550
      DO 510 I=1,NEQ
510      DELTA(I)=E(I)-PHI(I,KP2)
      ERKP1 = (1.0D0/DFLOAT(K+2))*DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      TERKP1 = FLOAT(K+2)*ERKP1
      IF(K.GT.1)GO TO 520
      IF(TERKP1.GE.0.5D0*TERK)GO TO 550
      GO TO 530
520   IF(TERKM1.LE.DMIN1(TERK,TERKP1))GO TO 540
      IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550
      TEMP2=K+1
      R=  (2.0D0*ERK  +0.0001D0)**(-1.0D0/TEMP2)
     1  / (2.0D0*ERKP1+0.0001D0)**(-1.0D0/(TEMP2+1.D0))
      IF(R .GE. 0.9D0)GOTO 550
C
C     raise order
530   K=KP1
      IF(ITRACE .GE. 1)WRITE(IDEV,531)
531   FORMAT(' ORDER RAISE CONSIDERED')
      EST = ERKP1
      GO TO 550
C
C     lower order
540   K=KM1
      EST = ERKM1
      GO TO 550
C
C     if iphase = 0, increase order by one and multiply stepsize by
C     factor two
545   K = KP1
      IF(ITRACE .GE. 1)WRITE(IDEV,546)
546   FORMAT(' ORDER RAISE WITH IPHASE =0')
      HNEW = H*2.0D0
      H = HNEW
      GO TO 575
C
C
C     determine the appropriate stepsize for
C     the next step.
550   HNEW=H
      TEMP2=K+1
      R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2)
      IF(R .LT. 2.0D0) GO TO 555
      HNEW = 2.0D0*H
      GO TO 560
555   IF(R .GT. 1.0D0) GO TO 560
      R = DMAX1(0.5D0,DMIN1(0.9D0,R))
      HNEW = H*R
560   H=HNEW
C
C
C     update differences for next step
575   CONTINUE
      IF(KOLD.EQ.IWM(LMXORD))GO TO 585
      DO 580 I=1,NEQ
580      PHI(I,KP2)=E(I)
585   CONTINUE
      DO 590 I=1,NEQ
590      PHI(I,KP1)=PHI(I,KP1)+E(I)
      DO 595 J1=2,KP1
         J=KP1-J1+1
         DO 595 I=1,NEQ
595      PHI(I,J)=PHI(I,J)+PHI(I,J+1)
      RETURN
C
C
C
C
C
C-----------------------------------------------------------------------
C     block 6
C     the step is unsuccessful. restore x,psi,phi
C     determine appropriate stepsize for
C     continuing the integration, or exit with
C     an error flag if there have been many
C     failures.
C-----------------------------------------------------------------------
600   IPHASE = 1
C
C     restore x,phi,psi
      X=XOLD
      IF(KP1.LT.NSP1)GO TO 630
      DO 620 J=NSP1,KP1
         TEMP1=1.0D0/BETA(J)
         DO 610 I=1,NEQ
610         PHI(I,J)=TEMP1*PHI(I,J)
620      CONTINUE
630   CONTINUE
      DO 640 I=2,KP1
640      PSI(I-1)=PSI(I)-H
C
C
C     test whether failure is due to corrector iteration
C     or error test
      IF(CONVGD)GO TO 660
      IWM(LCTF)=IWM(LCTF)+1
C
C
C     the newton iteration failed to converge with
C     a current iteration matrix.  determine the cause
C     of the failure and take appropriate action.
      IF(IER.EQ.0)GO TO 650
C
C     the iteration matrix is singular. reduce
C     the stepsize by a factor of 4. if
C     this happens three times in a row on
C     the same step, return with an error flag
      NSF=NSF+1
      R = 0.25D0
      H=H*R
      IF (NSF .LT. 3 .AND. DABS(H) .GE. HMIN) GO TO 690
      IDID=-8
      GO TO 675
C
C
C     the newton iteration failed to converge for a reason
C     other than a singular iteration matrix.  if ires = -2, then
C     return.  otherwise, reduce the stepsize and try again, unless
C     too many failures have occured.
650   CONTINUE
      IF (IRES .GT. -2) GO TO 655
      IDID = -11
      GO TO 675
655   NCF = NCF + 1
      R = 0.25D0
      H = H*R
      IF (NCF .LT. 10 .AND. DABS(H) .GE. HMIN) GO TO 690
      IDID = -7
      IF (IRES .LT. 0) IDID = -10
      IF (NEF .GE. 3) IDID = -9
      GO TO 675
C
C
C     the newton scheme converged,and the cause
C     of the failure was the error estimate
C     exceeding the tolerance.
660   NEF=NEF+1
      IEFAIL = IEFAIL + 1
      IF(ITRACE .GE.1)WRITE(IDEV,661)
661   FORMAT(' ERROR TEST FAILED')
      IWM(LETF)=IWM(LETF)+1
      IF (NEF .GT. 1) GO TO 665
C
C     on first error test failure, keep current order or lower
C     order by one.  compute new stepsize based on differences
C     of the solution.
      K = KNEW
      TEMP2 = K + 1
      R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2)
      R = DMAX1(0.25D0,DMIN1(0.9D0,R))
      H = H*R
      IF (DABS(H) .GE. HMIN) GO TO 690
      IDID = -6
      GO TO 675
C
C     on second error test failure, use the current order or
C     decrease order by one.  reduce the stepsize by a factor of
C     one quarter.
665   IF (NEF .GT. 2) GO TO 670
      K = KNEW
      H = 0.25D0*H
      IF (DABS(H) .GE. HMIN) GO TO 690
      IDID = -6
      GO TO 675
C
C     on third and subsequent error test failures, set the order to
C     one and reduce the stepsize by a factor of one quarter
670   K = 1
      H = 0.25D0*H
      IF (DABS(H) .GE. HMIN) GO TO 690
      IDID = -6
      GO TO 675
C
C
C
C
C     for all crashes, restore y to its last value,
C     interpolate to find yprime at last x, and return
675   CONTINUE
      CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI)
      RETURN
C
C
C     go back and try this step again
690   GO TO 200
C
C------end of subroutine dastep------
      END
      SUBROUTINE DDASLV(NEQ,DELTA,WM,IWM)
C
C***BEGIN PROLOGUE  DDASLV
C***REFER TO  DDASSL
C***ROUTINES CALLED DGESL,DGBSL
C***COMMON BLOCKS    DDA001
C***DATE WRITTEN   830315   (YYMMDD)
C***REVISION DATE  830315   (YYMMDD)
C***END PROLOGUE  DDASLV
C-----------------------------------------------------------------------
C     this routine manages the solution of the linear
C     system arising in the newton iteration.
C     matrices and real temporary storage and
C     real information are stored in the array wm.
C     integer matrix information is stored in
C     the array iwm.
C     for a dense matrix, the linpack routine
C     dgesl is called.
C     for a banded matrix,the linpack routine
C     dgbsl is called.
C-----------------------------------------------------------------------
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION DELTA(1),WM(1),IWM(1)
      COMMON/DDA001/NPD,NTEMP,LML,LMU,
     *  LMXORD,LMTYPE,
     *  LNST,LNRE,LNJE,LETF,LCTF,LIPVT
      COMMON /PSTATS/ ID(3), IS
      IS = IS + 1
C
      MTYPE=IWM(LMTYPE)
      GO TO(100,100,300,400,400),MTYPE
C
C     dense matrix
100   CALL DGESL(WM(NPD),NEQ,NEQ,IWM(LIPVT),DELTA,0)
      RETURN
C
C     dummy section for mtype=3
300   CONTINUE
      RETURN
C
C     banded matrix
400   MEBAND=2*IWM(LML)+IWM(LMU)+1
      CALL DGBSL(WM(NPD),MEBAND,NEQ,IWM(LML),
     *  IWM(LMU),IWM(LIPVT),DELTA,0)
      RETURN
C------end of subroutine ddaslv------
      END
      SUBROUTINE DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H,
     *  IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR,IPAR)
C
C***BEGIN PROLOGUE  DDAJAC
C***REFER TO  DDASSL
C***ROUTINES CALLED  DGEFA,DGBFA
C***COMMON BLOCKS    DDA001
C***DATE WRITTEN   830315   (YYMMDD)
C***REVISION DATE  830315   (YYMMDD)
C***END PROLOGUE  DDAJAC
C-----------------------------------------------------------------------
C     this routine computes the iteration matrix
C     pd=dg/dy+cj*dg/dyprime (where g(x,y,yprime)=0).
C     here pd is computed by the user-supplied
C     routine jac if iwm(mtype) is 1 or 4, and
C     it is computed by numerical finite differencing
C     if iwm(mtype)is 2 or 5
C     the parameters have the following meanings.
C     y        = array containing predicted values
C     yprime   = array containing predicted derivatives
C     delta    = residual evaluated at (x,y,yprime)
C                (used only if iwm(mtype)=2 or 5)
C     cj       = scalar parameter defining iteration matrix
C     h        = current stepsize in integration
C     ier      = variable which is .ne. 0
C                if iteration matrix is singular,
C                and 0 otherwise.
C     wt       = vector of weights for computing norms
C     e        = work space (temporary) of length neq
C     wm       = real work space for matrices. on
C                output it contains the lu decomposition
C                of the iteration matrix.
C     iwm      = integer work space containing
C                matrix information
C     res      = name of the external user-supplied routine
C                to evaluate the residual function g(x,y,yprime)
C     ires     = flag which is equal to zero if no illegal values
C                in res, and less than zero otherwise.  (if ires
C                is less than zero, the matrix was not completed)
C                in this case (if ires .lt. 0), then ier = 0.
C     uround   = the unit roundoff error of the machine being used.
C     jac      = name of the external user-supplied routine
C                to evaluate the iteration matrix (this routine
C                is only used if iwm(mtype) is 1 or 4)
C-----------------------------------------------------------------------
C
      IMPLICIT REAL*8(A-H,O-Z)
      EXTERNAL RES,JAC
      DIMENSION Y(1),YPRIME(1),DELTA(1),WT(1),E(1)
      DIMENSION WM(1),IWM(1),RPAR(1),IPAR(1)
      COMMON/DDA001/NPD,NTEMP,
     *  LML,LMU,LMXORD,LMTYPE,
     *  LNST,LNRE,LNJE,LETF,LCTF,LIPVT
C
      IER = 0
      NPDM1=NPD-1
      MTYPE=IWM(LMTYPE)
      GO TO (100,200,300,400,500),MTYPE
C
C
C     dense user-supplied matrix
100   LENPD=NEQ*NEQ
      DO 110 I=1,LENPD
110      WM(NPDM1+I)=0.0D0
      CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR)
      GO TO 230
C
C
C     dense finite-difference-generated matrix
200   IRES=0
      NROW=NPDM1
      SQUR = DSQRT(UROUND)
      DO 210 I=1,NEQ
         DEL=SQUR*DMAX1(DABS(Y(I)),DABS(H*YPRIME(I)),
     *     DABS(WT(I)))
         DEL=DSIGN(DEL,H*YPRIME(I))
         DEL=(Y(I)+DEL)-Y(I)
         YSAVE=Y(I)
         YPSAVE=YPRIME(I)
         Y(I)=Y(I)+DEL
         YPRIME(I)=YPRIME(I)+CJ*DEL
         CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR)
         IF (IRES .LT. 0) RETURN
         DELINV=1.0D0/DEL
         DO 220 L=1,NEQ
220      WM(NROW+L)=(E(L)-DELTA(L))*DELINV
      NROW=NROW+NEQ
      Y(I)=YSAVE
      YPRIME(I)=YPSAVE
210   CONTINUE
C
C
C     do dense-matrix lu decomposition on pd
230      CALL DGEFA(WM(NPD),NEQ,NEQ,IWM(LIPVT),IER)
      RETURN
C
C
C     dummy section for iwm(mtype)=3
300   RETURN
C
C
C     banded user-supplied matrix
400   LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ
      DO 410 I=1,LENPD
410      WM(NPDM1+I)=0.0D0
      CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR)
      MEBAND=2*IWM(LML)+IWM(LMU)+1
      GO TO 550
C
C
C     banded finite-difference-generated matrix
500   MBAND=IWM(LML)+IWM(LMU)+1
      MBA=MIN0(MBAND,NEQ)
      MEBAND=MBAND+IWM(LML)
      MEB1=MEBAND-1
      MSAVE=(NEQ/MBAND)+1
      ISAVE=NTEMP-1
      IPSAVE=ISAVE+MSAVE
      IRES=0
      SQUR=DSQRT(UROUND)
      DO 540 J=1,MBA
         DO 510 N=J,NEQ,MBAND
          K= (N-J)/MBAND + 1
          WM(ISAVE+K)=Y(N)
          WM(IPSAVE+K)=YPRIME(N)
          DEL=SQUR*DMAX1(DABS(Y(N)),DABS(H*YPRIME(N)),
     *      DABS(WT(N)))
          DEL=DSIGN(DEL,H*YPRIME(N))
          DEL=(Y(N)+DEL)-Y(N)
          Y(N)=Y(N)+DEL
510       YPRIME(N)=YPRIME(N)+CJ*DEL
      CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR)
      IF (IRES .LT. 0) RETURN
      DO 530 N=J,NEQ,MBAND
          K= (N-J)/MBAND + 1
          Y(N)=WM(ISAVE+K)
          YPRIME(N)=WM(IPSAVE+K)
          DEL=SQUR*DMAX1(DABS(Y(N)),DABS(H*YPRIME(N)),
     *      DABS(WT(N)))
          DEL=DSIGN(DEL,H*YPRIME(N))
          DEL=(Y(N)+DEL)-Y(N)
          DELINV=1.0D0/DEL
          I1=MAX0(1,(N-IWM(LMU)))
          I2=MIN0(NEQ,(N+IWM(LML)))
          II=N*MEB1-IWM(LML)+NPDM1
          DO 520 I=I1,I2
520         WM(II+I)=(E(I)-DELTA(I))*DELINV
530      CONTINUE
540   CONTINUE
C
C
C     do lu decomposition of banded pd
550   CALL DGBFA(WM(NPD),MEBAND,NEQ,
     *    IWM(LML),IWM(LMU),IWM(LIPVT),IER)
      RETURN
C------end of subroutine ddajac------
      END
      SUBROUTINE DDATRP(X,XOUT,YOUT,YPOUT,NEQ,KOLD,PHI,PSI)
C
C***BEGIN PROLOGUE  DDATRP
C***REFER TO  DDASSL
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   830315   (YYMMDD)
C***REVISION DATE  830315   (YYMMDD)
C***END PROLOGUE  DDATRP
C
C-----------------------------------------------------------------------
C     the methods in subroutine dastep use polynomials
C     to approximate the solution. ddatrp approximates the
C     solution and its derivative at time xout by evaluating
C     one of these polynomials,and its derivative,there.
C     information defining this polynomial is passed from
C     dastep, so ddatrp cannot be used alone.
C
C     the parameters are%
C     x     the current time in the integration.
C     xout  the time at which the solution is desired
C     yout  the interpolated approximation to y at xout
C           (this is output)
C     ypout the interpolated approximation to yprime at xout
C           (this is output)
C     neq   number of equations
C     kold  order used on last successful step
C     phi   array of scaled divided differences of y
C     psi   array of past stepsize history
C-----------------------------------------------------------------------
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION YOUT(1),YPOUT(1)
      DIMENSION PHI(NEQ,1),PSI(1)
      KOLDP1=KOLD+1
      TEMP1=XOUT-X
      DO 10 I=1,NEQ
         YOUT(I)=PHI(I,1)
10       YPOUT(I)=0.0D0
      C=1.0D0
      D=0.0D0
      GAMMA=TEMP1/PSI(1)
      DO 30 J=2,KOLDP1
         D=D*GAMMA+C/PSI(J-1)
         C=C*GAMMA
         GAMMA=(TEMP1+PSI(J-1))/PSI(J)
         DO 20 I=1,NEQ
            YOUT(I)=YOUT(I)+C*PHI(I,J)
20          YPOUT(I)=YPOUT(I)+D*PHI(I,J)
30       CONTINUE
      RETURN
C
C------end of subroutine ddatrp------
      END
      SUBROUTINE DDAINI(X,Y,YPRIME,NEQ,
     *   RES,JAC,H,WT,IDID,RPAR,IPAR,
     *   PHI,DELTA,E,WM,IWM,
     *   HMIN,UROUND,NONNEG)
C
C***BEGIN PROLOGUE  DDAINI
C***REFER TO  DDASSL
C***ROUTINES CALLED  DDANRM,DDAJAC,DDASLV
C***COMMON BLOCKS    DDA001
C***DATE WRITTEN   830315   (YYMMDD)
C***REVISION DATE  830315   (YYMMDD)
C***END PROLOGUE DDAINI
C
C-------------------------------------------------------
C     ddaini takes one step of size h or smaller
C     with the backward euler method, to
C     find yprime at the initial time x. a modified
C     damped newton iteration is used to
C     solve the corrector iteration.
C
C     the initial guess yprime is used in the
C     prediction, and in forming the iteration
C     matrix, but is not involved in the
C     error test. this may have trouble
C     converging if the initial guess is no
C     good, or if g(xy,yprime) depends
C     nonlinearly on yprime.
C
C     the parameters represent:
C     x --         independent variable
C     y --         solution vector at x
C     yprime --    derivative of solution vector
C     neq --       number of equations
C     h --         stepsize. imder may use a stepsize
C                  smaller than h.
C     wt --        vector of weights for error
C                  criterion
C     idid --      completion code with the following meanings
C                  idid= 1 -- yprime was found successfully
C                  idid=-12 -- ddaini failed to find yprime
C     rpar,ipar -- real and integer parameter arrays
C                  that are not altered by ddaini
C     phi --       work space for ddaini
C     delta,e --   work space for ddaini
C     wm,iwm --    real and integer arrays storing
C                  matrix information
C
C-----------------------------------------------------------------
C
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL CONVGD
      DIMENSION Y(1),YPRIME(1),WT(1)
      DIMENSION PHI(NEQ,1),DELTA(1),E(1)
      DIMENSION WM(1),IWM(1)
      DIMENSION RPAR(1),IPAR(1)
      EXTERNAL RES,JAC
      COMMON/SDEV2/ ITRACE, IDEV
      COMMON/DDA001/NPD,NTEMP,
     *  LML,LMU,LMXORD,LMTYPE,
     *  LNST,LNRE,LNJE,LETF,LCTF,LIPVT
C
      DATA MAXIT/12/,MJAC/8/
      DATA DAMP/0.75D0/
C
C
C
C---------------------------------------------------
C     block 1.
C     initializations.
C---------------------------------------------------
C
      IDID=1
      NEF=0
      NCF=0
      NSF=0
      YNORM=DDANRM(NEQ,Y,WT,RPAR,IPAR)
C
C     save y and yprime in phi
      DO 100 I=1,NEQ
         PHI(I,1)=Y(I)
100      PHI(I,2)=YPRIME(I)
C
C
C
C----------------------------------------------------
C     block 2.
C     do one backward euler step.
C----------------------------------------------------
C
C     set up for start of corrector iteration
200   CJ=1.0D0/H
      XNEW=X+H
C
C     predict solution and derivative
C
      DO 250 I=1,NEQ
250     Y(I)=Y(I)+H*YPRIME(I)
C
      JCALC=-1
      M=0
      CONVGD=.TRUE.
C
C
C     corrector loop.
300   IWM(LNRE)=IWM(LNRE)+1
      IRES=0
C
      CALL RES(XNEW,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
      IF (IRES.LT.0) GO TO 430
C
C
C     evaluate the iteration matrix
      IF (JCALC.NE.-1) GO TO 310
      IWM(LNJE)=IWM(LNJE)+1
      JCALC=0
      CALL DDAJAC(NEQ,XNEW,Y,YPRIME,DELTA,CJ,H,
     *   IER,WT,E,WM,IWM,RES,IRES,
     *   UROUND,JAC,RPAR,IPAR)
      IF(ITRACE .GE. 1)WRITE(IDEV,301)
301   FORMAT(' JAC EVAL IN DDAINI ')
C
      S=1000000.D0
      IF (IRES.LT.0) GO TO 430
      IF (IER.NE.0) GO TO 430
      NSF=0
C
C
C
C
C     multiply residual by damping factor
310   CONTINUE
      DO 320 I=1,NEQ
320      DELTA(I)=DELTA(I)*DAMP
C
C
C     compute a new iterate (back substitution)
C     store the correction in delta
C
      CALL DDASLV(NEQ,DELTA,WM,IWM)
C
C
C     update y and yprime
C
      DO 330 I=1,NEQ
         Y(I)=Y(I)-DELTA(I)
330      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
C
C
C     test for convergence of the iteration.
C
      DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      IF (DELNRM.LE.100.D0*UROUND*YNORM)
     *   GO TO 400
C
      IF (M.GT.0) GO TO 340
         OLDNRM=DELNRM
         GO TO 350
C
340   RATE=(DELNRM/OLDNRM)**(1.0D0/DFLOAT(M))
      IF (RATE.GT.0.90D0) GO TO 430
      S=RATE/(1.0D0-RATE)
      IF(ITRACE .GE. 2)WRITE(IDEV,341)RATE, DELNRM, S
341   FORMAT(' RATE= ',D11.3,' DELNRM=',D11.3,' S = ',D11.3)
C
350   IF (S*DELNRM .LE. 0.33D0) GO TO 400
C
C
C     the corrector has not yet converged. update
C     m and and test whether the maximum
C     number of iterations have been tried.
C     every mjac iterations, get a new
C     iteration matrix.
C
      M=M+1
      IF (M.GE.MAXIT) GO TO 430
C
      IF ((M/MJAC)*MJAC.EQ.M) JCALC=-1
C
      GO TO 300
C
C
C
C     the iteration has converged.
C     check nonnegativity constraints
400   IF (NONNEG.EQ.0) GO TO 450
      DO 410 I=1,NEQ
410      DELTA(I)=DMIN1(Y(I),0.0D0)
C
      DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
      IF (DELNRM.GT.0.33D0) GO TO 430
C
      DO 420 I=1,NEQ
         Y(I)=Y(I)-DELTA(I)
420      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
      GO TO 450
C
C
C     exits from corrector loop.
430   CONVGD=.FALSE.
450   IF (.NOT.CONVGD) GO TO 600
C
C
C
C-----------------------------------------------------
C     block 3.
C     the corrector iteration converged.
C     do error test.
C-----------------------------------------------------
C
C
      DO 510 I=1,NEQ
         E(I)=Y(I)-PHI(I,1)
510   CONTINUE
C
      ERR=DDANRM(NEQ,E,WT,RPAR,IPAR)
C
      IF (ERR.LE.1.0D0) RETURN
      IF(ITRACE .GE. 1)WRITE(IDEV,511)ERR
511   FORMAT(' SCALED LOCAL ERROR IN INITIAL STEP IS',D11.3)
      DO 512 I = 1,NEQ
512    YPRIME(I) = 0.0D0
      RETURN
C
C--------------------------------------------------------
C     block 4.
C     the backward euler step failed. restore y
C     and yprime to their original values.
C     reduce stepsize and try again, if
C     possible.
C---------------------------------------------------------
C
C
600   CONTINUE
      DO 610 I=1,NEQ
         Y(I)=PHI(I,1)
610      YPRIME(I)=PHI(I,2)
C
      IF (CONVGD) GO TO 640
      IF (IER.EQ.0) GO TO 620
         NSF=NSF+1
         H=H*0.25D0
         IF (NSF.LT.3.AND.DABS(H).GE.HMIN) GO TO 690
         IDID=-12
         RETURN
620   IF (IRES.GT.-2) GO TO 630
         IDID=-12
         RETURN
630   NCF=NCF+1
      H=H*0.25D0
      IF (NCF.LT.10.AND.DABS(H).GE.HMIN) GO TO 690
         IDID=-12
         RETURN
C
640   NEF=NEF+1
      R=0.90D0/(2.0D0*ERR+0.0001D0)
      R=DMAX1(0.1D0,DMIN1(0.5D0,R))
      H=H*R
      IF (DABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690
         IDID=-12
         RETURN
690      GO TO 200
C
C-------------end of subroutine ddaini----------------------
      END
      DOUBLE PRECISION FUNCTION DDANRM(NEQ,V,WT,RPAR,IPAR)
C
C***BEGIN PROLOGUE  DDANRM
C***REFER TO  DDASSL
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   830315   (YYMMDD)
C***REVISION DATE  830315   (YYMMDD)
C***END PROLOGUE  DDANRM
C-----------------------------------------------------------------------
C     this function routine computes the weighted
C     root-mean-square norm of the vector of length
C     neq contained in the array v,with weights
C     contained in the array wt of length neq.
C        ddanrm=sqrt((1/neq)*sum(v(i)/wt(i))**2)
C-----------------------------------------------------------------------
C
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION V(NEQ),WT(NEQ)
      DIMENSION RPAR(1),IPAR(1)
      DDANRM = 0.0D0
      VMAX = 0.0D0
      DO 10 I = 1,NEQ
10      IF(DABS(V(I)/WT(I)) .GT. VMAX) VMAX = DABS(V(I)/WT(I))
      IF(VMAX .LE. 0.0D0) GO TO 30
      SUM = 0.0D0
      DO 20 I = 1,NEQ
20      SUM = SUM + ((V(I)/WT(I))/VMAX)**2
C     DDANRM = VMAX*DSQRT(SUM)
      DDANRM = VMAX*DSQRT(SUM/DFLOAT(NEQ))
30    CONTINUE
      RETURN
C------end of function ddanrm------
      END
      SUBROUTINE XERRWV (MSG, NMES, NERR, IERT, NI, I1, I2, NR, R1, R2)
      INTEGER MSG, NMES, NERR, IERT, NI, I1, I2, NR,
     1   I, LUN, LUNIT, MESFLG, NWDS
      DOUBLE PRECISION R1, R2
      DIMENSION MSG(NMES)
C-----------------------------------------------------------------------
C subroutine xerrwv, as given here, constitutes
C a simplified version of the slatec error handling package.
C written by a. c. hindmarsh at lll.  version of january 23, 1980.
C modified by l. r. petzold, april 1982.
C this version is in single precision.
C
C all arguments are input arguments.
C
C msg    = the message (hollerith litteral or integer array).
C nmes   = the length of msg (number of characters).
C nerr   = the error number (not used).
C iert   = the error type..
C          1 means recoverable (control returns to caller).
C          2 means fatal (run is aborted--see note below).
C ni     = number of integers (0, 1, or 2) to be printed with message.
C i1,i2  = integers to be printed, depending on ni.
C nr     = number of reals (0, 1, or 2) to be printed with message.
C r1,r2  = reals to be printed, depending on ni.
C
C note..  this routine is machine-dependent and specialized for use
C in limited context, in the following ways..
C 1. the number of hollerith characters stored per word, denoted
C    by ncpw below, is set in a data statement below.
C 2. the value of nmes is assumed to be at most 60.
C    (multi-line messages are generated by repeated calls.)
C 3. if iert = 2, control passes to the statement   stop
C    to abort the run.  this statement may be machine-dependent.
C 4. r1 and r2 are assumed to be in real and are printed
C    in d21.13 format.
C 5. the data statement below contains default values of
C       mesflg = print control flag..
C                1 means print all messages (the default).
C                0 means no printing.
C       lunit  = logical unit number for messages.
C                the default is 3 (machine-dependent).
C                to change lunit, change the data statement
C                below.
C-----------------------------------------------------------------------
C the following are instructions for installing this routine
C in different machine environments.
C
C to change the default output unit, change the data statement
C below.
C
C for a different number of characters per word, change the
C data statement setting ncpw below.
C alternatives for various computers are shown in comment
C cards.
C
C for a different run-abort command, change the statement following
C statement 100 at the end.
C-----------------------------------------------------------------------
C the following value of ncpw is valid for the cdc-6600 and
C cdc-7600 computers.
C     data ncpw/10/
C the following is valid for the cray-1 computer.
C     data ncpw/8/
C the following is valid for the burroughs 6700 and 7800 computers.
C     data ncpw/6/
C the following is valid for the pdp-10 computer.
C     data ncpw/5/
C the following is valid for the vax computer with 4 bytes per integer,
C and for the ibm-360, ibm-303x, and ibm-43xx computers.
C     data ncpw/4/
C the following is valid for the pdp-11, or vax with 2-byte integers.
C     data ncpw/2/
C----------------------------------------------------------------------
      DIMENSION NFORM(13)
      DATA NFORM(1)/1H(/,NFORM(2)/1H1/,NFORM(3)/1HX/,NFORM(4)/1H,/,
     1  NFORM(7)/1HA/,NFORM(10)/1H,/,NFORM(11)/1HA/,NFORM(13)/1H)/
      DATA NCPW/4/
      DATA MESFLG/1/,LUNIT/4/
C
      IF (MESFLG .EQ. 0) GO TO 100
C get logical unit number. ---------------------------------------------
      LUN = LUNIT
C get number of words in message. --------------------------------------
      NCH = MIN0(NMES,60)
      NWDS = NCH/NCPW
      CALL S88FMT(2,NWDS,NFORM(5))
      CALL S88FMT(2,NCPW,NFORM(8))
      NREM = NCH - NWDS*NCPW
      IF (NREM .GT. 0) NWDS = NWDS + 1
      IF (NREM .LT. 1) NREM = 1
      CALL S88FMT(1,NREM,NFORM(12))
      WRITE(LUN,NFORM) (MSG(I),I=1,NWDS)
      IF (NI .EQ. 1) WRITE (LUN, 20) I1
 20   FORMAT(6X,23HIN ABOVE MESSAGE,  I1 =,I10)
      IF (NI .EQ. 2) WRITE (LUN, 30) I1,I2
 30   FORMAT(6X,23HIN ABOVE MESSAGE,  I1 =,I10,3X,4HI2 =,I10)
      IF (NR .EQ. 1) WRITE (LUN, 40) R1
 40   FORMAT(6X,23HIN ABOVE MESSAGE,  R1 =,D21.13)
      IF (NR .EQ. 2) WRITE (LUN, 50) R1,R2
 50   FORMAT(6X,15HIN ABOVE,  R1 =,D21.13,3X,4HR2 =,D21.13)
C abort the run if iert = 2. -------------------------------------------
 100  IF (IERT .NE. 2) RETURN
      STOP
C----------------------- end of subroutine xerrwv ----------------------
      END
      SUBROUTINE S88FMT(N,IVALUE,IFMT)
C***begin prologue  s88fmt
C***refer to  xerror
C     abstract
C        s88fmt replaces ifmt(1), ... ,ifmt(n) with the
C        characters corresponding to the n least significant
C        digits of ivalue.
C
C     taken from the bell laboratories port library error handler
C     latest revision ---  7 june 1978
C
C***references
C   jones r.e., *slatec common mathematical library error handling
C    package*, sand78-1189, sandia laboratories, 1978.
C***routines called  (none)
C***end prologue  s88fmt
C
      DIMENSION IFMT(N),IDIGIT(10)
      DATA IDIGIT(1),IDIGIT(2),IDIGIT(3),IDIGIT(4),IDIGIT(5),
     1     IDIGIT(6),IDIGIT(7),IDIGIT(8),IDIGIT(9),IDIGIT(10)
     2     /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C***first executable statement  s88fmt
      NT = N
      IT = IVALUE
   10    IF (NT .EQ. 0) RETURN
         INDEX = MOD(IT,10)
         IFMT(NT) = IDIGIT(INDEX+1)
         IT = IT/10
         NT = NT - 1
         GO TO 10
      END
      DOUBLE PRECISION FUNCTION D1MACH(IDUM)
      INTEGER IDUM
      DOUBLE PRECISION U,COMP
      U = 1.0D0
 10   U = U * 0.5D0
      COMP  = 1.0D0 + U
      IF(COMP .NE. 1.0D0) GOTO 10
      D1MACH = U * 2.0D0
      RETURN
      END
C    ----- NEW VERSION --------------------
C   PDECHEB DISCRETISATION MODULE
C   ****************************
C   THIS MODULE DISCRETISES MIXED SYSTEMS OF PARTIAL DIFFERENTIAL
C   EQUATIONS IN ONE SPACE VARIABLE AND ORDINARY DIFFERENTIAL EQUATIONS.
C   THIS IS THE MARK 1 VERSION OF PDECHEB 10TH AUGUST 1987 AS WRITTEN BY
C    DR MARTIN BERZINS
C      DEPARTMENT OF COMPUTER STUDIES
C       THE UNIVERSITY
C        LEEDS LS2 9JT
C   ALL RIGHTS RETAINED.
C   ( DOCUMENTATION MODIFIED ON 25/2/90 )
C   THE CLASS OF EQUATIONS THAT CAN BE HANDLED IS GIVEN BY
C
C                                    .
C   Q (X,T, U, U  ,  U  , U    , V , V )
C    I      -  - X   -T   - XT   -   -
C
C                          -M   M                               .
C                      =  X   (X  R (X,T, U, U  , U   , U  , V, V ))
C                                  I      -  -X   - XT  -T   -  -   X
C     WHERE
C           U = ( U  , ... , U ) TRANSPOSE  AND  I = 1,... , NPDE.
C           -       1         NPDE
C
C     THE P.D.E. FLUX FUNCTION R(.......) IS ASSUMED TO BE CONTINUOUS
C     W.R.T. THE SPACE VARIABLE R BUT THE FUNCTION  Q(.... ) IS
C     ALLOWED TO BE ONLY PIECEWISE CONTINUOUS PROVIDED THAT THE
C     DISCONTINUITIES ARE PLACED AT SPATIAL MESH POINTS.
C     THE OTHER VECTORS ARE DEFINED IN THE SAME WAY AS U EXCEPT THAT
C                                              .       -
C           V = ( V  , ... , V ) TRANSPOSE AND V  IS SIMILARLY DEFD.
C           -      1          NV               -
C
C                 .
C     WHERE V AND V    ARE THE SOLUTION OF A COUPLED SYSTEM OF
C           -     -            ORDINARY  DIFFERENTIAL EQUATIONS OF
C                              DIMENSION NV.
C     IN THE CASE WHEN NV > 0 THIS SYSTEM OF DIFFERENTIAL EQUATIONS IS
C     ASSUMED TO HAVE THE FORM.
C                .
C        FV ( V, V , XI, UI, UI , RI , UI , UI  , ) = 0
C        --   -  -   -   -   - X  -    - T  - XT
C
C                                             .
C     WHERE ALL THE VECTORS APART FROM V  AND V  ARE OF LENGTH NPDE*NXI.
C                                      -      -
C     AND CONTAIN THE VALUES OF THE P.D.E. VARIABLES U , U  , R, U ,U
C                                                         X       T  XT
C     AT THE SPATIAL O.D.E. /P.D.E. COUPLING POINTS DEINED BY
C     THE VECTOR XI(NXI) .
C
C   THE SPATIAL MESH IS BOUNDED BY A AND B  A < X < B.
C   THE BOUNDARY CONDITIONS HAVE THE FORM
C                                 .                       .
C          B (T) R(X,T, U, U , V, V )  = G (T, U , U , V, V)  AT X = A
C           A    -      -  -X  -  -      -A    -   -X  -  -
C  AND
C                                 .                       .
C          B (T) R(X,T, U, U , V, V )  = G (T, U , U , V, V)  AT X = B.
C           B    -      -  -X  -  -      -B    -   -X  -  -
C
C  WHERE   NOT ALL OF THE FUNCTIONS B AND G ARE SET TO ZERO.
C
C  THE INITIAL CONDITIONS ARE GIVEN BY
C          U (X, 0)  = K (X)  AND V(O) = K
C          -           -1         -      -2                     0
C  THE DISCRETISATION METHOD USED BY THIS MODULE IS BASED ON A C  -
C  COLLOCATION  METHOD AND EVALUATES THE P.D.E. FUNCTIONS INBETWEEN
C  THE USER SUPPLIED MESH POINTS . ANY DISCONTINUITIES IN THE P.D.E.
C  DEFINING FUNCTION  Q MUST THEREFORE BE AT THE USER SUPPLIED
C  BREAK POINTS .
C  REFERENCES
C  ----------
C  BERZINS M. AND DEW P.M.
C  CHEBYSHEV POLYNOMIAL SOFTWARE FOR ELLIPTIC PARABOLIC P.D.ES
C  ACM TRANS. ON MATH. SOFT. 1990 PP XX - YY.
C
C  BERZINS M. AND DEW P.M.
C  A NOTE ON C0 CHEBYSHEV METHODS FOR PARABOLIC EQUATIONS.
C  IMA JOURNAL OF NUMERICAL ANALYSIS (1987) 7, 15-37.
C
C  BERZINS M. AND DEW P.M. DEPT OF COMPUTER STUDIES
C  THE UNIVERSITY , LEEDS , LS2 9JT ,REPORT NO 180 .
C
C----------------------------------------------------------------------
C
C   HOW TO USE THIS MODULE
C   **********************
C (1) DECIDE ON THE FORM OF THE SPATIAL DISCRETISATION METHOD TO BE
C     USED. THIS MODULE ALLOWS YOU TO DEFINE A SET OF (NEL + 1) SPATIAL
C     BREAKPOINTS , XBK(I) I = 1,NEL+1 . THESE BREAKPOINTS IN TURN
C     DEFINE NEL SPATIAL ELEMENTS. I.E.
C              XBK(I) =< ELEMENT I =< XBK(I+1).
C     IN THE CASE WHEN THE FUNCTION Q(.....) IN THE P.D.E. DEFINITION
C     HAS DISCONTINIUITIES YOU MUST PLACE A BREAKPOINT AT EACH
C     DISCONTINUITY.
C     PDECHEB  WILL APPROXIMATE THE SOLUTION TO THE P.D.E. IN THE SPACE
C     DIMENSION BY USING A PIECEWISE CHEBYSHEV POLYNOMIAL BETWEEN EACH
C     PAIR OF BREAKPOINTS. THE DEGREE OF THIS POLYNOMIAL IS SPECIFIED
C     BY THE VARIABLE NPOLY WHICH MUST BE GREATER THAN OR
C     EQUAL TO 1. WHEN IT IS 1 THE SPATIAL MESH CONSISTS ONLY OF THE
C     BREAKPOINTS AND A LINEAR POLYNOMIAL IS USED TO APPROXIMATE THE
C     SOLUTION BETWEEN THESE POINTS.
C     THE ONLY  PRE-SET UPPER LIMIT TO THE DEGREE OF POLYNOMIAL THAT
C     CAN BE USED IS A SOME WHAT ARBITRARY LIMIT OF 50.
C
C
C (2) SET NPDE = NUMBER OF P.D.E.S TO BE SOLVED , MUST BE >= 0 .
C     SET NEL  = NUMBER OF SPATIAL ELEMENTS TO BE USED , MUST BE >= 0.
C     DEFINE AN ARRAY OF BREAKPOINTS IN THE DOUBLE PRECISION ARRAY
C     XBK(IBK) WHERE IBK = NEL + 1 AND
C              XBK(I) < XBK(I+1) , I = 1,NEL
C     SET NPOLY TO THE DEGREE OF THE POLYNOMIALIN EACH ELEMENT , > 1 .
C         NOTES ON THE CHOICE OF NPOLY AND XBK(IBK)
C         -----------------------------------------
C         IT SHOULD BE NOTED THAT THE PDECHEB SOFTWARE HAS NO MEANS OF
C         ESTIMATING OR CONTROLLING THE SPATIAL DISCRETISATION ERROR.
C         THE ERROR INCURRED WILL DEPEND ON THE NUMBER AND POSITION
C         OF THE BREAK POINTS AND ON THE DEGREE OF POLYNOMIAL USED.
C         THE GENERAL ADVICE IS USE AS FEW BREAK POINTS AS POSSIBLE
C         AND AS HIGH A DEGREE OF POLYNOMIAL AS SEEMS SENSIBLE FOR
C         THE PROBLEM AT HAND. THE APPROPRIATENESS OF A GIVEN DEGREE
C         OF POLYNOMIAL CAN BE JUDGED BY THE FACT THAT THE HIGHER
C         DEGREE COEFFICIENTS OF THE POLYNOMIAL EXPANSION SHOULD BE
C         SMALL IN COMPARISON WITH THE LOWER POLYNOMIAL DEGREE.
C         IT SHOULD ALSO BE NOTED THAT THE LOCAL TIME ERROR TOLERANCES
C         ( THE PARAMETERS RTOL AND ATOL - SEE SECTION 5 BELOW)
C         PASSED TO THE DASSL CODE  SHOULD BE AN ORDER OF MAGNITUDE
C         SMALLER THAN THE EXPECTED SPATIAL ERROR. INEVITABLY THESE
C         AREAS OF UNCERTAINTY MEAN THAT SOME EXPERIMENTATION WITH
C         A GIVEN PROBLEM IS NECESSARY BEFORE AN CONFIDENCE CAN BE
C         PLACED IN THE NUMERICAL RESULTS.
C
C
C     SET M FOR SPACE CO-ORDINATE TYPE
C         = 0 FOR CARTESIAN,  = 1 FOR CYLINDRICAL, = 2 FOR SPHERICAL
C     SET NV = NUMBER OF O.D.E.S COUPLED TO THE P.D.E.S
C     SET NXI = NUMBER OF SPACE POINTS WHERE THE O.D.E.S ARE COUPLED
C     SET XI(NXI) TO THE VALUES OF THE COUPLING POINTS
C     FOR USE BY THE ROUTINE PDECHB WHICH DEFINES THE O.D.E. SYSTEM
C     BEING SOLVED BY THE INTEGRATOR.
C     SET NPTS = NEL * NPTL-1 , THIS IS THE TOTAL NUMBER OF SPATIAL
C     DISCRETISATION POINTS USED BY THIS MODULE.
C     DECLARE A DOUBLE PRECISION ARRAY X, OF DIMENSION NPTS ; X(NPTS)
C     AND PUT X(1) = XBK(1) = A AND X(NPTS) = XBK(NEL+1) = B
C     WHERE A AND B ARE THE LEFT AND RIGHT EDGES OF THE SPTAIAL MESH.
C     THIS ARRAY WILL BE USED TO RETURN TO YOU THE SPATIAL MESH POINTS
C     USED BY THIS SPATIAL DISCRETISATION MODULE.
C     DECLARE A DOUBLE PRECISION ARRAY OF LENGTH NEQN WHERE
C           NEQN = NPDE * NPTS + NV
C     THAT IS USED TO HOLD THE SOLUTION VECTOR . NEQN IS THE NUMBER OF
C     ORDINARY DIFFERENTIAL EQUATIONS THAT MUST BE PASSED ACROSS TO
C     THE DASSL  PACKAGE . THE SOLUTION TO THIS SYSTEM OF ORDINARY
C     DIFFFERENTIAL EQUATIONS THAT IS GENERATED BY DISCRETISING THE
C     CLASS OF P.D.E.S DEFINED ABOVE IS ORDERED IN ,SAY, U(NEQN) AS
C     FOLLOWS.
C       U(I) , I = (J-1) * NPDE + K , K = 1,...,NPDE , J = 1 ,.. ,NPTS
C            CONTAINS THE SOLUTION FOR P.D.E. K AT MESH POINT X(J).
C       U(L) , L = NPDE*NPTS + L1 , L1 = 1,..., NV
C            CONTAINS THE COUPLED O.D.E. COMPONENT V(L1)
C     DEFINE A DOUBLE PRECISION WORKSPACE OF LENGTH IWK WHERE
C       IWK = NPTL*(3*NPTL + 2 + 7*NPDE + NEL) +NXI*(5*NPDE+1) + NV + 2
C     THIS IS THE WORKSPACE THAT MUST BE PASSED ACROSS TO THE DASSL
C     ROUTINE AS THE WORKSPACE FOR THE O.D.E. RESIDUAL DEFINING ROUTINE
C     PDECHB.
C
C
C
C (3) PROVIDE A SET OF ROUTINES WHICH DESCRIBE THE PRECISE FORM OF THE
C     P.D.E. TO BE SOLVED. FOUR ROUTINES MUST BE PROVIDED AND THE NAMES
C     OF THESE ROUTINES ARE FIXED. THESE ROUTINES ARE:
C
C       SPDEFN : FORMS THE FUNCTIONS Q AND R IN THE P.D.E. DESCRIBED
C                ABOVE. THIS ROUTINE FORMS THE VALUES OF THE FUNCTIONS
C                Q AND R OVER SEVERAL MESHPOINTS SIMULTANEOUSLY.
C                IN FACT AT THE X(NPTL) POINTS IN ONE ELEMENT AT A TIME.
C                THE MESH POINTS USED ARE INTERNALLY
C                GENERATED BY THE DISCRETISATION ROUTINE AND ARE
C                BETWEEN THE USER DEFINED BREAKPOINTS.
C        SBNDR  : FORMS THE FUNCTIONS B AND G ASSOCIATED WITH THE
C                BOUNDARY CONDITIONS FOR THE P.D.E. ABOVE.
C       UVINIT : SUPPLIES THE INITIAL VALUES OF THE P.D.E. PART AND ALSO
C                SUPPLIES THE INITIAL VALUES OF THE O.D.E. PART.
C       SODEFN : SUPPLIES THE ODE RESIDUAL AS DEFINED BY THE FUNCTION
C                FV ABOVE.
C           NOTE: THE P.D.E. SOLUTION VALUES AT THE COUPLING POINTS
C           PASSED INTO SODEFN ARE DEFINED BY POLYNOMIAL INTERPOLATION
C           ON THE VALUES AT THE P.D.E. SPATIAL MESH POINTS.
C
C    N.B. EXAMPLES OF THESE ROUTINES FOR THREE PROBLEMS ARE PROVIDED
C         IN THE EXAMPLE PROBLEMS SECTION BELOW.
C
C
C (4) CALL THE INITIALISATION ROUTINE INICHB, USING THE FORM
C
C     CALL INICHB(NEQN,NPDE,NPTS,X,U,WK,IWK,M,TS,IBAND,ITIME,XBK,
C    *                  IBK,NEL,NPOLY,NV,NXI,XI,IDEV)
C***********************************************************************
C ROUTINE FOR INITIALISATION OF CHEBYSHEV GENERALIZED COLLOCATION METHOD
C
C  PARAMETER LIST
C ----------------
C  NEQN:          EMPTY ON ENTRY, ON EXIT IT CONTAINS THE NUMBER OF
C                 O.D.E.S GENERATED BY THE DISCRETISED FORM OF THE
C                 P.D.E. , GIVEN BY  NPDE*NEL*(NPTL-1) + NPDE + NV.
C
C  NPDE           NUMBER OF PARABOLIC P.D.E.S IN ONE SPACE DIMENSION
C
C  NPTS           NUMBER OF SPATIAL GRID POINTS USED IN M.O.L. SOLUTION.
C                 NOTE THIS SHOULD BE EQUAL TO (NPTL-1)*NEL + 1
C
C  X(NPTS)        EMPTY ARRAY ON ENTRY . ON EXIT THIS ARRAY
C                 CONTAINS THE MESH USED IN SEMI-DISCRETISATION
C
C  M              =0,1,2 IF CARTESIAN CYLINDRICAL OR SPHERICAL POLARS.
C
C  U(NEQN)        SOLUTION VECTOR  EMPTY ON ENTRY CONTAINS INITIAL
C                 VALUES ON EXIT. THIS ARRAY IS ORDERED AS FOLLOWS.
C                 U(1) - U(NPDE*NPTS)      P.D.E. SOLUTION COMPONENTS.
C                 U(NPDE*NPTS+1) - U(NEQN) O.D.E. COMPONENTS THAT ARE
C                 COUPLED TO THE P.D.E.
C
C  WK(IWK)        REAL WORKSPACE USED TO PASS FOUR MATRICES AND VARIOUS
C                 USEFUL VECTORS TO THE O.D.E.FUNCTION CALL ROUTINE
C                 RESID SEE BELOW FOR A DETAILED DESCRIPTION.
C
C   TS            STARTING LEVEL OF TIME INTEGRATION.
C
C   XBK(IBK)      REAL ARRAY OF BREAK POINTS  IBK = NEL +1  WHERE
C                 NEL IS THE NUMBER OF SPATIAL ELEMENTS.
C                      XBK(1) = XLEFT
C                      XBK(I) =< XBK(I+1)  I = 1,...,NEL .
C                      XBK(IBK) = XRIGHT.
C  NEL            THE NUMBER OF SPATIAL ELEMENTS , >= 1
C
C  NPOLY          THE DEGREE OF THE APPROXIMATING POLYNOMIAL USED
C                 BETWEEN EACH PAIR OF BREAKPOINTS .
C  ITIME          THIS MUST BE SET = 1 ON THE CALL OF THIS MODULE
C                 PRIOR TO THE DASSL  PACKAGE BEING CALLED.
C                 ONCE DASSL  HAS RETURNED THIS ROUTINE MAY BE CALLED
C                 WITH ITIME = 2 TO RECOVER THE SPATIAL MESH USED
C                 (THIS IS PLACED IN THE ARRAY X(NPTS) ).
C
C  NV             THE NUMBER OF AUXILARY O.D.E.S THAT ARE COUPLED TO
C                 THE P.D.E.
C  NXI            THE NUMBER OF COUPLING POINTS AT WHICH P.D.E. VALUES
C                 ARE USED TO DEFINE THE O.D.E.S
C
C  XI(NXI)        A VECTOR SPECIFYING THE POSITION OF THESE POINTS.
C                 NOTE THAT THESE POINTS MUST BE DISTINCT FROM THE
C                 BREAK - POINTS .
C
C  IDEV           NUMBER OF OUTPUT CHANNEL ON WHICH ERROR MESSAGES TO
C                 DO WITH THE COLLOCATION DISCRETISATION WILL APPEAR.
C
C
C
C (5) SET TS AND TOUT FOR START AND END INTEGRATION TIMES
C     SET INFO, WORK ARRAYS AS REQUIRED FOR TIME INTEGRATION
C     AND CALL THE DASSLD ROUTINE AS FOLLOWS
C     CALL DDASSL (PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL,
C    *           , IDID, RWORK, LRW, IWORK, LIW, WKRES, IRESWK, DGEJAC)
C
C  DASSL  CODE SOLVES A SYSTEM OF DIFFERENTIAL/ALGEBRAIC EQUATIONS OF
C  THE FORM G(T,Y,YDOT) = 0.
C
C  VALUES FOR Y  AND YPRIME AT THE INITIAL TIME MUST  BE GIVEN AS INPUT
C  THESE VALUES MUST BE CONSISTENT, (THAT IS. IF T,Y,YDOT ARE THE GIVEN
C  INITIAL VALUES, THEY MUST  SATISFY G(T,Y,YDOT) = 0.)
C  THE SUBROUTINE SOLVES THE SYSTEM FROM T TO TOUT. IT IS  EASY TO
C  CONTINUE THE SOLUTION TO GET RESULTS AT ADDITIONAL TOUT. THIS IS THE
C  INTERVAL MODE OF OPERATION. INTERMEDIATE RESULTS CAN ALSO BE
C  OBTAINED EASILY BY USING THE INTERMEDIATE-OUTPUT CAPABILITY.
C
C  ------------AN OVERVIEW OF ARGUMENTS TO DASSL-----------------------
C  THE PARAMETERS ARE
C
C  PDECHB -- THIS IS A SUBROUTINE PROVIDED BY PDECHEB TO DEFINE THE
C            DIFFERENTIAL/ALGEBRAIC SYSTEM
C
C  NEQ --  THE NUMBER OF DIFFERENTIAL/ALGEBRAIC EQUATIONS TO BE SOLVED
C
C  T -- THIS IS THE CURRENT VALUE OF THE INDEPENDENT VARIABLE.
C
C  TOUT -- THIS IS A POINT AT WHICH A SOLUTION IS DESIRED.
C
C  INFO(*) -- THE BASIC TASK OF THE CODE IS TO SOLVE THE System
C             FROM T TO TOUT AND RETURN AN ANSWER AT TOUT. INFO(*) IS
C             INTEGER ARRAY WHICH IS USED TO COMMUNICATE EXACTLY HOW
C             YOU WANT THIS TASK TO BE CARRIED OUT.
C
C  Y(*) -- THIS ARRAY CONTAINS THE SOLUTION  COMPONENTS AT T
C
C  YDOT(*) -- THIS ARRAY CONTAINS THE DERIVATIVES OF Y(*) AT T
C
C  RTOL,ATOL -- THESE QUANTITIES REPRESENT ABSOLUTE AND Relative error
C               TOLERANCES WHICH YOU PROVIDE TO INDICATE HOW ACCURATELY
C               YOU WISH THE SOLUTION TO BE COMPUTED. YOu may choose
C               THEM TO BE BOTH SCALARS OR ELSE BOTH VECtors.
C
C  IDID -- THIS SCALAR QUANTITY IS AN INDICATOR REPORTING WHAT THE CODE
C          YOU MUST MONITOR THIS INTEGER VARIABLE TO DECIDE WHAT ACTION
C          TO TAKE NEXT.
C
C  RWORK(*),LRW -- RWORK(*) IS A REAL WORK ARRAY OF Length lrw which
C                  PROVIDES THE CODE WITH NEEDED STORAGE SPACE.
C
C  IWORK(*),LIW -- IWORK(*) IS AN INTEGER WORK ARRAY OF LENGTH LIW
C                  WHICH PROVIDES THE CODE WITH NEEDED storage space.
C
C  WKRES,IRESWK -- THESE ARE REAL AND INTEGER PARAMETER ARRAYS WHICH
C                  ARE USED TO COMMUNICATE INFORMATION FROM THE
C                  INITIALISATION ROUTINE INICHB TO THE SPATIAL
C                  DISCRETISATION  SUBROUTINE PDECHB.
C
C  DGEJAC -- THIS IS THE NAME OF A DUMMY SUBROUTINE WHICH IS PROVIDED
C            BY THE PDECHEB SOFTWARE. IT MUST BE DECLARED AS EXTERNAL
C            IN THE CALLING PROGRAM.
C
C  QUANTITIES WHICH ARE USED AS INPUT ITEMS ARE
C     NEQ, T Y(*), YDOT(*), TOUT, INFO(*), RTOL, ATOL , RWORK(1),
C     RWORK(2), RWORK(3), LRW, IWORK(1), IWORK(2),IWORK(3),AND LIW.
C
C  QUANTITIES WHICH MAY BE ALTERED BY THE CODE ARE
C     T, Y(*), YDOT(*), INFO(1), RTOL, ATOL, IDID, RWORK(*) AND IWORK(*)
C
C   (6) POST PROCESS THE SOLUTION.
C
C     THE SOLUTION VECTOR RETURNED BY DASSL CAN BE USED FOR POST-
C     PROCESSING IN A NUMBER OF WAYS.
C
C     SPATIAL INTERPOLATION
C     ---------------------
C     THE VECTOR Y(T) RETURNED BY DASSL CONSISTS ONLY OF SOLUTION
C     VALUES AT THE MESH POINTS DEFINED BY INICHB. THE FOLLOWING
C     INTERPOLATION ROUTINE ENABLES SOLUTION VALUES AT OTHER POINTS
C     TO BE OBTAINED.
C
C     SUBROUTINE INTERC(XP,UP,NP,U,NEQ,NPDE,IFLAG,ITYPE,WK,IWK)
C********************************************************************
C
C        SPACE INTERPOLATION ROUTINE FOR POST-PROCESSING OF SOLUTION
C        PRODUCED BY DASSL.
C        THIS ROUTINES PROVIDES VALUES OF THE SOLUTION AND POSSIBLY THE
C        FIRST DERIV IN SPACE AND THE FLUX ON THE MESH XP(NP).
C
C        PARAMETERS
C       --------------
C        NPDE     ON ENTRY MUST CONTAIN NO OF PARABOLIC EQUATIONS
C        NPTS     ON ENTRY MUST CONTAIN THE NUMBER OF SPATIAL
C                 MESH POINTS USED IN TIME INTEGRATION.
C        NP       ON ENTRY MUST CONTAIN THE NUMBER OF SPATIAL
C                 INTERPOLATION POINTS
C        XP(NP)   ARRAY WHICH ON ENTRY
C                 CONTAINS THE SPATIAL INTERPOLATION POINTS
C                 WE ASSUME THAT
C                    XP(I) <  XP(I+1)  ,  I = 1,...,NP-1
C        UP(NPDE,NP,ITYPE)  EMPTY ARRAY FOR THE INTERPOLATED VALUES AT
C                           THE CURRENT TIME LEVEL. THE VALUES OF THIS
C                           ARRAY ON EXIT DEPEND ON THE PARAMETER ITYPE.
C        U(NPDE,NPTS) THE CURRENT SOLUTION VECTOR COMPUTED BY THE ODE
C                  TIME INTEGRATOR MUST BE SUPPLIED IN THIS VECTOR.
C        IFLAG          ERROR FLAG       = 0 ON SUCCESSFUL RETURN
C                                        = 1 IF EXTRAPOLATION TRIED.
C                                        = 2 IF WORKSPACE NOT INITIAL
C                                               ISED ON ENTRY BY INICHB.
C                                        = 3 ILLEGAL VALUE OF ITYPE.
C        ITYPE = 1  ONLY THE SOLUTION IS OUTPUT IN THE ARRAY UP
C                   UP(J,K,1) HOLDS U(XP(K),T) FOR PDE J
C                2  AS FOR 1 BUT THE FIRST DERIV IS ALSO OUTPUT.
C                   UP(J,K,2) HOLDS D/DX U(XP(K),T).
C
C        WK(IWK) THE WORKSPACE USED BY THE CHEBYSHEV METHOD. THIS
C                MUST BE THE WORKSPACE INITIALISED BY INICHB.
C
C
C       !*********************************************************!
C       ! IN THE CASE WHEN THE EXACT SOLUTION IS NOT KNOWN IT MAY !
C       ! STILL BE NECESSARY TO SUPPLY A DUMMY ROUTINE EXACT TO   !
C       ! SATISFY LOADER REQUIREMENTS (SEE THE NEXT SECTION FOR A !
C       ! DESCRIPTION OF  EXACT.                                  !
C       !*********************************************************!
C
C     ESTIMATING THE ERROR WHEN THE EXACT SOLUTION IS KNOWN.
C     ------------------------------------------------------
C     THIS CAN BE DONE BY THE FOLLOWING CALL
C
C     CALL ERROR(U,NPDE,NPTS,X,M,ENORM,GERR,T,RELERR,ABSERR,
C    *                 ITRACE,RWK,IWK)
C
C**********************************************************************
C       THE FOLLOWING ROUTINE COMPUTES THE ERROR ENORM IN THE NUMERICAL
C       SOLUTION BY USING A COMBINATION OF THE L2 FUNCTION AND VECTOR
C       NORMS. GERR IS THE MAXIMUM ERROR AT THE GRID POINTS
C       THE EXACT SOLUTION IS ASSUMED TO BE GIVEN BY THE USER PROVIDED
C                SUBROUTINE EXACT(T,NPDE, NP, XP, US)
C                DOUBLE PRECISION US(NPDE, NP),XP(NP),T
C                WHERE US(J,I) ON EXIT CONTAINS THE SOLUTION AT TIME T
C                FOR NPDE J AT THE MESH POINT XP(I)
C
C     PARAMETER LIST
C     --------------
C  U(NEQN)        SOLUTION VECTOR  COMPUTED BY DASSL AT TIME T . ON
C                 ENTRY THIS ARRAY IS ASSUMED TO BE ORDERED AS FOLLOWS
C                 U(1) - U(NPDE*NPTS)      P.D.E. SOLUTION COMPONENTS.
C                 U(NPDE*NPTS+1) - U(NEQN) O.D.E. COMPONENTS THAT ARE
C                 COUPLED TO THE P.D.E.
C
C  NPDE           NUMBER OF PARABOLIC P.D.E.S IN ONE SPACE DIMENSION
C
C  NPTS           NUMBER OF SPATIAL GRID POINTS USED IN M.O.L. SOLUTION.
C                 NOTE THIS SHOULD BE EQUAL TO (NPTL-1)*NEL + 1
C
C  X(NPTS)        ON ENTRY THIS ARRAY MUST
C                 CONTAIN THE MESH USED IN SEMI-DISCRETISATION
C
C  M              =0,1,2 IF CARTESIAN CYLINDRICAL OR SPHERICAL POLARS.
C
C  ENORM          L2 ERROR NORM ESTIMATED BY USING TRAPEZOIDAL RULE
C                 WITH 100 EVENLY SPACED POINTS IS OUTPUT IN ENORM
C
C  GERR           MAXIMUM GRID ERROR OVER THE ARRAY OF SPATIAL GRID
C                 POINTS X(NPTS) IS OUTPUT IN GERR
C
C  T              CURRENT TIME LEVEL OF TIME INTEGRATION ( INPUT).
C
C  RELERR         RELATIVE ERROR TOLERANCE SUPPLIED TO DASSL (RTOL IN
C                 THE CALL TO THAT ROUTINE) (INPUT)
C
C  ABSERR         ABSOLUTE ERROR TOLERANCE SUPPLIED TO DASSL (ATOL IN
C                 THE CALL TO THAT ROUTINE). (INPUT)
C
C  ITRACE         INTEGER TRACE LEVEL SET TO ZERO FOR NO TRACE SET =1
C                 FOR TRACE INFORMATION.   (INPUT)
C
C  RWK(IWK)       REAL WORKSPACE INITIALISED BT INICHB AND PASSED TO
C                 THE D.A.E.FUNCTION CALL ROUTINE  RESID
C                 SEE BELOW FOR A DETAILED DESCRIPTION.(INPUT)
C**********************************************************************
C EXAMPLE  PROBLEM ONE
C SOLUTION OF MOVING BOUNDARY  PROBLEM BY CO-ORDINATE TRANSFORMATION.
C********************************************************************
C  THIS PROBLEM IS THE ONE PHASE STEFAN PROBLEM (HOFFMAN (1977) ) SEE
C  FURZELAND R.M. A COMPARATIVE STUDY OF NUMERICAL METHODS FOR MOVING
C                 BOUNDARY PROBLEMS. J.I.M.A. (1977) ,26, PP 411 - 429.
C  THE PROBLEM HAS  MELTING DUE TO HEAT INPUT AT THE FIXED
C  BOUNDARY . THE P.D.E. IS DEFINED BY THE EQUATIONS
C         U  =  U        0 < Y < S(T) , 0.1 < T < 1
C          T     YY
C            U  = - EXP(T) , Y = 0
C             Y            .
C            U  =  0  AND  S(T) = - U   ON THE MOVING BOUNDARY Y = S(T).
C                                    Y
C  AND THE INITIAL SOLUTION VALUES AT T = 0.1 ARE GIVEN BY THE ANALYTIC
C  SOLUTION
C            U = EXP(T-Y) - 1 , S(T) = T.
C  THE PROBLEM IS REWRITTEN BY USING THE CO-ORDINATE TRANSFORMATION
C  GIVEN BY  X(T)  =  Y / S(T)  . THE EQUATIONS THEN READ
C                      .
C     S * S * U  - S * S  * X * U   =  U     , X IN (0,1).
C              T                 X      XX
C  WITH THE NEUMANN TYPE BOUNDARY CONDITIONS
C                                               .
C     U  = - EXP(T)  AT X=0  AND  U  = - S(T) * S(T) AT X = 1
C      X                           X
C  AND THE O.D.E. COUPLING POINT EQUATION AT X = 1 WHICH IMPLICITLY
C  DEFINES S(T) IS GIVEN  BY
C     U(1,T) = 0
C  THE EXACT SOLUTION IS NOW DEFINED BY
C     U(X,T) = EXP((T - X*S(T))  , S(T) = T
C
C WE SHALL NOW DETAIL THE ROUTINES NEEDED TO DESCRIBE THIS PROBLEM.
C        PROBLEM DESCRIPTION ROUTINES
C       ******************************
C EXACT SOLUTION
C      SUBROUTINE EXACT( TIME, NPDE, NPTS, X, U)
C      ROUTINE FOR P.D.E. EXACT VALUES  (IF KNOWN)
C      INTEGER NPDE, NPTS
C      DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME, P
C      P=DSQRT(2.0D0)*0.5D0
C      DO 10 I = 1,NPTS
C10       U(1,I) = DEXP( TIME * (1 - X(I))) - 1.0D0
C      RETURN
C      END
C      SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV, V)
C      ROUTINE FOR P.D.E. INITIAL VALUES.
C      INTEGER NPDE, NPTS, NV
C      DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME, V(NV)
C      TIME=0.1D0
C      V(1)=0.1D0
C      CALL EXACT(TIME,NPDE,NPTS,X,U)
C      RETURN
C      END
C
C      SUBROUTINE SPDEFN(T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R,
C     1                  NV, V, VDOT, IRES)
C      PROBLEM INTERFACE  FOR THE MOVING BOUNDARY PROBLEM.
C      INTEGER NPTL, NPDE, NV, I, IRES
C      DOUBLE PRECISION X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL), T,
C    1         V(1), VDOT(1), F(NPDE,NPTL), Q(NPDE,NPTL) ,R(NPDE,NPTL),
C    2         UDOT(NPDE,NPTL), UTDX(NPDE,NPTL)
C      DO 10 I = 1,NPTL
C         R(1,I) = DUDX(1,I)
C         Q(1,I) = V(1)*V(1)*UDOT(1,I) -X(I)*VD(I)*DUDX(1,I) * V(1)
C10    CONTINUE
C      RETURN
C      END
C      SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE,
C     1                  LEFT, NV, V, VDOT, IRES)
C  THIS SUBROUTINE PROVIDES THE LEFT AND RIGHT BOUNDARY VALUES
C  FOR THE MOVING BOUNDARY PROBLEM IN THE FORM.
C           BETA(I) * DU/DX(I) = GAMMA(I)
C  WHERE I = 1,NPDE AND GAMMA IS A FUNCTION OF U,X AND T
C
C      INTEGER NPDE, NV, IRES
C      LOGICAL LEFT
C      DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE)
C    -                  ,T, V(1), VDOT(1), UDOT(NPDE), UTDX(NPDE)
C      BETA(1) = 1.0D0
C      IF(LEFT)THEN
C         GAMMA(1) = -V(1)*DEXP(T)
C      ELSE
C         GAMMA(1) = -V(1)*VD(1)
C      END IF
C      RETURN
C      END
C
C      SUBROUTINE SODEFN(T, NV, V, VDOT, NPDE, NXI, XI, UI, UXI, RI,
C    1                    UTI, UTXI, VRES, IRES)
C      ROUTINE TO PROVIDE RESIDUAL OF COUPLED ODE SYSTEM FOR THE
C      MOVING BOUNDARY PROBLEM.
C      NOTE HOW IRES CAN BE RESET TO COPE WIH ILLEGAL VALUES OF THE
C           MOVING BOUNDARY POSITION V(1).
C      INTEGER NPDE, NXI, NV, IRES
C      DOUBLE PRECISION T, XI(NXI), UI(NPDE,NXI), UXI(NPDE,NXI),
C    1         RI(NPDE,NXI), UTI(NPDE,NXI), UTXI(NPDE,NXI), VRES(NV),
C    2         V(NV), VDOT(NV), TEM
C      VRES(1) = UI(1,1)
C      TEM = 1.0D0
C      IF(IRES .EQ. -1)TEM = 0.0D0
C      IF(V(1) .LT. 0.0D0)IRES = -1
C      VRES(1) = TEM * UI(1,1)
C      RETURN
C      END
C
C   EXAMPLE PROGRAM ONE ....................
C
C     C0 COLLOCATION PARAMETERS
C       PARAMETER ( IBK   = 21, NEL  = IBK-1 , NPDE = 1, NV = 1,
C    1              NPOLY =  2,  NPTS = NEL*NPOLY+1,     NXI = 1,
C    2              NEQ   = NPTS * NPDE + NV,
C    3              NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) +
C    4                       NPDE * 8 + 3 + NV + NXI,
C     DDASSL TIME INTEGRATION PARAMETERS
C    5              MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2,
C    6              LIW = 20 + NEQ )
C
C       INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID, IRESWK,
C    1          IDEV, ITRACE
C       DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ),
C    1          WKRES(NWKRES), RWORK(LRW), XI(1), T, TOUT, RTOL, ATOL,
C    2          ENORM, GERR, VERROR, CTIME, TOL
C       EXTERNAL PDECHB, DGEJAC
C       COMMON /SDEV2/ ITRACE, IDEV
C       COMMON /PROB1/ TOL
C       TOL  = 0.1D-5/50.D0
C       M    = 0
C       T    = TOL
C       IDEV = 4
C       ITRACE = 1
C       WRITE(IDEV,9)NPOLY, NEL
C9      FORMAT(' TEST PROBLEM 1'/' ***********'/' POLY OF DEGREE =',I4,
C    1         ' NO OF ELEMENTS = ',I4)
C       XI(1)  = 1.0D0
C       DO 10 I = 1,IBK
C10       XBK(I) = (I-1.0D0)/(IBK-1.0D0)
C           INITIALISE THE P.D.E. WORKSPACE
C       ITIME  = 1
C       CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND,
C    1              ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV)
C       IF(ITIME .EQ. -1)THEN
C          WRITE(IDEV, 15)
C15        FORMAT(' INICHB ROUTINE RETURNED ITIME = -1 - RUN HALTED ')
C          GOTO 100
C       END IF
C         SETUP DASSL PARAMETERS
C      RTOL = TOL
C      ATOL = TOL
C      DO 20 I = 1,11
C20      INFO(I) = 0
C         BANDED MATRIX OPTION WHEN INFO(6) = 1
C      IF(INFO(6) .EQ. 1)THEN
C         IWORK(1) = IBAND
C         IWORK(2) = IBAND
C      END IF
C30    TOUT = T * 10.0D0
C      IF(TOUT .GE. 2.D0)TOUT =2.0D0
C      CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL,
C    1              IDID, RWORK, LRW, IWORK, LIW, WKRES, IRESWK, DGEJAC)
C      IF( IDID .LT. 0 )THEN
C          DASSL FAILED TO FINISH INTEGRATION.
C          WRITE(IDEV,40)T,IDID
C40        FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3)
C          GOTO 100
C      ELSE
C        DASSL INTEGRATED TO T = TOUT
C        CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION.
C        ITRACE = 1
C        CALL ERROR( Y, NPDE, NPTS, X, M, ENORM, GERR, T, RTOL, ATOL,
C    1               ITRACE, WKRES, NWKRES)
C        ITRACE = 0
C        VERROR  = Y(NEQ) - T
C        WRITE(IDEV,50)Y(NEQ),VERROR
C50      FORMAT(' MOVING BOUNDARY IS AT ',D12.4,' WITH ERROR=',D12.4)
C        IF(TOUT .LT. 1.99D0 ) GOTO 30
C      END IF
C100    CONTINUE
C      WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13)
C110    FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4)
C       STOP
C       END
C
C
C
C EXAMPLE PROBLEM TWO
C ********************
C     THIS PROBLEM IS DEFINED BY
C             -2    2               2
C     U U  = X   ( X  U U  )   + 5 U  + 4 X U U     ,  X IN (0,1)
C        T                X  X                 X
C
C     THE LEFT BOUNDARY CONDITION AT X = 0 (LEFT = .TRUE. ) IS GIVEN BY
C        U (0,T)  = 0.0
C         X
C     THE RIGHT BOUNDARY CONDITION IS  (LEFT = .FALSE.)
C         U( 1,T) = EXP ( -T )
C
C      THE INITIAL CONDITION IS GIVEN BY THE EXACT SOLUTION ;
C        U( X, T )  = EXP ( 1 - X*X - T )  , X IN ( 0,1)
C                            2
C**********************************************************************
C
C     C0 COLLOCATION PARAMETERS
C       PARAMETER ( IBK   =  2, NEL  = IBK-1 , NPDE = 1, NV = 0,
C    1              NPOLY = 10, NPTS = NEL*NPOLY+1,     NXI = 0,
C    2              NEQ   = NPTS * NPDE + NV,
C    C              NWKRES= 2*(NPOLY+1)*(NPOLY+NEL+2) + 2 + NV +
C    3              NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) +
C    4                       NPDE * 8 + 3 + NV + NXI,
C    C                       NPDE * (7 * (NPOLY+1+NXI) + 8),
C     DDASSL TIME INTEGRATION PARAMETERS
C    5              MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2,
C    6              LIW = 20 + NEQ )
C
C       INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID, IRESWK,
C    1          IDEV, ITRACE
C       DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ),
C    1          WKRES(NWKRES), RWORK(LRW), XI(1), T, TOUT, RTOL, ATOL,
C    2          ENORM, GERR, CTIME
C       EXTERNAL PDECHB, DGEJAC
C       COMMON /SDEV2/ ITRACE, IDEV
C       M    = 2
C       T    = 0.0D0
C       IDEV = 4
C       ITRACE = 1
C       WRITE(IDEV,9)NPOLY, NEL
C9      FORMAT(' TEST PROBLEM 1'/' ***********'/' POLY OF DEGREE =',I4,
C    1         ' NO OF ELEMENTS = ',I4)
C       DO 10 I = 1,IBK
C10       XBK(I) =          (I-1.0D0) / (IBK - 1.0D0)
C           INITIALISE THE P.D.E. WORKSPACE
C       ITIME = 1
C       CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND,
C    1              ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV)
C       IF(ITIME .EQ. -1)THEN
C          WRITE(IDEV, 15)
C15        FORMAT(' INICHB ROUTINE RETURNED ITIME = -1 - RUN HALTED ')
C          GOTO 100
C       END IF
C         SETUP DASSL PARAMETERS
C      RTOL = 1.0D-8
C      ATOL = 1.0D-8
C      DO 20 I = 1,11
C20      INFO(I) = 0
C      INFO(11)= 1
C         BANDED MATRIX OPTION WHEN INFO(6) = 1
C      IF(INFO(6) .EQ. 1)THEN
C         IWORK(1) = IBAND
C         IWORK(2) = IBAND
C      END IF
C30    TOUT = T + 0.1D0
C      CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL,
C    1              IDID, RWORK, LRW, IWORK, LIW, WKRES, IRESWK, DGEJAC)
C      IF( IDID .LT. 0 )THEN
C          DASSL FAILED TO FINISH INTEGRATION.
C          WRITE(IDEV,40)T,IDID
C40        FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3)
C          GOTO 100
C      ELSE
C        DASSL INTEGRATED TO T = TOUT
C        CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION.
C        CALL ERROR( Y, NPDE, NPTS, X, M, ENORM, GERR, T, RTOL, ATOL,
C    1               ITRACE, WKRES, NWKRES)
C        IF(TOUT .LT. 0.99D0 ) GOTO 30
C      END IF
C100    CONTINUE
C      WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13)
C110    FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4)
C       STOP
C       END
C      SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV,V)
C      ROUTINE FOR P.D.E. INITIAL VALUES.
C      INTEGER NPDE, NPTS, NV
C      DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), V(1), T
C        T = 0.0D0
C        V(1) IS A DUMMY VARIABLE AS THERE ARE NO COUPLED O.D.E.S
C        CALL EXACT( T, NPDE, NPTS, X, U )
C      RETURN
C      END
C
C      SUBROUTINE SPDEFN( T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R,
C    1                    NV, V, VDOT, IRES)
C      ROUTINE TO DESCRIBE THE BODY OF THE P.D.E.
C      THE P.D.E. IS WRITEN AS       -M   M
C         Q(X,T,U, U  , U  , U  ) = X   (X  R(X,T,U,U , U , U  ))
C                   X    T    TX                     X   T   TX  X
C      THE FUNCTIONS Q AND R MUST BE DEFINED IN THIS ROUTINE.
C      DEFINITIONS FOR THE MODEL PROBLEM ARE GIVEN
C      NOTE NV = 0 : THERE IS NO O.D.E PART.
C      INTEGER NPDE, NPTL, I, J, NV, IRES
C      DOUBLE PRECISION T, X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL),
C    1         UDOT(NPDE,NPTL), Q(NPDE,NPTL), R(NPDE,NPTL), V, VDOT,
C    2         UTDX(NPDE,NPTL)
C      DO 10 I = 1,NPTL
C         R(1,I) = U(1,I) * DUDX(1,I)
C         Q(1,I) = U(1,I) * UDOT(1,I) - 5.0D0 * U(1,I)**2
C    1                                - 4.0D0 * U(1,I)*DUDX(1,I)*X(I)
C10    CONTINUE
C      RETURN
C      END
C
C      SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, LEFT,
C    1                   NV, V, VDOT, IRES)
C      BOUNDARY CONDITIONS ROUTINE
C      INTEGER NPDE, NV, IRES
C      DOUBLE PRECISION T, BETA(NPDE), GAMMA(NPDE), U(NPDE), C2,
C    1                  UX(NPDE), V, VDOT, UDOT(NPDE), UTDX(NPDE)
C      LOGICAL LEFT
C      IF(LEFT) THEN
C         BETA (1) = 1.0D0
C         GAMMA(1) = 0.0D0
C      ELSE
C         BETA (1) = 0.0D0
C         GAMMA(1) = U(1) - DEXP( -T )
C         BETA (1) = 1.0D0
C         GAMMA(1) = - 2.D0 *U(1)**2
C      END IF
C      RETURN
C      END
C
C      DUMMY O.D.E. ROUTINE AS NV IS ZERO
C      SUBROUTINE SODEFN
C      RETURN
C      END
C EXACT SOLUTION
C      SUBROUTINE EXACT( TIME, NPDE, NPTS, X, U)
C      ROUTINE FOR P.D.E. EXACT VALUES  (IF KNOWN)
C      INTEGER NPDE, NPTS, I
C      DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME
C      DO 10 I = 1,NPTS
C10       U(1,I) = DEXP( 1.0D0 - X(I)**2 - TIME)
C      RETURN
C      END
C
C EXAMPLE PROBLEM 3
C *********************
C     THIS PROBLEM IS DEFINED BY
C               -1
C       U  = ( C   U  )  - C * EXP(-2U) + EXP(-U)  ,  X IN (-1,0)
C        T      1   X  X    1
C  AND
C               -1
C       U  = ( C   U  )  - C * EXP(-2U) + EXP(-U)  ,  X IN (0,1)
C        T      2   X  X    2
C  WHERE
C       C  = 0.1     AND    C   = 1.0
C        1                   2
C
C     THE LEFT BOUNDARY CONDITION AT X =-1 (LEFT = .TRUE. ) IS GIVEN BY
C         U(-1,T)  = LOG ( - C  + T + P)
C                       1
C     THE RIGHT BOUNDARY CONDITION IS  (LEFT = .FALSE.)
C         U( 1,T) + (C + T + P ) U  = LOG ( - C  + T + P) + 1.0D0
C                                 X
C
C      THE INITIAL CONDITION IS GIVEN BY THE EXACT SOLUTION ;
C        U( X, T )  = LOG ( C X + T + P )  , X IN ( -1, 0)
C                            1
C        U( X, T )  = LOG ( C X + T + P )  , X IN (  0, 1)
C                            2
C**********************************************************************
C      SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV,V)
C      ROUTINE FOR P.D.E. INITIAL VALUES.
C      INTEGER NPDE, NPTS, NV
C      DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), V(1), T
C        T = 0.0D0
C        V(1) IS A DUMMY VARIABLE AS THERE ARE NO COUPLED O.D.E.S
C        CALL EXACT( T, NPDE, NPTS, X, U )
C      RETURN
C      END
C
C      SUBROUTINE SPDEFN( T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R,
C    1                    NV, V, VDOT, IRES)
C      ROUTINE TO DESCRIBE THE BODY OF THE P.D.E.
C      THE P.D.E. IS WRITEN AS       -M   M
C         Q(X,T,U, U  , U  , U  ) = X   (X  R(X,T,U,U , U , U  ))
C                   X    T    TX                     X   T   TX  X
C      THE FUNCTIONS Q AND R MUST BE DEFINED IN THIS ROUTINE.
C      DEFINITIONS FOR THE MODEL PROBLEM ARE GIVEN
C      NOTE NV = 0 : THERE IS NO O.D.E PART.
C      INTEGER NPDE, NPTL, I, J, NV, IRES
C      DOUBLE PRECISION T, X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL),
C    1         UDOT(NPDE,NPTL), Q(NPDE,NPTL), R(NPDE,NPTL), V, VDOT,
C    2         UTDX(NPDE,NPTL), C
C      IF(X(1) .LT. 0.0D0 .AND. X(NPTL) .LE. 0.0D0)THEN
C        ELEMENT TO LEFT OF THE INTERFACE AT 0.0
C        C  =  0.1D0
C      ELSE
C        C =   1.0D0
C      END IF
C      DO 10 I = 1,NPTL
C         R(1,I) = DUDX(1,I) /C
C         Q(1,I) = UDOT(1,I) - DEXP(-U(1,I))- DEXP(-2.0D0*U(1,I))* C
C10    CONTINUE
C      RETURN
C      END
C
C      SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, LEFT,
C    1                   NV, V, VDOT, IRES)
C      BOUNDARY CONDITIONS ROUTINE
C      INTEGER NPDE, NV, IRES
C      DOUBLE PRECISION T, BETA(NPDE), GAMMA(NPDE), U(NPDE), C2,
C    1                  UX(NPDE), V, VDOT, UDOT(NPDE), UTDX(NPDE)
C      LOGICAL LEFT
C      IF(LEFT) THEN
C         BETA (1) = 0.0D0
C         GAMMA(1) = U(1) - DLOG( -0.1 + T + 1.0D0)
C      ELSE
C         C2 = 1.0D0
C         BETA (1) = C2 * ( C2 + T + 1.0D0)
C         GAMMA(1) = U(1) - DLOG( C2 + T + 1.0D0) + 1.0D0
C      END IF
C      RETURN
C      END
C
C      DUMMY O.D.E. ROUTINE AS NV IS ZERO
C      SUBROUTINE SODEFN
C      RETURN
C      END
C EXACT SOLUTION
C      SUBROUTINE EXACT( TIME, NPDE, NPTS, X, U)
C      ROUTINE FOR P.D.E. EXACT VALUES  (IF KNOWN)
C      INTEGER NPDE, NPTS, I, IDERIV
C      DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME, C
C      COMMON /PROB3/ IDERIV
C      IF(IDERIV .EQ. 0)THEN
C         DO 10 I = 1,NPTS
C            C = 1.0D0
C            IF(X(I) .LT. 0.0D0)C = 0.1D0
C10          U(1,I) = DLOG( TIME + 1.0D0 + C * X(I))
C      ELSE
C         DO 20 I = 1,NPTS
C            C = 1.0D0
C            IF(X(I) .LT. 0.0D0)C = 0.1D0
C            U(1,I) = C / ( TIME + 1.0D0 + C * X(I))
C            IF(X(I) .EQ. 0.0D0) U(1,I) = 0.55D0 / ( TIME + 1.0D0 )
C20       CONTINUE
C      END IF
C      RETURN
C      END
C
C
C  OTHER EXAMPLE PROBLEMS
C  **********************
C
C EXAMPLE PROGRAMS ARE PROVIDED FOR THE POOL EVAPORATION PROBLEM
C DESCRIBED IN THE PAPER THAT ACCOMPANIES THIS CODE AND FOR THE
C
C     FOURTH ORDER P.D.E. PROBLEM WRITTEN AS ELLIPTIC-PARABOLIC SYSTEM.
C
C     U     =  K U     + UU    - U U
C      XXT        XXXX     XXX    X XX
C
C-----------------------------------------------------------------------
C
C   SOFTWARE STRUCTURE
C   ******************
C
C     THE SUBROUTINES IN THIS MODULE CAN BE BROKEN DOWN INTO THREE
C   PARTS.
C
C  1) INITIALISATION ROUTINES         2) DEFINITION OF D.A.E.S
C
C      ----------                        ------------
C      ! INICHB !                        ! PDECHB   !
C      ----------                        ------------
C          !                              !      !  !
C      ----------           ----------------     !  ----------
C      !  CSET  !           ! DRES OR CRES !     !  ! CHINTR !
C      ----------           ----------------     !  ----------
C          !                   !      !          !
C      ----------       ----------  ---------   ----------
C      ! UVINIT !       ! SPDEFN !  ! SBNDR !   ! SODEFN !
C      ----------       ----------  ---------   ----------
C
C       THE FOUR BOTTOM LEVEL ROUTINES ARE THE USER DEFINED PROBLEM
C       DEFINITION ROUTINES.
C
C     3) POST PROCESSING (SPACE INTERPOLATION ).
C
C       ----------
C       ! INTERC !    THIS ROUTINE CAN BE CALLED BY THE USER.
C       ----------
C           !
C       ----------
C       ! INTRCH !    SYSTEM INTERPOLATION ROUTINE ONLY.
C       ----------
C
C     4) ERROR MESSAGE HANDLER
C        ALL THE ABOVE ROUTINES MAY CALL A GENERAL ERROR MESSAGE
C        HANDLING ROUTINE CALLED
C                   ----------
C                   ! SCHERR !
C                   ----------
C
C     5) OPTIONAL ERROR CALCULATION ROUTINE FOR ANALYTIC SOLUTION
C        PROBLEMS IN THIS CASE THE USER MAY CALL AN ERROR CALCULATION
C        ROUTINE CALLED  ERROR WHICH IN TURN CALLS A USER DEFINED
C        ROUTINE TO SUPPLY THE ANALYTIC SOLUTION (MUST BE NAMED EXACT)
C                   ----------
C                   ! ERROR  !
C                   ----------
C                       !
C                   ----------
C                   ! EXACT  !
C                   ----------
C----------------------------------------------------------------------
C
C  INTERFACES TO THE INDIVIDUAL ROUTINES NOW FOLLOW IN THE FOLLOWING
C  ORDER
C   (1) INICHB
C   (2) CSET
C   (3) PDECHB
C   (4) CHINTR
C   (5) INTERC
C   (6) INTRCH
C   (7) SCHERR
C   (8) ERROR
C       THE LAST ROUTINE IS A P.D.E. UTILITY TO EVALUATE THE P.D.E.
C       ERROR NORMS AND GRID ERRORS FOR PROBLEMS WITH ANALYTIC SOL.
C
C
C***********************************************************************
      SUBROUTINE INICHB(NEQN,NPDE,NPTS,X,U,WK,IWK,M,TS,IBAND,ITIME,XBK,
     *                  IBK,NEL,NPOLY,NV,NXI,XI,IDEV)
C***********************************************************************
C ROUTINE FOR INITIALISATION OF CHEBYSHEV GENERALIZED COLLOCATION METHOD
C
C  PARAMETER LIST
C ----------------
C  NEQN:          EMPTY ON ENTRY, ON EXIT IT CONTAINS THE NUMBER OF
C                 O.D.E.S GENERATED BY THE DISCRETISED FORM OF THE
C                 P.D.E. , GIVEN BY  NPDE*NEL*(NPTL-1) + NPDE + NV.
C
C  NPDE           NUMBER OF PARABOLIC P.D.E.S IN ONE SPACE DIMENSION
C
C  NPTS           NUMBER OF SPATIAL GRID POINTS USED IN M.O.L. SOLUTION.
C                 NOTE THIS SHOULD BE EQUAL TO (NPTL-1)*NEL + 1
C
C  X(NPTS)        EMPTY ARRAY ON ENTRY . ON EXIT THIS ARRAY
C                 CONTAINS THE MESH USED IN SEMI-DISCRETISATION
C
C  M              =0,1,2 IF CARTESIAN CYLINDRICAL OR SPHERICAL POLARS.
C
C  U(NEQN)        SOLUTION VECTOR  EMPTY ON ENTRY CONTAINS INITIAL
C                 VALUES ON EXIT. THIS ARRAY IS ORDERED AS FOLLOWS.
C                 U(1) - U(NPDE*NPTS)      P.D.E. SOLUTION COMPONENTS.
C                 U(NPDE*NPTS+1) - U(NEQN) O.D.E. COMPONENTS THAT ARE
C                 COUPLED TO THE P.D.E.
C
C  WK(IWK)        REAL WORKSPACE USED TO PASS FOUR MATRICES AND VARIOUS
C                 USEFUL VECTORS TO THE O.D.E.FUNCTION CALL ROUTINE
C                 RESID SEE BELOW FOR A DETAILED DESCRIPTION.
C
C   TS            STARTING LEVEL OF TIME INTEGRATION.
C
C   XBK(IBK)      REAL ARRAY OF BREAK POINTS  IBK = NEL +1  WHERE
C                 NEL IS THE NUMBER OF SPATIAL ELEMENTS.
C                      XBK(1) = XLEFT
C                      XBK(I) =< XBK(I+1)  I = 1,...,NEL .
C                      XBK(IBK) = XRIGHT.
C  NEL            THE NUMBER OF SPATIAL ELEMENTS , >= 1
C
C  NPOLY          THE DEGREE OF THE APPROXIMATING POLYNOMIAL USED
C                 BETWEEN EACH PAIR OF BREAKPOINTS .
C  ITIME          THIS MUST BE SET = 1 ON THE CALL OF THIS MODULE
C                 PRIOR TO THE DASSL  PACKAGE BEING CALLED.
C                 ONCE DASSL  HAS RETURNED THIS ROUTINE MAY BE CALLED
C                 WITH ITIME = 2 TO RECOVER THE SPATIAL MESH USED
C                 (THIS IS PLACED IN THE ARRAY X(NPTS) ).
C
C  NV             THE NUMBER OF AUXILARY O.D.E.S THAT ARE COUPLED TO
C                 THE P.D.E.
C  NXI            THE NUMBER OF COUPLING POINTS AT WHICH P.D.E. VALUES
C                 ARE USED TO DEFINE THE O.D.E.S
C
C  XI(NXI)        A VECTOR SPECIFYING THE POSITION OF THESE POINTS.
C                 NOTE THAT THESE POINTS MUST BE DISTINCT FROM THE
C                 BREAK - POINTS .
C
C  IDEV           NUMBER OF OUTPUT CHANNEL ON WHICH ERROR MESSAGES TO
C                 DO WITH THE COLLOCATION DISCRETISATION WILL APPEAR.
C
C---------------------------------------------------------------------
C   EIGHT IMPORTANT PARAMETERS ARE PASSED ACROSS FROM HERE IN
C   COMMON /SCHSZ1/ NNEL, NNPTL, NNPDE, NNPTS, MM, NNV, NNXI, NVST
C
C  NNEL  = NEL
C
C  NNPTL = NPTL = NPOLY + 1
C
C  NNPDE = NPDE     THE NUMBER OF P.D.E.S
C
C  NNPTS = NPTS     THE TOTAL NUMBER OF MESHPOINTS = NEL*(NPTL-1) + 1
C
C  MM = M           = 0,1,2 CARTESIAN, CYLINDRICAL OR SPHERICAL POLAR
C                           CO-ORDINATES IN USE.
C  NNV = NV         NUMBER OF AUXILLARY ODES
C
C  NNXI= NXI        THE NUMBER OF COUPLING POINTS
C
C  NVST             THE STARTING POINT OF THE ODE COMPONENTS IN THE
C                   SOLUTION VECTOR.
C----------------------------------------------------------------------
C
C     DETAILED DESCRIPTION OF WORKSPACE
C    -----------------------------------
C        THE WORKSPACE WK(IWK) IS USED TO PASS ARRAYS AND VECTORS TO
C        THE ROUTINES  RESID AND CHINTR.
C
C        SIZE  :  IWK MUST BE >= 2*NPTL*(NPTL+NEL+1) + 2 + NV +
C                                  NPDE*(7 * (NPTL + NXI) + 8)
C
C     STRUCTURE        NAME IN CODE   PURPOSE IN CODE IS TO HOLD
C     *********
C     WK(1)  -  WK(I2-1)  OMEGA     MATRIX OMEGA FOR MAPPING TO COEFFS
C     WK(I2) -  WK(I3-1)  DU        MATRIX DU FOR FORMING DUDX
C     WK(I3) -  WK(I4-1)  DUTEM     TEMPORARY WORK AREA
C     WK(I4) -  WK(I7-1)  XC        CHEBYSHEV POINTS IN (-1,1)
C     WK(I7) -  WK(I8-1)  BETA      BETA (NPDE,4)       ARRAY FOR B.C.S
C     WK(I8) -  WK(I9-1)  GAMMA     GAMMA(NPDE,4)       ARRAY FOR B.C.S.
C     WK(I9) -  WK(I10-1)  DUDX     DUDX(NPDE,NPTL)     !WORKSPACES
C     WK(I10)-  WK(I11-1)   RT      R(3*NPDE,NPTS)      !USED INSIDE
C     WK(I11)-  WK(I12-1)   QT      Q(3*NPDE,NPTS)      !ROUTINE CRES
C     WK(I12)-  WK(I13-1)   CCR     COEFFS OF CLENSHAW CURTIS RULE OF
C                                   DEGREE NPTL-1.
C     ---------------------THE FOLLOWING PARTS OF THE WORKSPACE ARE USED
C                          IN SEMI-DISCRETISING MIXED O.D.E./P.D.E.
C                          PROBLEMS.
C     WK(I13)-  WK(I14-1) UI        ARRAY UI(NPDE,NXI) USED TO HOLD THE
C                                   PDE COMPONENTS AT THE COUPLING PTS .
C     WK(I14)-  WK(I15-1) UXI       SPACE DERIVS CORRESS TO ARRAY UI.
C     WK(I15)-  WK(I16-1) RI        FLUX CORRESS TO UI ARRAY
C     WK(I16)-  WK(I17-1) UTI       TIME DERIV CORRESS TO UI ARRAY.
C     WK(I17)-  WK(I18-1) UTXI      SPACE DERIV OF ARRAY UTI.
C     WK(I18)-  WK(I19-1) XI        COUPLING POINTS TO LINK PDE TO ODE.
C     WK(I19)-  WK(I20)   VDUM      ARRAY OF ZEROES.
C
C     --------------------THE FOLLOWING TWO PARTS OF WK HOLD THE MESH
C                         POINT INFORMATION USED IN SEMI-DISCRETISATION.
C     WK(I5) -  WK(I6-1)  XBK(IBK)  BREAKPOINTS USED BY THE CODE
C     WK(I6) -  WK(I13)   X(NPTS)   SPATIAL MESH POINTS USED BY THE CODE
C
C   THE ARRAYS BETA AND GAMMA ARE USED IN THE FORMATION OF THE
C   BOUNDARY CONDITIONS. THE ARRAYS DUDX R AND Q HOLD THE TEMPORARY
C   VARIABLES NEEDED IN THE CONSTRUCTION OF THE RESIDUAL OF THE O.D.E.
C   SYSTEM.
C   NOTE ; THE MESH POINTS AND BREAK POINTS ARE STORED AT THE END OF THE
C   *****  WORKSPACE WK SO THAT THE BREAK POINTS MAY BE INCREASED OR
C          DECREASED BY A MESH MODIFICATION ROUTINE. IN SUCH CASES THE
C          MESH POINTS MUST BE RECOMPUTED AS THEY ARE THE CHEBYSHEV
C          POINTS IN  (-1,1) MAPPED ONTO THE INTERVAL. THE CODE TO DO
C          THIS IS GIVEN BY
C          DO 10 I = 1, NEL
C             H1 = XBK(I+1) - XBK(I)
C             H2 = XBK(I=1) + XBK(I)
C             DO 10 J = 1, NPTL
C                IJ = (I-1)*(NPTL -1) + J
C      10        X(IJ) = (XC(J)) * H1 + H2) * 0.5D0
C         WHERE THE VALUES OF XBK AND XC MUST BE EXTRACTED FROM THE
C         WORKSPACE AND THE NEW VALUES OF X PUT IN THE WORKSPACE.
C
C   THE PARAMETERS I2,...,I20  ARE DEFINED BELOW.
C
C**********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION  TS
      INTEGER           IBAND, IBK, IDEV, ITIME, IWK, M, NEL, NEQN,
     *                  NPDE, NPOLY, NPTS, NV, NXI
C     .. Array Arguments ..
      DOUBLE PRECISION  U(1), WK(IWK), X(NPTS), XBK(IBK), XI(1)
C     .. Scalars in Common ..
      DOUBLE PRECISION  TO, TWOU
      INTEGER           I10, I10A, I10B, I11, I11A, I11B, I12, I13, I14,
     *                  I15, I16, I17, I18, I19, I2, I3, I4, I5, I6, I7,
     *                  I8, I9, ILOC, INDEV, JTIMES, K1, K2, K3, K4, MM,
     *                  NNEL, NNNPTL, NNPDE, NNPTL, NNPTS, NNV, NNXI,
     *                  NVST
      CHARACTER*6       PDCODE
C     .. Local Scalars ..
      DOUBLE PRECISION  TEMP, TEMP2
      INTEGER           I, I20, IBKM1, IT, IV, J, NPTL, NSQ
      CHARACTER*240     ERRMSG
C     .. External Subroutines ..
      EXTERNAL          CSET, SCHERR
C     .. Intrinsic Functions ..
      INTRINSIC         DABS, DMAX1
C     .. Common blocks ..
      COMMON            /DISCHK/PDCODE
      COMMON            /SCHSZ/I2, I3, I4, I5, I6, I7, I8, I9, I10,
     *                  I10A, I10B, I11, I11A, I11B, I12, I13, I14, I15,
     *                  I16, I17, I18, I19
      COMMON            /SCHSZ1/NNEL, NNPTL, NNPDE, NNPTS, MM, NNV,
     *                  NNXI, NVST
      COMMON            /SCHSZ2/INDEV
      COMMON            /SCHSZ3/TWOU
      COMMON            /SCHSZ4/TO, K1, K2, K3, K4, JTIMES, ILOC
      COMMON            /SCHSZ5/NNNPTL
C     .. Save statement ..
      SAVE              /SCHSZ1/, /SCHSZ/, /DISCHK/, /SCHSZ2/, /SCHSZ3/,
     *                  /SCHSZ4/, /SCHSZ5/
C     .. Executable Statements ..
      INDEV = IDEV
      IF (ITIME.LT.1 .OR. ITIME.GT.2) THEN
         ERRMSG =
     *' INICHB DETECTED THAT THE SUPPLIED VALUE OF ITIME        (VALUE =
     * I1 ) IS NOT IN THE RANGE ONE TO TWO '
         CALL SCHERR(ERRMSG,1,1,ITIME,0,0,0.0D0,0.0D0)
         ITIME = -1
         RETURN
      END IF
      IF (ITIME.EQ.2 .AND. PDCODE.EQ.'C0CHEB') GO TO 140
      PDCODE = 'C0CHEB'
      TO = TS
      ILOC = -1
      MM = M
      NNPDE = NPDE
      NPTL = NPOLY + 1
      IF (NPOLY.LT.2 .OR. NPOLY.GT.49) THEN
         ERRMSG =
     *' INICHB ROUTINE DETECTED THAT THE SUPPLIED VALUE         OF NPOLY
     * WAS (= I1 ) WHICH IS LESS THAN TWO OR GREATER THAN 49'
         CALL SCHERR(ERRMSG,1,1,NPOLY,0,0,0.0D0,0.0D0)
         ITIME = -1
      END IF
      NNPTS = (NPTL-1)*NEL + 1
      IF (NPTS.NE.NNPTS) THEN
         ERRMSG =
     *' INCORRECT VALUE OF NPTS (=I1) SUPPLIED IN CALL TO
     *  INICHB. THE VALUE SHOULD BE (=I2)'
         CALL SCHERR(ERRMSG,1,2,NPTS,NNPTS,0,0.0D0,0.0D0)
         ITIME = -1
      END IF
      NNEL = NEL
      NNPTL = NPTL
      NNV = NV
      NNXI = NXI
      NVST = NPDE*NPTS + 1
      NEQN = NPDE*NPTS + NV
      IF (NV.GT.0) THEN
         IBAND = NEQN - 1
      ELSE
         IBAND = (NPTL)*NPDE - 1
      END IF
      IF (IBK.NE.(NEL+1)) THEN
         ERRMSG =
     *' INCORRECT VALUE OF IBK (=I1) SUPPLIED IN CALL TO
     *  INICHB. THE VALUE SHOULD BE (=I2) PLUS 1'
         CALL SCHERR(ERRMSG,1,2,IBK,NEL,0,0.0D0,0.0D0)
         ITIME = -1
      END IF
      X(1) = XBK(1)
      X(NPTS) = XBK(IBK)
      ITIME = 1
      IF (X(NPTS).LE.X(1)) THEN
         ERRMSG =
     *' INICHB ROUTINE FOUND THAT THE LAST BREAK-POINT          (=R1) HA
     *S BEEN PLACED BEFORE THE FIRST BREAK-POINT (= R2)'
         CALL SCHERR(ERRMSG,1,0,0,0,2,X(NPTS),X(1))
         ITIME = -1
         RETURN
      END IF
      IF (NEL.LT.1) THEN
         ERRMSG =
     *' INICHB ROUTINE - HAS DETECTED THAT THE                  SUPPLIED
     * VALUE OF NEL ( = I1 ) WHICH IS ILLEGAL '
         CALL SCHERR(ERRMSG,1,1,NEL,0,0,0.0D0,0.0D0)
         ITIME = -1
         RETURN
      END IF
      I = NEL*(NPTL-1) + 1
      IF (I.NE.NPTS) THEN
         ERRMSG =
     *' INIT FOR C0 COLLOC- VALUES OF NEL AND NPTL FORM A       MESH OF
     *(=I1) POINTS BUT NPTS IS SET TO ( =I2)'
         CALL SCHERR(ERRMSG,1,2,I,NPTS,0,0.0D0,0.0D0)
         ITIME = -1
         RETURN
      END IF
      DO 20 I = 2, IBK
         IF (XBK(I).LE.XBK(I-1)) THEN
            ERRMSG =
     *' INICHB - BREAKPOINT NO (=I1) HAS VALUE (=R1)            WHICH IS
     * SMALLER THAN OR EQUAL TO BREAKPOINT NO I1-1              WITH VAL
     *UE (=R2)'
            CALL SCHERR(ERRMSG,1,1,I,0,2,XBK(I),XBK(I-1))
            ITIME = -1
            RETURN
         END IF
   20 CONTINUE
C
C   CALCULATE ROUGH ESTIMATE OF UNIT ROUND-OFF ERROR FOR CHECKING
C
      TWOU = 0.1D0
   40 TEMP = 1.0D0 + TWOU
      IF (1.0D0.EQ.TEMP) THEN
         TWOU = TWOU*2.0D0
      ELSE
         TWOU = TWOU*0.5D0
         GO TO 40
      END IF
C
C  CHECK IF THE BREAK-POINTS MATCH THE COUPLING POINTS.
C
      IF (IBK.GT.2 .AND. NXI.GT.0) THEN
         IBKM1 = IBK - 1
         DO 80 I = 2, IBKM1
            DO 60 J = 1, NXI
               TEMP = DABS(XI(J)-XBK(I))
               TEMP2 = TWOU/DMAX1(TEMP,1.0D0)
               IF (TEMP.LT.TEMP2) THEN
C                 COUPLING POINT IS TOO CLOSE TO BREAK-POINT
                  ERRMSG =
     *' INICHB ROUTINE HAS FOUND THAT COUPLING                  POINT (=
     *I1) HAS VALUE (=R1) WHICH IS VERY CLOSE TO                BREAK-PO
     *INT (=I2) WITH VALUE (=R2)'
                  CALL SCHERR(ERRMSG,1,2,J,I,2,XI(J),XBK(I))
               END IF
   60       CONTINUE
   80    CONTINUE
      END IF
*
C
C  FORM INTEGER CONSTANTS FOR WKSPACE MANIPULATION
C
      NSQ = NPTL*NPTL
      IT = NPDE*NXI
      I2 = NSQ + 1
      I3 = I2 + NSQ
      I4 = I3 + NSQ
      I7 = I4 + NPTL
      I8 = I7 + NPDE*4
      I9 = I8 + NPDE*4
      I10 = I9 + NPDE*NPTL
      I11 = I10 + NPDE*NPTL*3
      I12 = I11 + NPDE*NPTL*3
      I13 = I12 + NPTL
      I14 = I13 + IT
      I15 = I14 + IT
      I16 = I15 + IT
      I17 = I16 + IT
      I18 = I17 + IT
      I19 = I18 + NXI
      I5 = I19 + NV
      I6 = I5 + NEL + 1
      I20 = I6 + NEL*(NPTL-1) + 1
      I10A = I10 + NPDE*NPTL
      I10B = I10A + NPDE*NPTL
      I11A = I11 + NPDE*NPTL
      I11B = I11A + NPDE*NPTL
      K1 = 1
      K2 = K1 + NEQN
      K3 = K2 + NEQN
      K4 = K3 + NEQN
      IF (I20.GT.IWK) THEN
         ERRMSG =
     *' INICHB-ROUTINE WORKSPACE OF SIZE (=I1) IS LESS          THAN REQ
     *UIRED SIZE (=I2)'
         CALL SCHERR(ERRMSG,1,2,IWK,I20,0,0.0D0,0.0D0)
         ITIME = -1
         RETURN
      END IF
      IV = NPDE*NPTS
      IF (NV.GT.0) THEN
         IV = NVST
C        COPY ACROSS THE COUPLING POINTS
         DO 100 I = 1, NXI
            WK(I18+I-1) = XI(I)
  100    CONTINUE
         DO 120 I = 2, NXI
            IF (XI(I).LE.XI(I-1)) THEN
               ERRMSG =
     *' INICHB WARNING THE ODE/PDE COUPLING POINTS              COUPLING
     * POINTS ARE NOT IN STRICTLY INCREASING ORDER'
               CALL SCHERR(ERRMSG,1,0,0,0,0,0.0D0,0.0D0)
            END IF
  120    CONTINUE
      END IF
C
      CALL CSET(NPDE,NPTS,U,WK(I6),WK,WK(I2),WK(I5),NEL,NPTL,WK(I4),
     *          WK(I12),XBK,IBK,WK(I3),U(IV),NV)
C
  140 DO 160 I = 1, NPTS
         X(I) = WK(I6+I-1)
  160 CONTINUE
      NNNPTL = NPTL
      RETURN
      END
      SUBROUTINE CSET(NPDE,NPTS,U,X,OMEGA,DU,XBK,NEL,NPTL,XC,CCR,XBH,
     *                IBK,DUTEM,V,NV)
C***********************************************************************
C       FORTRAN FUNCTIONS USED:  SIN COS .
C***********************************************************************
C     .. Scalar Arguments ..
      INTEGER         IBK, NEL, NPDE, NPTL, NPTS, NV
C     .. Array Arguments ..
      DOUBLE PRECISIONCCR(NPTL), DU(NPTL,NPTL), DUTEM(NPTL,NPTL),
     *                OMEGA(NPTL,NPTL), U(NPDE,NPTS), V(1), X(NPTS),
     *                XBH(IBK), XBK(IBK), XC(NPTL)
C     .. Arrays in Common ..
      DOUBLE PRECISIONCCRULE(50)
C     .. Local Scalars ..
      DOUBLE PRECISIONH1, H2, PI, SINT, SUM, TEMP
      INTEGER         I, IJ, ITEM, J, K, NM1, NT, NTP1
C     .. External Subroutines ..
      EXTERNAL        UVINIT
C     .. Intrinsic Functions ..
      INTRINSIC       DBLE, DCOS, DSIN
C     .. Common blocks ..
      COMMON          /SCHSZ6/CCRULE
C     .. Save statement ..
      SAVE            /SCHSZ6/
C     .. Executable Statements ..
C
C  FORM  CONSTANTS FOR WKSPACE INITIALISATION
C
      NM1 = NPTL - 1
      PI = 3.1415926535897930D0
C
C  FORMATION OF GRID AND INITIAL VALUES OF U
C
      DO 40 I = 1, NEL
         H1 = XBH(I+1) - XBH(I)
         H2 = XBH(I+1) + XBH(I)
         XBK(I) = XBH(I)
         DO 20 J = 1, NPTL
            IJ = (I-1)*NM1 + J
            IF (I.EQ.1) XC(J) = DCOS(PI*DBLE(J-NPTL)/NM1)
            X(IJ) = (XC(J)*H1+H2)*0.5D0
            IF (J.EQ.1) X(IJ) = XBH(I)
            IF (J.EQ.NPTL) X(IJ) = XBH(I+1)
   20    CONTINUE
   40 CONTINUE
      XBK(IBK) = XBH(IBK)
      XC(1) = -1.0D0
      XC(NPTL) = 1.0D0
C
C  FORM THE MATRIX OMEGA
C
      DO 80 J = 1, NPTL
         DO 60 I = 1, NPTL
            OMEGA(I,J) = 2.D0*DCOS(PI*(I-1)*(NPTL-J)/NM1)/NM1
   60    CONTINUE
   80 CONTINUE
C
C   MODIFY EDGES OF OMEGA AND FORM EDGES OF INTERMEDIATE DU MATRIX
C
      ITEM = 1
      DO 100 I = 1, NPTL
         OMEGA(I,1) = OMEGA(I,1)*0.5D0
         OMEGA(1,I) = OMEGA(1,I)*0.5D0
         OMEGA(NPTL,I) = OMEGA(NPTL,I)*0.5D0
         OMEGA(I,NPTL) = OMEGA(I,NPTL)*0.5D0
         DUTEM(I,1) = 0.0D0
         DUTEM(1,I) = -DBLE((I-1)**2*ITEM)
         DUTEM(NPTL,I) = DBLE((I-1)**2)
         ITEM = -ITEM
  100 CONTINUE
C
C FINISH FORMING REST OF INTERMEDIATE DU MATRIX THAT IS HELD IN DUTEM.
C
      IF (NPTL.GT.2) THEN
         DO 140 I = 2, NM1
            TEMP = PI*(I-NPTL)/NM1
            SINT = DSIN(TEMP)
            DO 120 J = 2, NM1
               DUTEM(I,J) = DSIN(TEMP*(J-1))/SINT*(J-1)
  120       CONTINUE
            DUTEM(I,NPTL) = 0.0D0
  140    CONTINUE
      END IF
C
C  FORM FULL DU BY MATRIX MULTIPLICATION
C
      DO 200 I = 1, NPTL
         DO 180 J = 1, NPTL
            DU(I,J) = 0.0D0
            DO 160 K = 1, NPTL
               DU(I,J) = DU(I,J) + DUTEM(I,K)*OMEGA(K,J)
  160       CONTINUE
  180    CONTINUE
  200 CONTINUE
C
C        CALCULATE THE COEFFS OF THE CLENSHAW CURTIS RULE
C
      NT = NM1/2
      IF ((2*NT).NE.NM1) NT = (NM1-1)/2
      NTP1 = NT + 1
      SUM = 0.0D0
      DO 240 I = 1, NPTL
         TEMP = 0.5D0
         CCR(I) = 0.0D0
         DO 220 K = 1, NTP1
            IF (K.EQ.NTP1 .AND. ((2*NT).EQ.NM1)) TEMP = 0.5D0
            CCR(I) = CCR(I) + DCOS(2.0D0*(I-1)*(K-1)*PI/NM1)
     *               *TEMP/(4.0D0*(K-1)**2-1.0D0)
            TEMP = 1.0D0
  220    CONTINUE
         IF (I.EQ.1 .OR. I.EQ.NPTL) TEMP = 0.5D0
         CCR(I) = CCR(I)*(-4.0D0)*TEMP/NM1
         SUM = SUM + CCR(I)
  240 CONTINUE
      DO 260 I = 1, NPTL
         CCRULE(I) = CCR(I)
  260 CONTINUE
      DO 280 I = 2, NM1
         CCR(I) = CCR(I)/CCR(1)
  280 CONTINUE
C  FIND THE INITIAL VALUES OF THE O.D.E. AND P.D.E. COMPONENTS.
      CALL UVINIT(NPDE,NPTS,X,U,NV,V)
      RETURN
C
C-----------END  OF  CSET ROUTINE---------------------------------------
C
      END
      SUBROUTINE PDECHB(T,U,UDOT,RESD,IRES,WK,IWK)
C***********************************************************************
C
C THIS IS THE CHEBYSHEV GLOBAL ELEMENT ROUTINE TO EVALUATE THE
C RESIDUAL OF THE IMPLICIT SET OF O.D.E.'S DEFINED BY
C
C        RESIDUAL  =  A(U,T)*DU/DT  -  F(U,T)
C
C PARAMETER LIST
C----------------
C  T               CURRENT TIME INTEGRATION LEVEL , > 0.0
C  U(N)            CURRENT SOLUTION VECTOR
C  RESD(N)          VECTOR WHICH WILL CONTAIN THE RESIDUAL ON EXIT
C  UDOT(N)         CURRENT ESTIMATE OF DU/DT
C  WK(1)           REAL WORKSPACE - DEFINED IN INICHB
C  IWK(1)          INTEGER WORKSPACE - NOT USED HERE.
C  IRES            INDICATOR FOR DASSL FROM RESIDUAL ROUTINE.
C                  ON EXIT = -1 THEN ILLEGAL SOLUTION VALUES HAVE BEEN
C                               FOUND .
C                           =-2 DASSL SHOULD HALT THE INTEGRATION.
C
C  ONLY  RESD(N) IS ALTERED ON EXIT : IT CONTAINS THE CURRENT RESIDUAL
C***********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION  T
      INTEGER           IRES
C     .. Array Arguments ..
      DOUBLE PRECISION  RESD(1), U(1), UDOT(1), WK(1)
      INTEGER           IWK(1)
C     .. Scalars in Common ..
      INTEGER           I10, I10A, I10B, I11, I11A, I11B, I12, I13, I14,
     *                  I15, I16, I17, I18, I19, I2, I3, I4, I5, I6, I7,
     *                  I8, I9, M, NEL, NPDE, NPTL, NPTS, NV, NVST, NXI
      CHARACTER*6       PDCODE
C     .. Local Scalars ..
      INTEGER           I, IBK, IFL, IR, ITYPE, IV, J, N
      CHARACTER*240     ERRMSG
C     .. External Subroutines ..
      EXTERNAL          CHINTR, CRES, DRES, SCHERR, SODEFN
C     .. Common blocks ..
      COMMON            /DISCHK/PDCODE
      COMMON            /SCHSZ/I2, I3, I4, I5, I6, I7, I8, I9, I10,
     *                  I10A, I10B, I11, I11A, I11B, I12, I13, I14, I15,
     *                  I16, I17, I18, I19
      COMMON            /SCHSZ1/NEL, NPTL, NPDE, NPTS, M, NV, NXI, NVST
C     .. Save statement ..
      SAVE              /SCHSZ1/, /SCHSZ/, /DISCHK/
C     .. Executable Statements ..
C
      IF (PDCODE.NE.'C0CHEB') THEN
         ERRMSG =
     *' C0CHEB-RES ROUTINE ERROR-THE SETUP ROUTINE INICHB       WAS NOT
     *CALLED BEFORE DASSL  WAS ENTERED'
         CALL SCHERR(ERRMSG,1,0,0,0,0,0.0D0,0.0D0)
         IRES = -2
         RETURN
      END IF
C
      IR = 1
      IRES = 1
      N = NPDE*NPTS + NV
      DO 20 J = 1, N
         RESD(J) = 0.0D0
   20 CONTINUE
      IBK = NEL + 1
      IV = NPTS*NPDE
      IF (NV.GT.0) THEN
         IV = NVST
C        GENERATE THE SOLUTION VALUES SPACE DERIVS AND FLUXES AT THE
C        COUPLING POINTS
         ITYPE = 3
         IFL = 0
         CALL CHINTR(NXI,WK(I18),WK(I13),ITYPE,U,NPTS,NPDE,NEL,NPTL,WK,
     *               WK(I10),WK(I5),IBK,IFL,NV,U(IV),UDOT(IV),WK(I11),T,
     *               IR)
         IF (IR.NE.1 .OR. IFL.EQ.1) GO TO 60
C        GENERATE TIME DERIV VALUES AND THEIR SPACE DERIVS AT THE
C        COUPLING POINTS.
         ITYPE = 2
         CALL CHINTR(NXI,WK(I18),WK(I16),ITYPE,UDOT,NPTS,NPDE,NEL,NPTL,
     *               WK,WK(I10),WK(I5),IBK,IFL,NV,U(IV),UDOT(IV),WK(I11)
     *               ,T,IR)
         IF (IR.NE.1 .OR. IFL.EQ.1) GO TO 60
C        CALL THE ROUTINE TO DEFINE THE AUXILLARY ODE RESIDUAL.
         CALL SODEFN(T,NV,U(IV),UDOT(IV),NPDE,NXI,WK(I18),WK(I13),
     *               WK(I14),WK(I15),WK(I16),WK(I17),RESD(IV),IRES)
         IF (IRES.NE.1) GO TO 60
      END IF
C       CALL THE CO COLLOCATION DISCRETISATION ROUTINE
      IR = 1
      IF (NPTL.GT.2) THEN
C        GENERAL POLYNOMIAL VERSION.
         CALL CRES(NPDE,NPTS,T,U,RESD,UDOT,M,WK(I6),WK,WK(I2),WK(I5),
     *             WK(I7),WK(I8),WK(I9),WK(I10),WK(I11),NEL,NPTL,WK(I4),
     *             WK(I12),IRES,WK(I10A),WK(I11A),WK(I11B),WK(I10B),NV,
     *             U(IV),UDOT(IV),WK(I19))
      ELSE
C        LINEAR BASIS FUNCTION VERSION.
         CALL DRES(NPDE,NPTS,T,U,RESD,UDOT,M,WK(I6),WK,WK(I2),WK(I5),
     *             WK(I7),WK(I8),WK(I9),WK(I10),WK(I11),NEL,NPTL,WK(I4),
     *             WK(I12),IRES,WK(I10A),WK(I11A),WK(I11B),WK(I10B),NV,
     *             U(IV),UDOT(IV),WK(I19))
      END IF
      DO 40 I = 1, N
         RESD(I) = -RESD(I)
   40 CONTINUE
      IF (IRES.NE.1) THEN
         IR = IRES
         GO TO 60
      END IF
      RETURN
   60 IRES = IR
      IF (IR.EQ.-2) THEN
         ERRMSG =
     *' ROUTINE PDECHB AT TIME T (=R1). THE VALUE OF IRES
     * HAS BEEN SET TO -2 TO TERMINATE INTEGRATION.'
         CALL SCHERR(ERRMSG,1,0,0,0,1,T,0.0D0)
      ELSE IF (IR.NE.-1) THEN
         ERRMSG =
     *' ROUTINE PDECHB AT TIME T (=R1). THE
     *  VALUE OF IRES HAS BEEN SET TO AN ILLEGAL VALUE (=I1).
     *PDECHB HAS RESET IRES TO -1 AND INTEGRATION CONTINUES.'
         CALL SCHERR(ERRMSG,1,0,0,0,1,T,0.0D0)
         IRES = -1
      END IF
      RETURN
C
C---------------------------END OF PDECHB-----------------------------
C
      END
      SUBROUTINE CRES(NPDE,NPTS,T,U,RES,UDOT,M,X,OMEGA,DU,XBK,BETA,
     *                GAMMA,DUDX,R,Q,NEL,NPTL,XC,CCR,IRES,RT,QT,UDT,
     *                UTDX,NV,V,VDOT,VDUM)
C**********************************************************************
C       CHEBYSHEV C0 COLLOCATION SPATIAL DISCRETISATION ROUTINE
C       FOR POLYNOMIALS OF DEGREE 2 AND ABOVE.
C**********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISIONT
      INTEGER         IRES, M, NEL, NPDE, NPTL, NPTS, NV
C     .. Array Arguments ..
      DOUBLE PRECISIONBETA(NPDE,4), CCR(NPTL), DU(NPTL,NPTL),
     *                DUDX(NPDE,NPTL), GAMMA(NPDE,4), OMEGA(NPTL,NPTL),
     *                Q(NPDE,NPTL), QT(NPDE,NPTL), R(NPDE,NPTL),
     *                RES(NPDE,NPTS), RT(NPDE,NPTL), U(NPDE,NPTS),
     *                UDOT(NPDE,NPTS), UDT(NPDE,NPTL), UTDX(NPDE,NPTL),
     *                V(1), VDOT(1), VDUM(1), X(NPTS), XBK(1), XC(NPTL)
C     .. Scalars in Common ..
      DOUBLE PRECISIONTWOU
C     .. Local Scalars ..
      DOUBLE PRECISIONH, MP1, SAVEL, SAVER, SFIRST
      INTEGER         I, II, IJ, IK, IV, J, JJ, JK, K, KJ, NM1
C     .. Local Arrays ..
      INTEGER         IZ(3)
C     .. External Subroutines ..
      EXTERNAL        SBNDR, SPDEFN
C     .. Intrinsic Functions ..
      INTRINSIC       MAX0, MIN0
C     .. Common blocks ..
      COMMON          /SCHSZ3/TWOU
C     .. Save statement ..
      SAVE            /SCHSZ3/
C     .. Executable Statements ..
      NM1 = NPTL - 1
      IV = MAX0(1,NV)
      MP1 = 1.0D0
      DO 260 I = 1, NEL
         JJ = (I-1)*NM1
         IJ = JJ + 1
         H = 2.0D0/(XBK(I+1)-XBK(I))
         DO 20 IK = 1, 3
            IZ(IK) = 1
   20    CONTINUE
C        ***************************************************************
C        MAIN LOOP OVER ALL THE SPATIAL ELEMENTS START BY
C        FORMING THE SPACE DERIVS OF U AND UDOT IN DUDX AND UTDX
C        RESPECTIVELY.
C        **************************************************************
         DO 80 K = 1, NPDE
            DO 60 II = 1, NPTL
               DUDX(K,II) = 0.0D0
               UTDX(K,II) = 0.0D0
               DO 40 J = 1, NPTL
                  UTDX(K,II) = UTDX(K,II) + DU(II,J)*UDOT(K,JJ+J)*H
                  DUDX(K,II) = DUDX(K,II) + DU(II,J)*U(K,JJ+J)*H
   40          CONTINUE
   60       CONTINUE
   80    CONTINUE
C        ---------------------------------------------------------------
C        EVALUATE THE FUNCTIONS Q AND R IN THIS ELEMENT
C        --------------------------------------------------------------
         CALL SPDEFN(T,X(IJ),NPTL,NPDE,U(1,IJ),DUDX,UDOT(1,IJ),UTDX,Q,R,
     *               IV,V,VDOT,IZ(1))
         IF (M.GT.0) THEN
C           MODIFY Q FUNCTION IF POLAR CO-ORDINATES
            KJ = 1
            IF (X(IJ).LE.TWOU) THEN
               MP1 = 1.0D0 + M
               KJ = 2
               DO 100 K = 1, NPDE
C                 R(K,1) = 0.0D0
                  Q(K,1) = Q(K,1)/(M+1)
  100          CONTINUE
            END IF
            DO 140 J = KJ, NPTL
               DO 120 K = 1, NPDE
                  Q(K,J) = Q(K,J) - R(K,J)*M/X(JJ+J)
  120          CONTINUE
  140       CONTINUE
         END IF
C        **************************************************************
C        FORM THE FUNCTIONS BETA AND GAMMA IN THE BOUNDARY CONDITIONS
C        **************************************************************
         IF (I.EQ.1) THEN
C           LEFT HAND BOUNDARY CONDITIONS
            CALL SBNDR(T,BETA(1,1),GAMMA(1,1),U(1,1),DUDX,UDOT(1,1),
     *                 UTDX,NPDE,.TRUE.,IV,V,VDOT,IZ(2))
            IF (IZ(2).NE.1) IRES = IZ(2)
         END IF
         IF (I.EQ.NEL) THEN
C           RIGHT HAND BOUNDARY CONDITIONS
            CALL SBNDR(T,BETA(1,2),GAMMA(1,2),U(1,NPTS),DUDX(1,NPTL),
     *                 UDOT(1,NPTS),UTDX(1,NPTL),NPDE,.FALSE.,IV,V,VDOT,
     *                 IZ(3))
            IF (IZ(3).NE.1) IRES = IZ(3)
         END IF
C        ---------------------------------------------------------------
C        SET UP SAVEL AND SAVER  FOR THE BOUNDARY AND INTERFACE
C        CONDITIONS AND FORM DRDX  BY OVERWRITING DUDX
C        --------------------------------------------------------------
         KJ = MAX0(2,I)
         JK = MIN0(NEL,I+1) + 1
         SAVEL = 1.0D0/(XBK(KJ)+XBK(I+1)-XBK(KJ-1)-XBK(I))
         SAVER = 1.0D0/(XBK(JK)+XBK(I+1)-XBK(JK-1)-XBK(I))
         IF (I.EQ.1) SFIRST = SAVEL
         DO 200 K = 1, NPDE
            DO 180 II = 1, NPTL
               DUDX(K,II) = 0.0D0
               DO 160 J = 1, NPTL
                  DUDX(K,II) = DUDX(K,II) + DU(II,J)*R(K,J)
  160          CONTINUE
  180       CONTINUE
  200    CONTINUE
C        ---------------------------------------------------------------
C         FORM THE RESIDUAL AND THE INTERFACE CONDITIONS
C        --------------------------------------------------------------
         DO 240 J = 1, NPDE
            DO 220 K = 2, NM1
C              COLLOCATION AT INTERIOR POINT
               RES(J,JJ+K) = Q(J,K) - DUDX(J,K)*H
  220       CONTINUE
            JK = IJ + NM1
            RES(J,IJ) = RES(J,IJ) + ((Q(J,1)/H-DUDX(J,1)-R(J,1)/CCR(1))
     *                  *2.0)*SAVEL
            RES(J,JK) = ((Q(J,NPTL)/H-DUDX(J,NPTL)+R(J,NPTL)/CCR(1))
     *                  *2.0)*SAVER
  240    CONTINUE
C        TEST TO SEE IF ILLEGAL SOLUTION VALUES HAVE BEEN FOUND.
         IF (IZ(1).NE.1) THEN
            IRES = IZ(1)
            GO TO 300
         END IF
  260 CONTINUE
C
C                             PROCESS THE BOUNDARY CONDITIONS
      DO 280 J = 1, NPDE
C        L.H.--BOUNDARY CONDITION IS PROCESSED
         RES(J,1) = MP1*(RES(J,1)*BETA(J,1)*2.0D0+GAMMA(J,1)
     *              *4.0D0/CCR(1)*SFIRST)
C        R.H.---BOUNDARY CONDITION IS PROCESSED
         RES(J,NPTS) = RES(J,NPTS)*BETA(J,2)*2.0D0 - GAMMA(J,2)
     *                 *4.0D0/CCR(1)*SAVER
  280 CONTINUE
  300 CONTINUE
      RETURN
C-------END OF CRES----------------------------------------------------
C
      END
      SUBROUTINE DRES(NPDE,NPTS,T,U,RES,UDOT,M,X,OMEGA,DU,XBK,BETA,
     *                GAMMA,DUDX,R,Q,NEL,NPTL,XC,CCR,IRES,RT,QT,UDT,
     *                UTDX,NV,V,VDOT,VDUM)
C**********************************************************************
C       CHEBYSHEV C0 COLLOCATION ROUTINE
C       THIS VERSION FOR USE WITH LINEAR BASIS FUNCTIONS ONLY
C**********************************************************************
C
C     .. Scalar Arguments ..
      DOUBLE PRECISIONT
      INTEGER         IRES, M, NEL, NPDE, NPTL, NPTS, NV
C     .. Array Arguments ..
      DOUBLE PRECISIONBETA(NPDE,4), CCR(NPTL), DU(NPTL,NPTL),
     *                DUDX(NPDE,NPTL), GAMMA(NPDE,4), OMEGA(NPTL,NPTL),
     *                Q(NPDE,NPTL), QT(NPDE,NPTL), R(NPDE,NPTL),
     *                RES(NPDE,NPTS), RT(NPDE,NPTL), U(NPDE,NPTS),
     *                UDOT(NPDE,NPTS), UDT(NPDE,NPTL), UTDX(NPDE,NPTL),
     *                V(1), VDOT(1), VDUM(1), X(NPTS), XBK(1), XC(NPTL)
C     .. Scalars in Common ..
      DOUBLE PRECISIONTWOU
C     .. Local Scalars ..
      DOUBLE PRECISIONH, MP1, SAVEL, SAVER, SFIRST, TEM
      INTEGER         I, II, IJ, IK, IV, J, JJ, JK, K, KJ, NM1
C     .. Local Arrays ..
      INTEGER         IZ(3)
C     .. External Subroutines ..
      EXTERNAL        SBNDR, SPDEFN
C     .. Intrinsic Functions ..
      INTRINSIC       MAX0, MIN0
C     .. Common blocks ..
      COMMON          /SCHSZ3/TWOU
C     .. Save statement ..
      SAVE            /SCHSZ3/
C     .. Executable Statements ..
      NM1 = NPTL - 1
      IV = MAX0(1,NV)
      MP1 = 1.0D0
      DO 220 I = 1, NEL
         JJ = (I-1)*NM1
         IJ = JJ + 1
         H = 2.0D0/(XBK(I+1)-XBK(I))
         DO 20 IK = 1, 3
            IZ(IK) = 1
   20    CONTINUE
C        ***************************************************************
C        MAIN LOOP OVER ALL THE SPATIAL ELEMENTS START BY FORMING THE
C        SPACE DERIVS OF U AND UDOT IN DUDX AND UTDX RESPECTIVELY.
C        **************************************************************
         DO 80 K = 1, NPDE
            DO 60 II = 1, NPTL
               DUDX(K,II) = 0.0D0
               UTDX(K,II) = 0.0D0
               DO 40 J = 1, NPTL
                  UTDX(K,II) = UTDX(K,II) + DU(II,J)*UDOT(K,JJ+J)*H
                  DUDX(K,II) = DUDX(K,II) + DU(II,J)*U(K,JJ+J)*H
   40          CONTINUE
   60       CONTINUE
   80    CONTINUE
C
         IF (I.EQ.1) THEN
C           SAVE THE VALUES NEEDED FOR LEFT BOUNDARY CONDITIONS
            DO 100 J = 1, NPDE
               BETA(J,3) = DUDX(J,1)
               BETA(J,4) = UTDX(J,1)
  100       CONTINUE
         END IF
         IF (I.EQ.NEL) THEN
C           SAVE THE VALUES NEEDED FOR RIGHT BOUNDARY CONDITIONS
            DO 120 J = 1, NPDE
               GAMMA(J,3) = DUDX(J,NPTL)
               GAMMA(J,4) = UTDX(J,NPTL)
  120       CONTINUE
         END IF
C        ---------------------------------------------------------------
C         EVALUATE THE FUNCTIONS Q AND R IN THIS ELEMENT
C        --------------------------------------------------------------
         CALL SPDEFN(T,X(IJ),NPTL,NPDE,U(1,IJ),DUDX,UDOT(1,IJ),UTDX,Q,R,
     *               IV,V,VDOT,IZ(1))
         IF (M.GT.0) THEN
C           MODIFY Q FUNCTION IF POLAR CO-ORDINATES
            KJ = 1
            IF (X(IJ).LE.TWOU) THEN
               MP1 = 1.0D0 + M
               KJ = 2
               DO 140 K = 1, NPDE
C                 R(K,1) = 0.0D0
                  Q(K,1) = Q(K,1)/(M+1)
  140          CONTINUE
            END IF
            DO 180 J = KJ, NPTL
               DO 160 K = 1, NPDE
                  Q(K,J) = Q(K,J) - R(K,J)*M/X(JJ+J)
  160          CONTINUE
  180       CONTINUE
         END IF
C        ---------------------------------------------------------------
C        SET UP SAVEL AND SAVER FOR BOUNDARY AND INTERFACE CONDITIONS
C        --------------------------------------------------------------
         KJ = MAX0(2,I)
         JK = MIN0(NEL,I+1) + 1
         SAVEL = 1.0D0/(XBK(KJ)+XBK(I+1)-XBK(KJ-1)-XBK(I))
         SAVER = 1.0D0/(XBK(JK)+XBK(I+1)-XBK(JK-1)-XBK(I))
         IF (I.EQ.1) SFIRST = SAVEL
C        ---------------------------------------------------------------
C         FORM THE RESIDUAL AND THE INTERFACE CONDITIONS
C        --------------------------------------------------------------
         DO 200 J = 1, NPDE
            JK = IJ + NM1
            TEM = R(J,1) + R(J,NPTL)
            RES(J,IJ) = RES(J,IJ) + (Q(J,1)*2.0/H-TEM)*SAVEL
            RES(J,JK) = (Q(J,NPTL)*2.0/H+TEM)*SAVER
  200    CONTINUE
C        TEST TO SEE IF ILLEGAL SOLUTION VALUES HAVE BEEN FOUND.
         IF (IZ(1).NE.1) THEN
            IRES = IZ(1)
            GO TO 280
         END IF
  220 CONTINUE
C**********************************************************************
C    EVALUATE THE FUNCTIONS BETA AND GAMMA AT THE BOUNDARY CONDITIONS
C**********************************************************************
C
      CALL SBNDR(T,BETA(1,1),GAMMA(1,1),U(1,1),BETA(1,3),UDOT(1,1),
     *           BETA(1,4),NPDE,.TRUE.,IV,V,VDOT,IZ(2))
      CALL SBNDR(T,BETA(1,2),GAMMA(1,2),U(1,NPTS),GAMMA(1,3),UDOT(1,
     *           NPTS),GAMMA(1,4),NPDE,.FALSE.,IV,V,VDOT,IZ(3))
C
C                             PROCESS THE BOUNDARY CONDITIONS
      DO 240 J = 1, NPDE
C        L.H.--BOUNDARY CONDITION IS PROCESSED
         RES(J,1) = MP1*(RES(J,1)*BETA(J,1)*2.0D0+GAMMA(J,1)
     *              *4.0D0/CCR(1)*SFIRST)
C        R.H.---BOUNDARY CONDITION IS PROCESSED
         RES(J,NPTS) = RES(J,NPTS)*BETA(J,2)*2.0D0 - GAMMA(J,2)
     *                 *4.0D0/CCR(1)*SAVER
  240 CONTINUE
      DO 260 IK = 2, 3
         IF (IZ(IK).NE.1) IRES = IZ(IK)
  260 CONTINUE
  280 CONTINUE
      RETURN
C-------END OF DRES----------------------------------------------------
C
      END
C***********************************************************************
C
      SUBROUTINE CHINTR(NP,XP,UP,ITYPE,U,NPTS,NPDE,NEL,NPTL,OMEGA,COEFF,
     *                  XBK,IBK,IFLAG,NV,V,VDOT,RT,T,IR)
C
C***********************************************************************
C         PARAMETER LIST
C         **************
C         XP(NP)         THE MESH POINTS AT WHICH INTERPOLATED VALUES
C                        ARE REQUIRED. THESE POINTS SUCH BE IN
C                        INCREASING ORDER.
C         UP(NPDE,NP,ITYPE)  ARRAY THAT HOLDS THE VALUES FOUND BY
C                            INTERPOLATION.
C         IF ITYPE >= 1  UP(J,K,1) HOLDS THE SOLUTION VALUE AT MESH
C                                  POINT XP(K) FOR JTH PDE
C         IF ITYPE >= 2  UP(J,K,2) HOLDS THE SPACE DERIV OF THE SOLUTION
C                                  AT POINT XP(K) FOR JTH PDE.
C         IF ITYPE >= 3  UP(J,K,3) HOLDS THE FLUX R(..) AT THE POINT
C                                  XP(K) FOR THE JTH PDE.
C
C         U(NPDE,NPTS)   ORIGINAL SOLUTION VECTOR FROM THE ODE CODE.
C
C         NPTS           THE NUMBER OF MESH POINTS USED IN COMPUTING U.
C         NPDE           THE NUMBER OF PDES IN THE PROBLEM.
C         NEL            THE NUMBER OF SPATIAL ELEMENTS IN THE MESH.
C         NPTL           THE NUMBER OF MESH POINTS PER ELEMENT.
C                        THEREFORE NPTS = NEL*(NPTL-1) + 1
C         OMEGA          MATRIX USED IN MAPPING FROM THE SOLUTION ON A
C                        SPATIAL INTERVAL TO ITS CHEBYSHEV COEFFS.
C         COEFFS         WORKSPACE USED TO HOLD THESE COEFFS.
C         XBK(IBK)       ARRAY USED TO HOLD THE BREAKPOINTS BETWEEN THE
C                        SPATIAL ELEMENTS.
C         IFLAG          ERROR FLAG SET TO 0 UNLESS EXTRAPOLATION IS
C                        TRIED AND THEN SET TO 1.
C         NV             THE SIZE OF THE ADDITIONAL ODE SYSTEM THAT IS
C                        COUPLED TO THE PDE SYSTEM.
C         V(NV)          COUPLED ODE VARIABLES
C         VDOT(NV)       AND THEIR TIME DERIVS.
C         T              THE CURRENT VALUE OF THE TIME VARIABLE.
C   NOTE --- THESE LAST FOUR VARIABLES ARE ONLY USED IF ITYPE = 3
C   ****     OTHERWISE DUMMY VARIABLES MAY BE PASSED ACROSS.
C         IR ; IRES PARAM TO TEST FOR ILLEGAL VALUES
C                THE METHOD USED IS DECOMPOSITION OF THE SOLUTION
C         PER ELEMENT INTO CHEBYSHEV COEFFICIENTS. THIS IS DONE BY
C         MATRIX MULTIPLICATION USING THE OMEGA MATRIX .  F.F.T.
C         COULD ALSO BE USED. INTERPOLATION IS USED TO PROVIDE THOSE
C         SOLUTION VALUES IN THE ELEMENT (USING CLENSHAWS ALGORITHM).
C
C***********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION  T
      INTEGER           IBK, IFLAG, IR, ITYPE, NEL, NP, NPDE, NPTL,
     *                  NPTS, NV
C     .. Array Arguments ..
      DOUBLE PRECISION  COEFF(NPDE,NPTL,2), OMEGA(NPTL,NPTL),
     *                  RT(NPDE,NPTL,3), U(NPDE,NPTS), UP(NPDE,NP,*),
     *                  V(1), VDOT(1), XBK(IBK), XP(NP)
C     .. Scalars in Common ..
      DOUBLE PRECISION  TWOU
C     .. Local Scalars ..
      DOUBLE PRECISION  AL, BR, BR1, BR2, TEM, TEM1
      INTEGER           I, II, IONE, IP, IP1, IX, IY, IZ, J, K, NM1
      CHARACTER*240     ERRMSG
C     .. Local Arrays ..
      DOUBLE PRECISION  XCON(2)
C     .. External Subroutines ..
      EXTERNAL          SCHERR, SPDEFN
C     .. Intrinsic Functions ..
      INTRINSIC         MIN0
C     .. Common blocks ..
      COMMON            /SCHSZ3/TWOU
C     .. Save statement ..
      SAVE              /SCHSZ3/
C     .. Executable Statements ..
C
C  TREAT EACH ELEMENT SEPARATELY
C
      TEM = 1.0D0 + TWOU
      TEM1 = 1.0D0 - TWOU
      IONE = 1
      IP = 0
      NM1 = NPTL - 1
      IZ = 0
      DO 280 I = 1, NEL
         IP1 = I + 1
         IF (XBK(I).GT.(XBK(I+1)*TEM1-TWOU)) THEN
            ERRMSG =
     *' INTERC ROUTINE BREAKPOINT NUMBER (=I1)                  WITH VAL
     *UE (=R1) IS TOO CLOSE OR LARGER THAN BREAKPOINT NO        (=I2) WI
     *TH VALUE (=R2). INCORRECT CALL TO INTERC ASSUMED OR       WORKSPAC
     *E CORRUPTED'
            CALL SCHERR(ERRMSG,1,2,I,IP1,2,XBK(I),XBK(IP1))
            GO TO 300
         END IF
   20    IP = IP + 1
         IF (IP.EQ.(NP+1)) GO TO 300
         IF (XP(IP).LT.(XBK(I)*TEM1-TWOU)) GO TO 20
         IF (XP(IP).GT.(XBK(I+1)*TEM+TWOU)) GO TO 260
         IF (XP(IP).GT.(XBK(I+1)*TEM1-TWOU)) THEN
            IF (I.LT.NEL .AND. ITYPE.GE.2) IZ = 1
C           IZ = 1 MEANS THAT WEIGHTED AVERAGE MUST BE USED FOR
C           DERIVATIVE VALUES THAT ARE REQUESTED AT XBK(I+1)
         END IF
C        ***************************************************************
C         PROCESS A SEQUENCE OF XP(J) VALUES IN ELEMENT I
C         IX = START OF CORRECT PART OF SOLUTION VECTOR U
C         FORM THE CHEBYSHEV COEFFS IN THE ARRAY COEFF.
C        **************************************************************
         IX = NM1*(I-1)
         DO 80 K = 1, NPDE
            DO 60 J = 1, NPTL
               COEFF(K,J,1) = 0.0D0
               DO 40 II = 1, NPTL
                  COEFF(K,J,1) = COEFF(K,J,1) + OMEGA(J,II)*U(K,IX+II)
   40          CONTINUE
   60       CONTINUE
   80    CONTINUE
C        FORM THE CHEBYSHEV COEFFS OF THE SPACE DERIV.
         IF (ITYPE.GE.2) THEN
            DO 120 K = 1, NPDE
               COEFF(K,NPTL,2) = 0.0D0
               COEFF(K,NPTL-1,2) = 2.0D0*NM1*COEFF(K,NPTL,1)
               DO 100 J = 2, NM1
                  COEFF(K,NPTL-J,2) = COEFF(K,NPTL-J+2,2) + COEFF(K,
     *                                NPTL-J+1,1)*2*(NPTL-J)
  100          CONTINUE
               COEFF(K,1,2) = COEFF(K,1,2)*0.5D0
  120       CONTINUE
         END IF
         XCON(1) = 2.0D0/(XBK(I+1)-XBK(I))
         XCON(2) = -0.5D0*XCON(1)*(XBK(I+1)+XBK(I))
         IY = MIN0(2,ITYPE)
  140    DO 200 II = 1, IY
            DO 180 K = 1, NPDE
               BR1 = 0.0D0
               BR2 = 0.0D0
C              COEFF(K,NPTL) IS THE NPTL-TH  COEFF OF SOLUTION OF PDE
               AL = (XP(IP)*XCON(1)+XCON(2))*2.0D0
               BR = COEFF(K,NPTL,II)
               DO 160 J = 1, NM1
                  BR2 = COEFF(K,NPTL-J,II) + AL*BR - BR1
                  BR1 = BR
                  BR = BR2
  160          CONTINUE
               IF (II.EQ.1) THEN
                  UP(K,IP,II) = BR - BR1*AL*0.5D0
               ELSE IF (IZ.LT.2) THEN
                  UP(K,IP,II) = (BR-BR1*AL*0.5)*XCON(1)
               ELSE
                  UP(K,IP,II) = 1.D0/(XBK(I+1)-XBK(I-1))*(UP(K,IP,II)
     *                          *(XBK(I)-XBK(I-1))+(BR-BR1*AL*0.5)
     *                          *XCON(1)*(XBK(I+1)-XBK(I)))
               END IF
  180       CONTINUE
  200    CONTINUE
C        IF REQUIRED FORM THE FLUX AT THE INTERPLOATED POINTS (UNLESS
C        DERIV IS BEING FORMED BY WEIGHTED AVERAGE IN WHICH CASE WAIT
C        UNTIL THE FORMATION IS COMPLETE.
         IF (ITYPE.GE.3 .AND. IZ.NE.1) THEN
C           ZERO WORKSPACES USED IN THE FLUX CALL.
            DO 240 J = 1, 3
               DO 220 K = 1, NPDE
                  RT(K,1,J) = 0.0D0
  220          CONTINUE
  240       CONTINUE
            IR = 1
C           FORM THE FLUX AT THE INTERPOLATED POINTS.
            CALL SPDEFN(T,XP(IP),IONE,NPDE,UP(1,IP,1),UP(1,IP,2),RT(1,1,
     *                  1),RT(1,1,2),RT(1,1,3),UP(1,IP,3),NV,V,VDOT,IR)
            IF (IR.NE.1) THEN
               ERRMSG =
     *' ROUTINE SPDEFN SET IRES (=I1) WHEN CALLED FROM              THE
     *INTERPOLATION ROUTINE TO CALCULATE FLUX VALUES'
               CALL SCHERR(ERRMSG,1,1,IR,0,0,0.0D0,0.0D0)
               GO TO 300
            END IF
         END IF
         IF (IP.EQ.NP) GO TO 280
         IP = IP + 1
         IF (IZ.EQ.1) THEN
            IZ = 2
            GO TO 260
C           TO CALCULATE THE OTHER ELEMENTS CONTRIBUTION TO DERIV.
         END IF
         IF (IZ.EQ.2) IZ = 0
         IF (XP(IP).LT.(XBK(I+1)*TEM1-TWOU)) THEN
C           PROCESS ANOTHER POINT IN THIS ELEMENT
            GO TO 140
         ELSE IF (XP(IP).LT.(XBK(I+1)*TEM+TWOU)) THEN
            IF ((I+1).LT.NEL .AND. ITYPE.GE.2) IZ = 1
C           IZ = 1 MEANS THAT WEIGHTED AVERAGE MUST BE USED FOR
C           DERIVATIVE VALUES THAT ARE REQUESTED AT XBK(I+1)
            GO TO 140
         END IF
  260    IP = IP - 2
  280 CONTINUE
      RETURN
  300 IFLAG = 1
      RETURN
C---------END OF CHINTR--------------------------------------------
C
      END
      SUBROUTINE INTERC(XP,UP,NP,U,NEQ,NPDE,IFLAG,ITYPE,WK,IWK)
C********************************************************************
C
C        SPACE INTERPOLATION ROUTINE FOR POST-PROCESSING OF SOLUTION
C        PRODUCED BY DASSL.
C        THIS ROUTINES PROVIDES VALUES OF THE SOLUTION AND POSSIBLY THE
C        FIRST DERIV IN SPACE AND THE FLUX ON THE MESH XP(NP).
C
C        PARAMETERS
C       --------------
C        NPDE     ON ENTRY MUST CONTAIN NO OF PARABOLIC EQUATIONS
C        NPTS     ON ENTRY MUST CONTAIN THE NUMBER OF SPATIAL
C                 MESH POINTS USED IN TIME INTEGRATION.
C        NP       ON ENTRY MUST CONTAIN THE NUMBER OF SPATIAL
C                 INTERPOLATION POINTS
C        XP(NP)   ARRAY WHICH ON ENTRY
C                 CONTAINS THE SPATIAL INTERPOLATION POINTS
C                 WE ASSUME THAT
C                    XP(I) <  XP(I+1)  ,  I = 1,...,NP-1
C        UP(NPDE,NP,ITYPE)  EMPTY ARRAY FOR THE INTERPOLATED VALUES AT
C                           THE CURRENT TIME LEVEL. THE VALUES OF THIS
C                           ARRAY ON EXIT DEPEND ON THE PARAMETER ITYPE.
C        U(NPDE,NPTS) THE CURRENT SOLUTION VECTOR COMPUTED BY THE ODE
C                  TIME INTEGRATOR MUST BE SUPPLIED IN THIS VECTOR.
C        IFLAG          ERROR FLAG       = 0 ON SUCCESSFUL RETURN
C                                        = 1 IF EXTRAPOLATION TRIED.
C                                        = 2 IF WORKSPACE NOT INITIAL
C                                               ISED ON ENTRY BY INICHB.
C                                        = 3 ILLEGAL VALUE OF ITYPE.
C        ITYPE = 1  ONLY THE SOLUTION IS OUTPUT IN THE ARRAY UP
C                   UP(J,K,1) HOLDS U(XP(K),T) FOR PDE J
C                2  AS FOR 1 BUT THE FIRST DERIV IS ALSO OUTPUT.
C                   UP(J,K,2) HOLDS D/DX U(XP(K),T).
C
C        WK(IWK) THE WORKSPACE USED BY THE CHEBYSHEV METHOD. THIS
C                MUST BE THE WORKSPACE INITIALISED BY INICHB.
C**********************************************************************
C     .. Scalar Arguments ..
      INTEGER           IFLAG, ITYPE, IWK, NEQ, NP, NPDE
C     .. Array Arguments ..
      DOUBLE PRECISION  U(NEQ), UP(NPDE,NP,ITYPE), WK(IWK), XP(NP)
C     .. Scalars in Common ..
      DOUBLE PRECISION  TWOU
      INTEGER           I10, I11, I19, I5, I9, MM, NEL, NNPDE, NNPTS,
     *                  NPTL, NV, NVST, NXI
      CHARACTER*6       PDCODE
C     .. Arrays in Common ..
      INTEGER           IA(3), IB(3), IC(2), ID(9)
C     .. Local Scalars ..
      DOUBLE PRECISION  TEMP
      INTEGER           I, IBK, J, K, NPTS
      CHARACTER*240     ERRMSG
C     .. External Subroutines ..
      EXTERNAL          INTRCH, SCHERR
C     .. Intrinsic Functions ..
      INTRINSIC         DABS
C     .. Common blocks ..
      COMMON            /DISCHK/PDCODE
      COMMON            /SCHSZ/IA, I5, IB, I9, I10, IC, I11, ID, I19
      COMMON            /SCHSZ1/NEL, NPTL, NNPDE, NNPTS, MM, NV, NXI,
     *                  NVST
      COMMON            /SCHSZ3/TWOU
C     .. Save statement ..
      SAVE              /SCHSZ1/, /SCHSZ/, /DISCHK/, /SCHSZ3/
C     .. Executable Statements ..
      IF (PDCODE.NE.'C0CHEB') THEN
         IFLAG = 1
         GO TO 80
      END IF
      IFLAG = 0
      IBK   = NEL + 1
      IF (ITYPE.NE.1 .AND. ITYPE.NE.2) THEN
         ERRMSG =
     *' ILLEGAL VALUE OF ITYPE IN CALL TO SUBROUTINE INTERC
     *  THE VALUE IS (=I1), BUT SHOULD BE 1 OR 2 '
         CALL SCHERR(ERRMSG,1,1,ITYPE,0,0,0.0D0,0.0D0)
         IFLAG = 3
         GO TO 80
      END IF
C
C   TEST THE INTERPOLATION POINTS XP(NP) TO ENSURE THAT THEY ARE IN
C   INCREASING ORDER AND THAT IF ITYPE = 2 (DERIVATIVES REQUIRED) THE
C   POINTS DO NOT CONFLICT WITH THE BREAK-POINTS.
C
      DO 20 I = 2, NP
         TEMP = XP(I) - XP(I-1)
         IF (TEMP.LE.TWOU) THEN
            ERRMSG =
     *' INTERC ROUTINE CALLED WITH INTERP.POINTS NOT            IN STRIC
     *TLY INCREASING ORDER I.E. COMPONENT NO (=I1)              WITH VAL
     *UE (=R1) IS GREATER THAN COMPONENT( =I2)                  WITH VAL
     *UE (=R2).'
            CALL SCHERR(ERRMSG,1,2,J,I,2,XP(J),XP(I))
         END IF
   20 CONTINUE
      IF (ITYPE.GE.2 .AND. IBK.GT.2) THEN
         DO 60 I = 1, NP
            DO 40 J = 2, NEL
               TEMP = DABS(XP(I)-WK(I5-1+J))
               IF (TEMP.LE.TWOU) THEN
                  K = I5 + J - 1
                  ERRMSG =
     *' INTERC ROUTINE CALLED WITH ITYPE = 2                    AND INTE
     *RP. POINTS EQUAL TO BREAK-POINTS I.E.                     COMPONEN
     *T NO (=I1) WITH VALUE (=R1)                               IS CLOSE
     * TO BREAK POINT(=I2) WITH VALUE (=R2).'
                  CALL SCHERR(ERRMSG,1,2,I,J,2,XP(I),WK(K))
               END IF
   40       CONTINUE
   60    CONTINUE
      END IF
C
C    CALL THE INTERPOLATION ROUTINE.
C
      NPTS = NNPTS
      CALL INTRCH(NP,XP,UP,ITYPE,U,NPTS,NPDE,NEL,NPTL,WK,WK(I10),WK(I5),
     *            IBK,IFLAG)
   80 CONTINUE
      RETURN
      END
C***********************************************************************
C
      SUBROUTINE INTRCH(NP,XP,UP,ITYPE,U,NPTS,NPDE,NEL,NPTL,OMEGA,COEFF,
     *                  XBK,IBK,IFLAG)
C
C***********************************************************************
C         PARAMETER LIST
C         **************
C         XP(NP)         THE MESH POINTS AT WHICH INTERPOLATED VALUES
C                        ARE REQUIRED. THESE POINTS SUCH BE IN
C                        INCREASING ORDER.
C         UP(NPDE,NP,ITYPE)  ARRAY THAT HOLDS THE VALUES FOUND BY
C                            INTERPOLATION.
C         IF ITYPE >= 1  UP(J,K,1) HOLDS THE SOLUTION VALUE AT MESH
C                                  POINT XP(K) FOR JTH PDE
C         IF ITYPE >= 2  UP(J,K,2) HOLDS THE SPACE DERIV OF THE SOLUTION
C                                  AT POINT XP(K) FOR JTH PDE.
C
C         U(1..NEQN)     ORIGINAL SOLUTION VECTOR FROM THE ODE CODE.
C
C         NPTS           THE NUMBER OF MESH POINTS USED IN COMPUTING U.
C         NPDE           THE NUMBER OF PDES IN THE PROBLEM.
C         NEL            THE NUMBER OF SPATIAL ELEMENTS IN THE MESH.
C         NPTL           THE NUMBER OF MESH POINTS PER ELEMENT.
C                        THEREFORE NPTS = NEL*(NPTL-1) + 1
C         OMEGA          MATRIX USED IN MAPPING FROM THE SOLUTION ON A
C                        SPATIAL INTERVAL TO ITS CHEBYSHEV COEFFS.
C         COEFFS         WORKSPACE USED TO HOLD THESE COEFFS.
C         XBK(IBK)       ARRAY USED TO HOLD THE BREAKPOINTS BETWEEN THE
C                        SPATIAL ELEMENTS.
C         IFLAG          ERROR FLAG SET TO 0 UNLESS EXTRAPOLATION IS
C                        TRIED AND THEN SET TO 1.
C
C                THE METHOD USED IS DECOMPOSITION OF THE SOLUTION
C         PER ELEMENT INTO CHEBYSHEV COEFFICIENTS. THIS IS DONE BY
C         MATRIX MULTIPLICATION USING THE OMEGA MATRIX .  F.F.T.
C         COULD ALSO BE USED. INTERPOLATION IS USED TO PROVIDE THOSE
C         SOLUTION VALUES IN THE ELEMENT (USING CLENSHAWS ALGORITHM).
C
C***********************************************************************
C     .. Scalar Arguments ..
      INTEGER           IBK, IFLAG, ITYPE, NEL, NP, NPDE, NPTL, NPTS
C     .. Array Arguments ..
      DOUBLE PRECISION  COEFF(NPDE,NPTL,2), OMEGA(NPTL,NPTL),
     *                  U(NPDE,NPTS), UP(NPDE,NP,1), XBK(IBK), XP(NP)
C     .. Scalars in Common ..
      DOUBLE PRECISION  TWOU
C     .. Local Scalars ..
      DOUBLE PRECISION  AL, BR, BR1, BR2, CU, TEM, TEM1
      INTEGER           I, II, IP, IP1, IX, IY, IZ, J, K, NM1
      CHARACTER*240     ERRMSG
C     .. Local Arrays ..
      DOUBLE PRECISION  XCON(2)
C     .. External Subroutines ..
      EXTERNAL          SCHERR
C     .. Intrinsic Functions ..
      INTRINSIC         MIN0
C     .. Common blocks ..
      COMMON            /SCHSZ3/TWOU
C     .. Save statement ..
      SAVE              /SCHSZ3/
C     .. Executable Statements ..
C
C  TREAT EACH ELEMENT SEPARATELY
C
      CU = TWOU
      TEM1 = 1 - CU
      TEM = 1 + CU
      IP = 0
      NM1 = NPTL - 1
      IZ = 0
      DO 240 I = 1, NEL
         IP1 = I + 1
         IF (XBK(I).GT.(XBK(I+1)*TEM1-CU)) THEN
            ERRMSG =
     *' INTERC ROUTINE BREAKPOINT NUMBER (=I1)                  WITH VAL
     *UE (=R1) IS TOO CLOSE OR LARGER THAN BREAKPOINT NO        (=I2) WI
     *TH VALUE (=R2). INCORRECT CALL TO INTERC ASSUMED OR       WORKSPAC
     *E CORRUPTED'
            CALL SCHERR(ERRMSG,1,2,I,IP1,2,XBK(I),XBK(IP1))
            GO TO 260
         END IF
   20    IP = IP + 1
         IF (IP.EQ.(NP+1)) GO TO 260
         IF (XP(IP).LT.(XBK(I)*TEM1-CU)) GO TO 20
         IF (XP(IP).GT.(XBK(I+1)*TEM+CU)) THEN
             IP = IP - 1
             GOTO 240
         END IF
         IF (XP(IP).GE.(XBK(I+1)*TEM1-CU)) THEN
            IF (I.LT.NEL .AND. ITYPE.GE.2) IZ = 1
C           IZ = 1 MEANS THAT WEIGHTED AVERAGE MUST BE USED FOR
C           DERIVATIVE VALUES THAT ARE REQUESTED AT XBK(I+1)
         END IF
C        ***************************************************************
C         PROCESS A SEQUENCE OF XP(J) VALUES IN ELEMENT I
C         IX = START OF CORRECT PART OF SOLUTION VECTOR U
C         FORM THE CHEBYSHEV COEFFS IN THE ARRAY COEFF.
C        ***************************************************************
         IX = NM1*(I-1)
         DO 80 K = 1, NPDE
            DO 60 J = 1, NPTL
               COEFF(K,J,1) = 0.0D0
               DO 40 II = 1, NPTL
                  COEFF(K,J,1) = COEFF(K,J,1) + OMEGA(J,II)*U(K,IX+II)
   40          CONTINUE
   60       CONTINUE
   80    CONTINUE
C        FORM THE CHEBYSHEV COEFFS OF THE SPACE DERIV.
         IF (ITYPE.GE.2) THEN
            DO 120 K = 1, NPDE
               COEFF(K,NPTL,2) = 0.0D0
               COEFF(K,NPTL-1,2) = 2.0D0*NM1*COEFF(K,NPTL,1)
               DO 100 J = 2, NM1
                  COEFF(K,NPTL-J,2) = COEFF(K,NPTL-J+2,2) + COEFF(K,
     *                                NPTL-J+1,1)*2*(NPTL-J)
  100          CONTINUE
               COEFF(K,1,2) = COEFF(K,1,2)*0.5D0
  120       CONTINUE
         END IF
         XCON(1) = 2.0D0/(XBK(I+1)-XBK(I))
         XCON(2) = -0.5D0*XCON(1)*(XBK(I+1)+XBK(I))
         IY = MIN0(2,ITYPE)
  140    DO 200 II = 1, IY
            DO 180 K = 1, NPDE
               BR1 = 0.0D0
               BR2 = 0.0D0
C               COEFF(K,NPTL) IS THE NPTL-TH  COEFF OF SOLUTION OF PDE K
               AL = (XP(IP)*XCON(1)+XCON(2))*2.0D0
               BR = COEFF(K,NPTL,II)
               DO 160 J = 1, NM1
                  BR2 = COEFF(K,NPTL-J,II) + AL*BR - BR1
                  BR1 = BR
                  BR = BR2
  160          CONTINUE
               IF (II.EQ.1) THEN
                  UP(K,IP,II) = BR - BR1*AL*0.5D0
               ELSE IF (IZ.LT.2) THEN
                  UP(K,IP,II) = (BR-BR1*AL*0.5)*XCON(1)
               ELSE
                  UP(K,IP,II) = 1.D0/(XBK(I+1)-XBK(I-1))*(UP(K,IP,II)
     *                          *(XBK(I)-XBK(I-1))+(BR-BR1*AL*0.5)
     *                          *XCON(1)*(XBK(I+1)-XBK(I)))
               END IF
  180       CONTINUE
  200    CONTINUE
         IF (IP.EQ.NP) GO TO 240
         IP = IP + 1
         IF (IZ.EQ.1) THEN
            IZ = 2
            GO TO 220
C           TO CALCULATE THE OTHER ELEMENTS CONTRIBUTION TO DERIV.
         END IF
         IF (IZ.EQ.2) IZ = 0
         IF (XP(IP).LE.(XBK(I+1)*TEM1-CU)) THEN
            GO TO 140
         ELSE IF (XP(IP).LE.(XBK(I+1)*TEM+CU)) THEN
            IF (I.LT.NEL .AND. ITYPE.GE.2) IZ = 1
C           IZ = 1 MEANS THAT WEIGHTED AVERAGE MUST BE USED FOR
C           DERIVATIVE VALUES THAT ARE REQUESTED AT XBK(I+1)
            GO TO 140
         END IF
  220    IP = IP - 2
  240 CONTINUE
      RETURN
  260 IFLAG = 1
      RETURN
C---------END OF INTRCH-------------------------------------------
C
      END
      SUBROUTINE SCHERR(MSG,IERT,NI,I1,I2,NR,R1,R2)
C-----------------------------------------------------------------------
C  ERROR HANDLING ROUTINE FOR THE DASSL  INTEGRATION PACKAGE. THIS
C  ROUTINE IS A FORTRAN77 IMPROVED VERSION OF THE ROUTINE USED IN LSODI
C  AND MAKES USE OF CHARACTER HANDLING FACILITIES.
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION  R1, R2
      INTEGER           I1, I2, IERT, NI, NR
      CHARACTER*(*)     MSG
C     .. Scalars in Common ..
      INTEGER           NERR
C     .. Local Scalars ..
      INTEGER           I, IL, IT, J, K, KP1, LWORD
      CHARACTER*(240)   MSG1
C     .. Local Arrays ..
      CHARACTER*(60)    MSGOUT(5)
C     .. Intrinsic Functions ..
      INTRINSIC         LEN, MIN0
C     .. Common blocks ..
      COMMON            /SCHSZ2/NERR
C     .. Save statement ..
      SAVE              /SCHSZ2/
C     .. Executable Statements ..
C-----------------------------------------------------------------------
C
C ALL ARGUMENTS ARE INPUT ARGUMENTS.
C
C MSG    = THE MESSAGE IN CHARACTER FORMAT
C IERT   = THE ERROR TYPE..
C          1 MEANS RECOVERABLE (CONTROL RETURNS TO CALLER).
C          2 MEANS FATAL (RUN IS ABORTED--SEE NOTE BELOW).
C NI     = NUMBER OF INTEGERS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE.
C I1,I2  = INTEGERS TO BE PRINTED, DEPENDING ON NI.
C NR     = NUMBER OF REALS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE.
C R1,R2  = REALS TO BE PRINTED, DEPENDING ON NR.
C-----------------------------------------------------------------------
      IL = LEN(MSG)
C
C    SET MSG1 BLANK AND GET RID OF UNNECESSARY SPACES IN ERROR MESSAGE
C
      J = 1
      IT = MIN0(IL,240)
      DO 20 I = 1, 10
         MSG1(J:) = '                        '
         J = J + 24
   20 CONTINUE
      K = 0
      J = 0
      DO 40 I = 1, IT
         IF (MSG(I:I).EQ.' ') THEN
            K = K + 1
            IF (K.GT.2) GO TO 40
         ELSE
            K = 0
         END IF
         J = J + 1
         MSG1(J:J) = MSG(I:I)
   40 CONTINUE
      IL = J
C
C     FORMAT THE MESSAGE NOW STORED IN MSG1
C
      I = 1
      LWORD = 60
      J = 0
   60 J = J + 1
      IF (J.GT.1) LWORD = 51
      K = I + LWORD - 1
      KP1 = K + 1
   80 IF (MSG1(K:K).NE.' ' .AND. MSG1(KP1:KP1).NE.' ') THEN
         K = K - 1
         IF (K.EQ.I) THEN
            K = I + LWORD - 1
            GO TO 100
         END IF
         GO TO 80
      END IF
  100 IF (J.EQ.1) THEN
         MSGOUT(J) = MSG1(I:K)
      ELSE
         MSGOUT(J) = '         '//MSG1(I:K)
      END IF
      I = K + 1
      IF (K.LT.IL .AND. J.LT.5) GO TO 60
C
C  OUTPUT THE ERROR MESSAGE
C
      WRITE (NERR,FMT=99999) (MSGOUT(I),I=1,J)
C
C  PRINT THE INTEGERS AND REALS IN THE ERROR MESSAGE (IF ANY)
C
      IF (NI.EQ.1) WRITE (NERR,FMT=99998) I1
      IF (NI.EQ.2) WRITE (NERR,FMT=99997) I1, I2
      IF (NR.EQ.1) WRITE (NERR,FMT=99996) R1
      IF (NR.EQ.2) WRITE (NERR,FMT=99995) R1, R2
C ABORT THE RUN IF IERT = 2. -------------------------------------------
      IF (IERT.NE.2) RETURN
      STOP
C----------------------- END OF SUBROUTINE SCHERR ----------------------
99999 FORMAT (1X,A60)
99998 FORMAT (9X,' IN ABOVE MESSAGE I1 =',I10)
99997 FORMAT (9X,' IN ABOVE MESSAGE I1 =',I10,'   I2 =',I10)
99996 FORMAT (9X,' IN ABOVE MESSAGE R1 =',D21.13)
99995 FORMAT (9X,'IN ABOVE,  R1 =',D21.13,3X,'R2 =',D21.13)
      END
C**********************************************************************
C
      SUBROUTINE ERROR(U,NPDE,NPTS,X,M,ENORM,GERR,T,RELERR,ABSERR,
     *                 ITRACE,RWK,IWK)
C
C**********************************************************************
C       THE FOLLOWING ROUTINE COMPUTES THE ERROR ENORM IN THE NUMERICAL
C       SOLUTION BY USING A COMBINATION OF THE L2 FUNCTION AND VECTOR
C       NORMS. GERR IS THE MAXIMUM ERROR AT THE GRID POINTS
C       THE EXACT SOLUTION IS ASSUMED TO BE GIVEN BY THE USER PROVIDED
C                SUBROUTINE EXACT(T,NPDE, NP, XP, US)
C                DOUBLE PRECISION US(NPDE, NP),XP(NP),T
C                WHERE US(J,I) ON EXIT CONTAINS THE SOLUTION AT TIME T
C                FOR NPDE J AT THE MESH POINT XP(I)
C
C     PARAMETER LIST
C     --------------
C  U(NEQN)        SOLUTION VECTOR  COMPUTED BY DASSL AT TIME T . ON
C                 ENTRY THIS ARRAY IS ASSUMED TO BE ORDERED AS FOLLOWS
C                 U(1) - U(NPDE*NPTS)      P.D.E. SOLUTION COMPONENTS.
C                 U(NPDE*NPTS+1) - U(NEQN) O.D.E. COMPONENTS THAT ARE
C                 COUPLED TO THE P.D.E.
C
C  NPDE           NUMBER OF PARABOLIC P.D.E.S IN ONE SPACE DIMENSION
C
C  NPTS           NUMBER OF SPATIAL GRID POINTS USED IN M.O.L. SOLUTION.
C                 NOTE THIS SHOULD BE EQUAL TO (NPTL-1)*NEL + 1
C
C  X(NPTS)        ON ENTRY THIS ARRAY MUST
C                 CONTAIN THE MESH USED IN SEMI-DISCRETISATION
C
C  M              =0,1,2 IF CARTESIAN CYLINDRICAL OR SPHERICAL POLARS.
C
C  ENORM          L2 ERROR NORM ESTIMATED BY USING TRAPEZOIDAL RULE
C                 WITH 100 EVENLY SPACED POINTS IS OUTPUT IN ENORM
C
C  GERR           MAXIMUM GRID ERROR OVER THE ARRAY OF SPATIAL GRID
C                 POINTS X(NPTS) IS OUTPUT IN GERR
C
C  T              CURRENT TIME LEVEL OF TIME INTEGRATION ( INPUT).
C
C  RELERR         RELATIVE ERROR TOLERANCE SUPPLIED TO DASSL (RTOL IN
C                 THE CALL TO THAT ROUTINE) (INPUT)
C
C  ABSERR         ABSOLUTE ERROR TOLERANCE SUPPLIED TO DASSL (ATOL IN
C                 THE CALL TO THAT ROUTINE). (INPUT)
C
C  ITRACE         INTEGER TRACE LEVEL SET TO ZERO FOR NO TRACE SET =1
C                 FOR TRACE INFORMATION.   (INPUT)
C
C  RWK(IWK)       REAL WORKSPACE INITIALISED BT INICHB AND PASSED TO
C                 THE D.A.E.FUNCTION CALL ROUTINE  RESID
C                 SEE BELOW FOR A DETAILED DESCRIPTION.(INPUT)
C
C***********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION ABSERR, ENORM, GERR, RELERR, T
      INTEGER          ITRACE, IWK, M, NPDE, NPTS
C     .. Array Arguments ..
      DOUBLE PRECISION RWK(IWK), U(NPDE,NPTS), X(NPTS)
C     .. Scalars in Common ..
      INTEGER          IDEV
C     .. Local Scalars ..
      DOUBLE PRECISION EABS, EPS, ER, EREL, HH, WS
      INTEGER          I, IFLAG, IN, IONE, JI, NEQ, NP
C     .. Local Arrays ..
      DOUBLE PRECISION ERR(5), UN(5), US(404), WX(5), XP(201)
C     .. External Subroutines ..
      EXTERNAL         EXACT, INTERC
C     .. Intrinsic Functions ..
      INTRINSIC        DABS, DMAX1, DSQRT
C     .. Common blocks ..
      COMMON           /SCHSZ2/IDEV
C     .. Save statement ..
      SAVE             /SCHSZ2/
C     .. Executable Statements ..
      IONE = 1
C
C   SET UP L2 NORM WEIGHTS AND ESTIMATE NORM USING NP POINTS
C
      EPS = DMAX1(RELERR,ABSERR)
      IF (EPS.LE.0.0) RETURN
      EREL = RELERR/EPS
      EABS = ABSERR/EPS
      DO 40 IN = 1, NPDE
         WX(IN) = 0.0D0
         DO 20 I = 1, NPTS
            EPS = DABS(U(IN,I))
            IF (WX(IN).LT.EPS) WX(IN) = EPS
   20    CONTINUE
         WX(IN) = WX(IN)*EREL + EABS
   40 CONTINUE
      NP = 201
      HH = (X(NPTS)-X(1))/(NP-1)
      DO 60 IN = 1, NPDE
         ERR(IN) = 0.0D0
   60 CONTINUE
      WS = 1.0D0
      DO 80 I = 1, NP
         XP(I) = X(1) + (I-1)*HH
   80 CONTINUE
      NEQ = NPTS*NPDE
      CALL INTERC(XP,US,NP,U,NEQ,NPDE,IFLAG,IONE,RWK,IWK)
      JI = 1
      DO 120 I = 1, NP
         CALL EXACT(T,NPDE,IONE,XP(I),UN)
         IF (M.NE.0) WS = XP(I)**M
         DO 100 IN = 1, NPDE
            ER = DABS(US(JI)-UN(IN))
            ERR(IN) = ERR(IN) + WS*ER**2
            JI = JI + 1
  100    CONTINUE
  120 CONTINUE
      ENORM = 0.0D0
      DO 140 IN = 1, NPDE
         ENORM = ENORM + ERR(IN)/WX(IN)**2
  140 CONTINUE
      ENORM = DSQRT(ENORM*HH)
C
C       COMPUTE THE MAXIMUM ERROR AT THE GRID POINTS
C
      IF (ITRACE.GE.1) WRITE (IDEV,FMT=99999)
      GERR = 0.0D0
      DO 180 I = 1, NPTS
         CALL EXACT(T,NPDE,IONE,X(I),UN)
         DO 160 IN = 1, NPDE
            ER = DABS(U(IN,I)-UN(IN))
            IF (ITRACE.GE.1) WRITE (IDEV,FMT=99998) X(I), U(IN,I),
     *          UN(IN), ER
            IF (GERR.LT.ER) GERR = ER
  160    CONTINUE
  180 CONTINUE
      IF (ITRACE.GT.0) WRITE (IDEV,FMT=99997) ENORM, GERR
      RETURN
C
99999 FORMAT (6X,' MESH',6X,'NUM SOL',10X,'SOL',7X,'ERROR')
99998 FORMAT (4(2X,D11.3))
99997 FORMAT ('  ENORM=',D11.3,'       GERR=',D11.3)
      END
      SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO)
      INTEGER LDA,N,IPVT(1),INFO
      DOUBLE PRECISION A(LDA,1)
C
C     DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION.
C
C     DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) .
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO
C                     IF CALLED.  USE  RCOND  IN DGECO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DSCAL,IDAMAX
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION T
      INTEGER IDAMAX,J,K,KP1,L,NM1
C
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = IDAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (A(L,K) .EQ. 0.0D0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0D0/A(K,K)
            CALL DSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0D0) INFO = N
      RETURN
      END
      SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB)
      INTEGER LDA,N,IPVT(1),JOB
      DOUBLE PRECISION A(LDA,1),B(1)
C
C     DGESL SOLVES THE DOUBLE PRECISION SYSTEM
C     A * X = B  OR  TRANS(A) * X = B
C     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE OUTPUT FROM DGECO OR DGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DGECO OR DGEFA.
C
C        B       DOUBLE PRECISION(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  TRANS(A)*X = B  WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0
C        OR DGEFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL DGECO(A,LDA,N,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL DGESL(A,LDA,N,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DDOT
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,L,NM1
C
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE  L*Y = B
C
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .EQ. K) GO TO 10
               B(L) = B(K)
               B(K) = T
   10       CONTINUE
            CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL DAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            T = DDOT(K-1,A(1,K),1,B(1),1)
            B(K) = (B(K) - T)/A(K,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (NM1 .LT. 1) GO TO 90
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               T = B(L)
               B(L) = B(K)
               B(K) = T
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE DGBFA(ABD,LDA,N,ML,MU,IPVT,INFO)
      INTEGER LDA,N,ML,MU,IPVT(1),INFO
      DOUBLE PRECISION ABD(LDA,1)
C
C     DGBFA FACTORS A DOUBLE PRECISION BAND MATRIX BY ELIMINATION.
C
C     DGBFA IS USUALLY CALLED BY DGBCO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C
C     ON ENTRY
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                CONTAINS THE MATRIX IN BAND STORAGE.  THE COLUMNS
C                OF THE MATRIX ARE STORED IN THE COLUMNS OF  ABD  AND
C                THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS
C                ML+1 THROUGH 2*ML+MU+1 OF  ABD .
C                SEE THE COMMENTS BELOW FOR DETAILS.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  ABD .
C                LDA MUST BE .GE. 2*ML + MU + 1 .
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C                0 .LE. ML .LT. N .
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C                0 .LE. MU .LT. N .
C                MORE EFFICIENT IF  ML .LE. MU .
C     ON RETURN
C
C        ABD     AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND
C                THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT DGBSL WILL DIVIDE BY ZERO IF
C                     CALLED.  USE  RCOND  IN DGBCO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     BAND STORAGE
C
C           IF  A  IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT
C           WILL SET UP THE INPUT.
C
C                   ML = (BAND WIDTH BELOW THE DIAGONAL)
C                   MU = (BAND WIDTH ABOVE THE DIAGONAL)
C                   M = ML + MU + 1
C                   DO 20 J = 1, N
C                      I1 = MAX0(1, J-MU)
C                      I2 = MIN0(N, J+ML)
C                      DO 10 I = I1, I2
C                         K = I - J + M
C                         ABD(K,J) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           THIS USES ROWS  ML+1  THROUGH  2*ML+MU+1  OF  ABD .
C           IN ADDITION, THE FIRST  ML  ROWS IN  ABD  ARE USED FOR
C           ELEMENTS GENERATED DURING THE TRIANGULARIZATION.
C           THE TOTAL NUMBER OF ROWS NEEDED IN  ABD  IS  2*ML+MU+1 .
C           THE  ML+MU BY ML+MU  UPPER LEFT TRIANGLE AND THE
C           ML BY ML  LOWER RIGHT TRIANGLE ARE NOT REFERENCED.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DSCAL,IDAMAX
C     FORTRAN MAX0,MIN0
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION T
      INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1
C
C
      M = ML + MU + 1
      INFO = 0
C
C     ZERO INITIAL FILL-IN COLUMNS
C
      J0 = MU + 2
      J1 = MIN0(N,M) - 1
      IF (J1 .LT. J0) GO TO 30
      DO 20 JZ = J0, J1
         I0 = M + 1 - JZ
         DO 10 I = I0, ML
            ABD(I,JZ) = 0.0D0
   10    CONTINUE
   20 CONTINUE
   30 CONTINUE
      JZ = J1
      JU = 0
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 130
      DO 120 K = 1, NM1
         KP1 = K + 1
C
C        ZERO NEXT FILL-IN COLUMN
C
         JZ = JZ + 1
         IF (JZ .GT. N) GO TO 50
         IF (ML .LT. 1) GO TO 50
            DO 40 I = 1, ML
               ABD(I,JZ) = 0.0D0
   40       CONTINUE
   50    CONTINUE
C
C        FIND L = PIVOT INDEX
C
         LM = MIN0(ML,N-K)
         L = IDAMAX(LM+1,ABD(M,K),1) + M - 1
         IPVT(K) = L + K - M
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (ABD(L,K) .EQ. 0.0D0) GO TO 100
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. M) GO TO 60
               T = ABD(L,K)
               ABD(L,K) = ABD(M,K)
               ABD(M,K) = T
   60       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0D0/ABD(M,K)
            CALL DSCAL(LM,T,ABD(M+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            JU = MIN0(MAX0(JU,MU+IPVT(K)),N)
            MM = M
            IF (JU .LT. KP1) GO TO 90
            DO 80 J = KP1, JU
               L = L - 1
               MM = MM - 1
               T = ABD(L,J)
               IF (L .EQ. MM) GO TO 70
                  ABD(L,J) = ABD(MM,J)
                  ABD(MM,J) = T
   70          CONTINUE
               CALL DAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1)
   80       CONTINUE
   90       CONTINUE
         GO TO 110
  100    CONTINUE
            INFO = K
  110    CONTINUE
  120 CONTINUE
  130 CONTINUE
      IPVT(N) = N
      IF (ABD(M,N) .EQ. 0.0D0) INFO = N
      RETURN
      END
      SUBROUTINE DGBSL(ABD,LDA,N,ML,MU,IPVT,B,JOB)
      INTEGER LDA,N,ML,MU,IPVT(1),JOB
      DOUBLE PRECISION ABD(LDA,1),B(1)
C
C     DGBSL SOLVES THE DOUBLE PRECISION BAND SYSTEM
C     A * X = B  OR  TRANS(A) * X = B
C     USING THE FACTORS COMPUTED BY DGBCO OR DGBFA.
C
C     ON ENTRY
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                THE OUTPUT FROM DGBCO OR DGBFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  ABD .
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DGBCO OR DGBFA.
C
C        B       DOUBLE PRECISION(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  TRANS(A)*X = B , WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF DGBCO HAS SET RCOND .GT. 0.0
C        OR DGBFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DDOT
C     FORTRAN MIN0
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,L,LA,LB,LM,M,NM1
C
      M = MU + ML + 1
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE L*Y = B
C
         IF (ML .EQ. 0) GO TO 30
         IF (NM1 .LT. 1) GO TO 30
            DO 20 K = 1, NM1
               LM = MIN0(ML,N-K)
               L = IPVT(K)
               T = B(L)
               IF (L .EQ. K) GO TO 10
                  B(L) = B(K)
                  B(K) = T
   10          CONTINUE
               CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1)
   20       CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/ABD(M,K)
            LM = MIN0(K,M) - 1
            LA = M - LM
            LB = K - LM
            T = -B(K)
            CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            LM = MIN0(K,M) - 1
            LA = M - LM
            LB = K - LM
            T = DDOT(LM,ABD(LA,K),1,B(LB),1)
            B(K) = (B(K) - T)/ABD(M,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (ML .EQ. 0) GO TO 90
         IF (NM1 .LT. 1) GO TO 90
            DO 80 KB = 1, NM1
               K = N - KB
               LM = MIN0(ML,N-K)
               B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1)
               L = IPVT(K)
               IF (L .EQ. K) GO TO 70
                  T = B(L)
                  B(L) = B(K)
                  B(K) = T
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
C
C     CONSTANT TIMES A VECTOR PLUS A VECTOR.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DA
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF (DA .EQ. 0.0D0) RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DY(IY) + DA*DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,4)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DY(I) + DA*DX(I)
   30 CONTINUE
      IF( N .LT. 4 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        DY(I) = DY(I) + DA*DX(I)
        DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
        DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
        DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE DSCAL(N,DA,DX,INCX)
C
C     SCALES A VECTOR BY A CONSTANT.
C     USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DA,DX(1)
      INTEGER I,INCX,M,MP1,N,NINCX
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        DX(I) = DA*DX(I)
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DX(I) = DA*DX(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DX(I) = DA*DX(I)
        DX(I + 1) = DA*DX(I + 1)
        DX(I + 2) = DA*DX(I + 2)
        DX(I + 3) = DA*DX(I + 3)
        DX(I + 4) = DA*DX(I + 4)
   50 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
C
C     FORMS THE DOT PRODUCT OF TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      DDOT = 0.0D0
      DTEMP = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DTEMP + DX(IX)*DY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      DDOT = DTEMP
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DTEMP + DX(I)*DY(I)
   30 CONTINUE
      IF( N .LT. 5 ) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
     *   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
   50 CONTINUE
   60 DDOT = DTEMP
      RETURN
      END
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
C
C     FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DMAX
      INTEGER I,INCX,IX,N
C
      IDAMAX = 0
      IF( N .LT. 1 ) RETURN
      IDAMAX = 1
      IF(N.EQ.1)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      IX = 1
      DMAX = DABS(DX(1))
      IX = IX + INCX
      DO 10 I = 2,N
         IF(DABS(DX(IX)).LE.DMAX) GO TO 5
         IDAMAX = I
         DMAX = DABS(DX(IX))
    5    IX = IX + INCX
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
   20 DMAX = DABS(DX(1))
      DO 30 I = 2,N
         IF(DABS(DX(I)).LE.DMAX) GO TO 30
         IDAMAX = I
         DMAX = DABS(DX(I))
   30 CONTINUE
      RETURN
      END
 TEST PROBLEM 1
 ***********
 POLY OF DEGREE =   2 NO OF ELEMENTS =   20
 JAC EVAL
 SCALED LOCAL ERROR IS    0.267D-02
 ORDER RAISE WITH IPHASE =0
 AT T=   0.202D-07 H=  0.360D-09  ORDER=  1
 SCALED LOCAL ERROR IS    0.118D-01
 AT T=   0.205D-07 H=  0.720D-09  ORDER=  2
 JAC EVAL
 SCALED LOCAL ERROR IS    0.215D-02
 AT T=   0.213D-07 H=  0.144D-08  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.221D-04
 AT T=   0.227D-07 H=  0.288D-08  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.272D-08
 AT T=   0.256D-07 H=  0.576D-08  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.372D-09
 AT T=   0.313D-07 H=  0.115D-07  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.149D-08
 AT T=   0.429D-07 H=  0.230D-07  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.597D-08
 AT T=   0.659D-07 H=  0.461D-07  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.239D-07
 AT T=   0.112D-06 H=  0.922D-07  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.956D-07
 AT T=   0.204D-06 H=  0.184D-06  ORDER=  1
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.200D-06    0.200D-06    0.535D-10
    0.250D-01    0.195D-06    0.195D-06    0.522D-10
    0.500D-01    0.190D-06    0.190D-06    0.509D-10
    0.750D-01    0.185D-06    0.185D-06    0.495D-10
    0.100D+00    0.180D-06    0.180D-06    0.482D-10
    0.125D+00    0.175D-06    0.175D-06    0.469D-10
    0.150D+00    0.170D-06    0.170D-06    0.455D-10
    0.175D+00    0.165D-06    0.165D-06    0.442D-10
    0.200D+00    0.160D-06    0.160D-06    0.428D-10
    0.225D+00    0.155D-06    0.155D-06    0.415D-10
    0.250D+00    0.150D-06    0.150D-06    0.402D-10
    0.275D+00    0.145D-06    0.145D-06    0.388D-10
    0.300D+00    0.140D-06    0.140D-06    0.375D-10
    0.325D+00    0.135D-06    0.135D-06    0.361D-10
    0.350D+00    0.130D-06    0.130D-06    0.348D-10
    0.375D+00    0.125D-06    0.125D-06    0.335D-10
    0.400D+00    0.120D-06    0.120D-06    0.321D-10
    0.425D+00    0.115D-06    0.115D-06    0.308D-10
    0.450D+00    0.110D-06    0.110D-06    0.295D-10
    0.475D+00    0.105D-06    0.105D-06    0.281D-10
    0.500D+00    0.100D-06    0.100D-06    0.268D-10
    0.525D+00    0.950D-07    0.950D-07    0.254D-10
    0.550D+00    0.900D-07    0.900D-07    0.241D-10
    0.575D+00    0.850D-07    0.850D-07    0.228D-10
    0.600D+00    0.800D-07    0.800D-07    0.214D-10
    0.625D+00    0.750D-07    0.750D-07    0.201D-10
    0.650D+00    0.700D-07    0.700D-07    0.187D-10
    0.675D+00    0.650D-07    0.650D-07    0.174D-10
    0.700D+00    0.600D-07    0.600D-07    0.161D-10
    0.725D+00    0.550D-07    0.550D-07    0.147D-10
    0.750D+00    0.500D-07    0.500D-07    0.134D-10
    0.775D+00    0.450D-07    0.450D-07    0.120D-10
    0.800D+00    0.400D-07    0.400D-07    0.107D-10
    0.825D+00    0.350D-07    0.350D-07    0.937D-11
    0.850D+00    0.300D-07    0.300D-07    0.803D-11
    0.875D+00    0.250D-07    0.250D-07    0.669D-11
    0.900D+00    0.200D-07    0.200D-07    0.535D-11
    0.925D+00    0.150D-07    0.150D-07    0.402D-11
    0.950D+00    0.100D-07    0.100D-07    0.268D-11
    0.975D+00    0.500D-08    0.500D-08    0.134D-11
    0.100D+01    0.339D-22    0.000D+00    0.339D-22
  ENORM=  0.310D-10       GERR=  0.535D-10
 MOVING BOUNDARY IS AT   0.1999D-06 WITH ERROR= -0.5355D-10
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.200D-05    0.200D-05    0.533D-10
    0.250D-01    0.195D-05    0.195D-05    0.520D-10
    0.500D-01    0.190D-05    0.190D-05    0.506D-10
    0.750D-01    0.185D-05    0.185D-05    0.493D-10
    0.100D+00    0.180D-05    0.180D-05    0.480D-10
    0.125D+00    0.175D-05    0.175D-05    0.467D-10
    0.150D+00    0.170D-05    0.170D-05    0.453D-10
    0.175D+00    0.165D-05    0.165D-05    0.440D-10
    0.200D+00    0.160D-05    0.160D-05    0.427D-10
    0.225D+00    0.155D-05    0.155D-05    0.414D-10
    0.250D+00    0.150D-05    0.150D-05    0.400D-10
    0.275D+00    0.145D-05    0.145D-05    0.387D-10
    0.300D+00    0.140D-05    0.140D-05    0.374D-10
    0.325D+00    0.135D-05    0.135D-05    0.360D-10
    0.350D+00    0.130D-05    0.130D-05    0.347D-10
    0.375D+00    0.125D-05    0.125D-05    0.334D-10
    0.400D+00    0.120D-05    0.120D-05    0.320D-10
    0.425D+00    0.115D-05    0.115D-05    0.307D-10
    0.450D+00    0.110D-05    0.110D-05    0.294D-10
    0.475D+00    0.105D-05    0.105D-05    0.280D-10
    0.500D+00    0.100D-05    0.100D-05    0.267D-10
    0.525D+00    0.950D-06    0.950D-06    0.254D-10
    0.550D+00    0.900D-06    0.900D-06    0.240D-10
    0.575D+00    0.850D-06    0.850D-06    0.227D-10
    0.600D+00    0.800D-06    0.800D-06    0.214D-10
    0.625D+00    0.750D-06    0.750D-06    0.200D-10
    0.650D+00    0.700D-06    0.700D-06    0.187D-10
    0.675D+00    0.650D-06    0.650D-06    0.174D-10
    0.700D+00    0.600D-06    0.600D-06    0.160D-10
    0.725D+00    0.550D-06    0.550D-06    0.147D-10
    0.750D+00    0.500D-06    0.500D-06    0.134D-10
    0.775D+00    0.450D-06    0.450D-06    0.120D-10
    0.800D+00    0.400D-06    0.400D-06    0.107D-10
    0.825D+00    0.350D-06    0.350D-06    0.936D-11
    0.850D+00    0.300D-06    0.300D-06    0.803D-11
    0.875D+00    0.250D-06    0.250D-06    0.669D-11
    0.900D+00    0.200D-06    0.200D-06    0.535D-11
    0.925D+00    0.150D-06    0.150D-06    0.401D-11
    0.950D+00    0.100D-06    0.100D-06    0.268D-11
    0.975D+00    0.500D-07    0.500D-07    0.134D-11
    0.100D+01    0.330D-21    0.000D+00    0.330D-21
  ENORM=  0.309D-10       GERR=  0.533D-10
 MOVING BOUNDARY IS AT   0.2000D-05 WITH ERROR= -0.5355D-10
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.200D-04    0.200D-04    0.388D-10
    0.250D-01    0.195D-04    0.195D-04    0.382D-10
    0.500D-01    0.190D-04    0.190D-04    0.375D-10
    0.750D-01    0.185D-04    0.185D-04    0.369D-10
    0.100D+00    0.180D-04    0.180D-04    0.362D-10
    0.125D+00    0.175D-04    0.175D-04    0.355D-10
    0.150D+00    0.170D-04    0.170D-04    0.348D-10
    0.175D+00    0.165D-04    0.165D-04    0.341D-10
    0.200D+00    0.160D-04    0.160D-04    0.334D-10
    0.225D+00    0.155D-04    0.155D-04    0.326D-10
    0.250D+00    0.150D-04    0.150D-04    0.318D-10
    0.275D+00    0.145D-04    0.145D-04    0.310D-10
    0.300D+00    0.140D-04    0.140D-04    0.302D-10
    0.325D+00    0.135D-04    0.135D-04    0.294D-10
    0.350D+00    0.130D-04    0.130D-04    0.286D-10
    0.375D+00    0.125D-04    0.125D-04    0.277D-10
    0.400D+00    0.120D-04    0.120D-04    0.268D-10
    0.425D+00    0.115D-04    0.115D-04    0.259D-10
    0.450D+00    0.110D-04    0.110D-04    0.250D-10
    0.475D+00    0.105D-04    0.105D-04    0.240D-10
    0.500D+00    0.100D-04    0.100D-04    0.231D-10
    0.525D+00    0.950D-05    0.950D-05    0.221D-10
    0.550D+00    0.900D-05    0.900D-05    0.211D-10
    0.575D+00    0.850D-05    0.850D-05    0.201D-10
    0.600D+00    0.800D-05    0.800D-05    0.191D-10
    0.625D+00    0.750D-05    0.750D-05    0.180D-10
    0.650D+00    0.700D-05    0.700D-05    0.169D-10
    0.675D+00    0.650D-05    0.650D-05    0.158D-10
    0.700D+00    0.600D-05    0.600D-05    0.147D-10
    0.725D+00    0.550D-05    0.550D-05    0.136D-10
    0.750D+00    0.500D-05    0.500D-05    0.125D-10
    0.775D+00    0.450D-05    0.450D-05    0.113D-10
    0.800D+00    0.400D-05    0.400D-05    0.101D-10
    0.825D+00    0.350D-05    0.350D-05    0.892D-11
    0.850D+00    0.300D-05    0.300D-05    0.770D-11
    0.875D+00    0.250D-05    0.250D-05    0.646D-11
    0.900D+00    0.200D-05    0.200D-05    0.521D-11
    0.925D+00    0.150D-05    0.150D-05    0.393D-11
    0.950D+00    0.100D-05    0.100D-05    0.264D-11
    0.975D+00    0.500D-06    0.500D-06    0.133D-11
    0.100D+01    0.301D-20    0.000D+00    0.301D-20
  ENORM=  0.246D-10       GERR=  0.388D-10
 MOVING BOUNDARY IS AT   0.2000D-04 WITH ERROR= -0.5354D-10
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.200D-03    0.200D-03    0.945D-09
    0.250D-01    0.195D-03    0.195D-03    0.897D-09
    0.500D-01    0.190D-03    0.190D-03    0.850D-09
    0.750D-01    0.185D-03    0.185D-03    0.805D-09
    0.100D+00    0.180D-03    0.180D-03    0.761D-09
    0.125D+00    0.175D-03    0.175D-03    0.718D-09
    0.150D+00    0.170D-03    0.170D-03    0.676D-09
    0.175D+00    0.165D-03    0.165D-03    0.636D-09
    0.200D+00    0.160D-03    0.160D-03    0.596D-09
    0.225D+00    0.155D-03    0.155D-03    0.559D-09
    0.250D+00    0.150D-03    0.150D-03    0.522D-09
    0.275D+00    0.145D-03    0.145D-03    0.486D-09
    0.300D+00    0.140D-03    0.140D-03    0.452D-09
    0.325D+00    0.135D-03    0.135D-03    0.419D-09
    0.350D+00    0.130D-03    0.130D-03    0.387D-09
    0.375D+00    0.125D-03    0.125D-03    0.357D-09
    0.400D+00    0.120D-03    0.120D-03    0.328D-09
    0.425D+00    0.115D-03    0.115D-03    0.300D-09
    0.450D+00    0.110D-03    0.110D-03    0.273D-09
    0.475D+00    0.105D-03    0.105D-03    0.247D-09
    0.500D+00    0.100D-03    0.100D-03    0.223D-09
    0.525D+00    0.950D-04    0.950D-04    0.200D-09
    0.550D+00    0.900D-04    0.900D-04    0.178D-09
    0.575D+00    0.850D-04    0.850D-04    0.158D-09
    0.600D+00    0.800D-04    0.800D-04    0.139D-09
    0.625D+00    0.750D-04    0.750D-04    0.121D-09
    0.650D+00    0.700D-04    0.700D-04    0.104D-09
    0.675D+00    0.650D-04    0.650D-04    0.884D-10
    0.700D+00    0.600D-04    0.600D-04    0.741D-10
    0.725D+00    0.550D-04    0.550D-04    0.610D-10
    0.750D+00    0.500D-04    0.500D-04    0.493D-10
    0.775D+00    0.450D-04    0.450D-04    0.387D-10
    0.800D+00    0.400D-04    0.400D-04    0.294D-10
    0.825D+00    0.350D-04    0.350D-04    0.214D-10
    0.850D+00    0.300D-04    0.300D-04    0.146D-10
    0.875D+00    0.250D-04    0.250D-04    0.905D-11
    0.900D+00    0.200D-04    0.200D-04    0.475D-11
    0.925D+00    0.150D-04    0.150D-04    0.169D-11
    0.950D+00    0.100D-04    0.100D-04    0.121D-12
    0.975D+00    0.500D-05    0.500D-05    0.684D-12
    0.100D+01    0.339D-19    0.000D+00    0.339D-19
  ENORM=  0.419D-09       GERR=  0.945D-09
 MOVING BOUNDARY IS AT   0.2000D-03 WITH ERROR= -0.5308D-10
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.200D-02    0.200D-02    0.666D-10
    0.250D-01    0.195D-02    0.195D-02    0.660D-10
    0.500D-01    0.190D-02    0.190D-02    0.654D-10
    0.750D-01    0.185D-02    0.185D-02    0.646D-10
    0.100D+00    0.180D-02    0.180D-02    0.638D-10
    0.125D+00    0.175D-02    0.175D-02    0.629D-10
    0.150D+00    0.170D-02    0.170D-02    0.619D-10
    0.175D+00    0.165D-02    0.165D-02    0.609D-10
    0.200D+00    0.160D-02    0.160D-02    0.598D-10
    0.225D+00    0.155D-02    0.155D-02    0.586D-10
    0.250D+00    0.150D-02    0.150D-02    0.574D-10
    0.275D+00    0.145D-02    0.145D-02    0.561D-10
    0.300D+00    0.140D-02    0.140D-02    0.547D-10
    0.325D+00    0.135D-02    0.135D-02    0.533D-10
    0.350D+00    0.130D-02    0.130D-02    0.518D-10
    0.375D+00    0.125D-02    0.125D-02    0.502D-10
    0.400D+00    0.120D-02    0.120D-02    0.486D-10
    0.425D+00    0.115D-02    0.115D-02    0.470D-10
    0.450D+00    0.110D-02    0.110D-02    0.453D-10
    0.475D+00    0.105D-02    0.105D-02    0.436D-10
    0.500D+00    0.100D-02    0.100D-02    0.418D-10
    0.525D+00    0.950D-03    0.950D-03    0.400D-10
    0.550D+00    0.900D-03    0.900D-03    0.381D-10
    0.575D+00    0.850D-03    0.850D-03    0.362D-10
    0.600D+00    0.800D-03    0.800D-03    0.342D-10
    0.625D+00    0.750D-03    0.750D-03    0.323D-10
    0.650D+00    0.700D-03    0.700D-03    0.303D-10
    0.675D+00    0.650D-03    0.650D-03    0.282D-10
    0.700D+00    0.600D-03    0.600D-03    0.261D-10
    0.725D+00    0.550D-03    0.550D-03    0.241D-10
    0.750D+00    0.500D-03    0.500D-03    0.219D-10
    0.775D+00    0.450D-03    0.450D-03    0.198D-10
    0.800D+00    0.400D-03    0.400D-03    0.177D-10
    0.825D+00    0.350D-03    0.350D-03    0.155D-10
    0.850D+00    0.300D-03    0.300D-03    0.133D-10
    0.875D+00    0.250D-03    0.250D-03    0.111D-10
    0.900D+00    0.200D-03    0.200D-03    0.889D-11
    0.925D+00    0.150D-03    0.150D-03    0.668D-11
    0.950D+00    0.100D-03    0.100D-03    0.446D-11
    0.975D+00    0.500D-04    0.500D-04    0.223D-11
    0.100D+01    0.344D-18    0.000D+00    0.344D-18
  ENORM=  0.438D-10       GERR=  0.666D-10
 MOVING BOUNDARY IS AT   0.2000D-02 WITH ERROR= -0.8957D-10
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.202D-01    0.202D-01    0.192D-08
    0.250D-01    0.197D-01    0.197D-01    0.187D-08
    0.500D-01    0.192D-01    0.192D-01    0.182D-08
    0.750D-01    0.187D-01    0.187D-01    0.177D-08
    0.100D+00    0.182D-01    0.182D-01    0.172D-08
    0.125D+00    0.177D-01    0.177D-01    0.168D-08
    0.150D+00    0.171D-01    0.171D-01    0.163D-08
    0.175D+00    0.166D-01    0.166D-01    0.158D-08
    0.200D+00    0.161D-01    0.161D-01    0.153D-08
    0.225D+00    0.156D-01    0.156D-01    0.149D-08
    0.250D+00    0.151D-01    0.151D-01    0.144D-08
    0.275D+00    0.146D-01    0.146D-01    0.139D-08
    0.300D+00    0.141D-01    0.141D-01    0.134D-08
    0.325D+00    0.136D-01    0.136D-01    0.129D-08
    0.350D+00    0.131D-01    0.131D-01    0.125D-08
    0.375D+00    0.126D-01    0.126D-01    0.120D-08
    0.400D+00    0.121D-01    0.121D-01    0.115D-08
    0.425D+00    0.116D-01    0.116D-01    0.110D-08
    0.450D+00    0.111D-01    0.111D-01    0.106D-08
    0.475D+00    0.106D-01    0.106D-01    0.101D-08
    0.500D+00    0.101D-01    0.101D-01    0.961D-09
    0.525D+00    0.955D-02    0.955D-02    0.913D-09
    0.550D+00    0.904D-02    0.904D-02    0.865D-09
    0.575D+00    0.854D-02    0.854D-02    0.817D-09
    0.600D+00    0.803D-02    0.803D-02    0.769D-09
    0.625D+00    0.753D-02    0.753D-02    0.721D-09
    0.650D+00    0.702D-02    0.702D-02    0.673D-09
    0.675D+00    0.652D-02    0.652D-02    0.625D-09
    0.700D+00    0.602D-02    0.602D-02    0.577D-09
    0.725D+00    0.552D-02    0.552D-02    0.529D-09
    0.750D+00    0.501D-02    0.501D-02    0.481D-09
    0.775D+00    0.451D-02    0.451D-02    0.433D-09
    0.800D+00    0.401D-02    0.401D-02    0.385D-09
    0.825D+00    0.351D-02    0.351D-02    0.337D-09
    0.850D+00    0.300D-02    0.300D-02    0.289D-09
    0.875D+00    0.250D-02    0.250D-02    0.241D-09
    0.900D+00    0.200D-02    0.200D-02    0.192D-09
    0.925D+00    0.150D-02    0.150D-02    0.144D-09
    0.950D+00    0.100D-02    0.100D-02    0.962D-10
    0.975D+00    0.500D-03    0.500D-03    0.481D-10
    0.100D+01    0.386D-17    0.000D+00    0.386D-17
  ENORM=  0.109D-08       GERR=  0.192D-08
 MOVING BOUNDARY IS AT   0.2000D-01 WITH ERROR= -0.1994D-08
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.221D+00    0.221D+00    0.274D-08
    0.250D-01    0.215D+00    0.215D+00    0.262D-08
    0.500D-01    0.209D+00    0.209D+00    0.257D-08
    0.750D-01    0.203D+00    0.203D+00    0.246D-08
    0.100D+00    0.197D+00    0.197D+00    0.241D-08
    0.125D+00    0.191D+00    0.191D+00    0.230D-08
    0.150D+00    0.185D+00    0.185D+00    0.225D-08
    0.175D+00    0.179D+00    0.179D+00    0.215D-08
    0.200D+00    0.174D+00    0.174D+00    0.209D-08
    0.225D+00    0.168D+00    0.168D+00    0.199D-08
    0.250D+00    0.162D+00    0.162D+00    0.193D-08
    0.275D+00    0.156D+00    0.156D+00    0.184D-08
    0.300D+00    0.150D+00    0.150D+00    0.178D-08
    0.325D+00    0.145D+00    0.145D+00    0.170D-08
    0.350D+00    0.139D+00    0.139D+00    0.164D-08
    0.375D+00    0.133D+00    0.133D+00    0.156D-08
    0.400D+00    0.127D+00    0.127D+00    0.149D-08
    0.425D+00    0.122D+00    0.122D+00    0.142D-08
    0.450D+00    0.116D+00    0.116D+00    0.135D-08
    0.475D+00    0.111D+00    0.111D+00    0.128D-08
    0.500D+00    0.105D+00    0.105D+00    0.121D-08
    0.525D+00    0.997D-01    0.997D-01    0.115D-08
    0.550D+00    0.942D-01    0.942D-01    0.108D-08
    0.575D+00    0.887D-01    0.887D-01    0.102D-08
    0.600D+00    0.833D-01    0.833D-01    0.952D-09
    0.625D+00    0.779D-01    0.779D-01    0.895D-09
    0.650D+00    0.725D-01    0.725D-01    0.826D-09
    0.675D+00    0.672D-01    0.672D-01    0.773D-09
    0.700D+00    0.618D-01    0.618D-01    0.702D-09
    0.725D+00    0.565D-01    0.565D-01    0.654D-09
    0.750D+00    0.513D-01    0.513D-01    0.581D-09
    0.775D+00    0.460D-01    0.460D-01    0.537D-09
    0.800D+00    0.408D-01    0.408D-01    0.463D-09
    0.825D+00    0.356D-01    0.356D-01    0.422D-09
    0.850D+00    0.305D-01    0.305D-01    0.346D-09
    0.875D+00    0.253D-01    0.253D-01    0.308D-09
    0.900D+00    0.202D-01    0.202D-01    0.230D-09
    0.925D+00    0.151D-01    0.151D-01    0.195D-09
    0.950D+00    0.101D-01    0.101D-01    0.115D-09
    0.975D+00    0.501D-02    0.501D-02    0.825D-10
    0.100D+01    0.343D-16    0.000D+00    0.343D-16
  ENORM=  0.533D-08       GERR=  0.274D-08
 MOVING BOUNDARY IS AT   0.2000D+00 WITH ERROR= -0.3416D-08
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.639D+01    0.639D+01    0.190D-05
    0.250D-01    0.603D+01    0.603D+01    0.205D-07
    0.500D-01    0.569D+01    0.569D+01    0.162D-05
    0.750D-01    0.536D+01    0.536D+01    0.907D-07
    0.100D+00    0.505D+01    0.505D+01    0.138D-05
    0.125D+00    0.475D+01    0.475D+01    0.149D-06
    0.150D+00    0.447D+01    0.447D+01    0.117D-05
    0.175D+00    0.421D+01    0.421D+01    0.196D-06
    0.200D+00    0.395D+01    0.395D+01    0.987D-06
    0.225D+00    0.371D+01    0.371D+01    0.234D-06
    0.250D+00    0.348D+01    0.348D+01    0.830D-06
    0.275D+00    0.326D+01    0.326D+01    0.263D-06
    0.300D+00    0.306D+01    0.306D+01    0.695D-06
    0.325D+00    0.286D+01    0.286D+01    0.285D-06
    0.350D+00    0.267D+01    0.267D+01    0.578D-06
    0.375D+00    0.249D+01    0.249D+01    0.300D-06
    0.400D+00    0.232D+01    0.232D+01    0.477D-06
    0.425D+00    0.216D+01    0.216D+01    0.310D-06
    0.450D+00    0.200D+01    0.200D+01    0.390D-06
    0.475D+00    0.186D+01    0.186D+01    0.316D-06
    0.500D+00    0.172D+01    0.172D+01    0.316D-06
    0.525D+00    0.159D+01    0.159D+01    0.318D-06
    0.550D+00    0.146D+01    0.146D+01    0.253D-06
    0.575D+00    0.134D+01    0.134D+01    0.317D-06
    0.600D+00    0.123D+01    0.123D+01    0.199D-06
    0.625D+00    0.112D+01    0.112D+01    0.313D-06
    0.650D+00    0.101D+01    0.101D+01    0.153D-06
    0.675D+00    0.916D+00    0.916D+00    0.308D-06
    0.700D+00    0.822D+00    0.822D+00    0.115D-06
    0.725D+00    0.733D+00    0.733D+00    0.302D-06
    0.750D+00    0.649D+00    0.649D+00    0.835D-07
    0.775D+00    0.568D+00    0.568D+00    0.295D-06
    0.800D+00    0.492D+00    0.492D+00    0.577D-07
    0.825D+00    0.419D+00    0.419D+00    0.287D-06
    0.850D+00    0.350D+00    0.350D+00    0.370D-07
    0.875D+00    0.284D+00    0.284D+00    0.279D-06
    0.900D+00    0.221D+00    0.221D+00    0.208D-07
    0.925D+00    0.162D+00    0.162D+00    0.272D-06
    0.950D+00    0.105D+00    0.105D+00    0.862D-08
    0.975D+00    0.513D-01    0.513D-01    0.264D-06
    0.100D+01    0.333D-15    0.000D+00    0.333D-15
  ENORM=  0.284D-05       GERR=  0.190D-05
 MOVING BOUNDARY IS AT   0.2000D+01 WITH ERROR=  0.1550D-06
 NSTEPS =   81 NRESID =  188 JAC =   35 CPU=  0.000D+00
 TEST PROBLEM 1
 ***********
 POLY OF DEGREE =  10 NO OF ELEMENTS =    1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.325D+04
 ERROR TEST FAILED
 JAC EVAL
 SCALED LOCAL ERROR IS    0.325D+03
 ERROR TEST FAILED
 JAC EVAL
 SCALED LOCAL ERROR IS    0.239D+02
 ERROR TEST FAILED
 JAC EVAL
 SCALED LOCAL ERROR IS    0.156D+01
 ERROR TEST FAILED
 JAC EVAL
 SCALED LOCAL ERROR IS    0.988D-01
 AT T=   0.391D-06 H=  0.781D-06  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.246D-04
 AT T=   0.117D-05 H=  0.156D-05  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.985D-04
 AT T=   0.273D-05 H=  0.313D-05  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.395D-03
 AT T=   0.586D-05 H=  0.625D-05  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.159D-02
 AT T=   0.121D-04 H=  0.125D-04  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.641D-02
 AT T=   0.246D-04 H=  0.250D-04  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.261D-01
 AT T=   0.496D-04 H=  0.500D-04  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.106D+00
 AT T=   0.996D-04 H=  0.100D-03  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.431D+00
 AT T=   0.200D-03 H=  0.100D-03  ORDER=  1
 SCALED LOCAL ERROR IS    0.325D+00
 AT T=   0.300D-03 H=  0.100D-03  ORDER=  1
 SCALED LOCAL ERROR IS    0.326D+00
 ORDER RAISE CONSIDERED
 AT T=   0.400D-03 H=  0.200D-03  ORDER=  1
 SCALED LOCAL ERROR IS    0.283D+00
 AT T=   0.600D-03 H=  0.200D-03  ORDER=  2
 SCALED LOCAL ERROR IS    0.163D+00
 AT T=   0.800D-03 H=  0.200D-03  ORDER=  2
 SCALED LOCAL ERROR IS    0.370D-01
 AT T=   0.100D-02 H=  0.400D-03  ORDER=  2
 JAC EVAL
 SCALED LOCAL ERROR IS    0.808D-01
 AT T=   0.140D-02 H=  0.400D-03  ORDER=  2
 SCALED LOCAL ERROR IS    0.587D-02
 AT T=   0.180D-02 H=  0.800D-03  ORDER=  2
 JAC EVAL
 SCALED LOCAL ERROR IS    0.313D-01
 AT T=   0.260D-02 H=  0.160D-02  ORDER=  2
 JAC EVAL
 SCALED LOCAL ERROR IS    0.137D+00
 AT T=   0.420D-02 H=  0.160D-02  ORDER=  2
 SCALED LOCAL ERROR IS    0.759D-01
 AT T=   0.580D-02 H=  0.160D-02  ORDER=  2
 SCALED LOCAL ERROR IS    0.816D-01
 AT T=   0.740D-02 H=  0.160D-02  ORDER=  2
 SCALED LOCAL ERROR IS    0.832D-01
 ORDER RAISE CONSIDERED
 AT T=   0.900D-02 H=  0.320D-02  ORDER=  2
 SCALED LOCAL ERROR IS    0.111D+00
 AT T=   0.122D-01 H=  0.320D-02  ORDER=  3
 SCALED LOCAL ERROR IS    0.822D-01
 AT T=   0.154D-01 H=  0.320D-02  ORDER=  3
 SCALED LOCAL ERROR IS    0.223D-01
 AT T=   0.186D-01 H=  0.640D-02  ORDER=  3
 JAC EVAL
 SCALED LOCAL ERROR IS    0.237D+00
 AT T=   0.250D-01 H=  0.640D-02  ORDER=  3
 SCALED LOCAL ERROR IS    0.472D-01
 AT T=   0.314D-01 H=  0.640D-02  ORDER=  3
 SCALED LOCAL ERROR IS    0.642D-01
 AT T=   0.378D-01 H=  0.640D-02  ORDER=  3
 SCALED LOCAL ERROR IS    0.320D-01
 AT T=   0.442D-01 H=  0.640D-02  ORDER=  3
 SCALED LOCAL ERROR IS    0.247D-01
 AT T=   0.506D-01 H=  0.128D-01  ORDER=  3
 JAC EVAL
 SCALED LOCAL ERROR IS    0.501D+00
 AT T=   0.634D-01 H=  0.115D-01  ORDER=  3
 SCALED LOCAL ERROR IS    0.154D+00
 AT T=   0.749D-01 H=  0.115D-01  ORDER=  3
 SCALED LOCAL ERROR IS    0.316D+00
 AT T=   0.864D-01 H=  0.115D-01  ORDER=  3
 SCALED LOCAL ERROR IS    0.293D+00
 AT T=   0.980D-01 H=  0.115D-01  ORDER=  3
 SCALED LOCAL ERROR IS    0.284D+00
 AT T=   0.109D+00 H=  0.115D-01  ORDER=  3
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.246D+01    0.246D+01    0.105D-06
    0.245D-01    0.246D+01    0.246D+01    0.105D-06
    0.955D-01    0.244D+01    0.244D+01    0.761D-07
    0.206D+00    0.236D+01    0.236D+01    0.755D-07
    0.345D+00    0.218D+01    0.218D+01    0.116D-06
    0.500D+00    0.192D+01    0.192D+01    0.175D-07
    0.655D+00    0.160D+01    0.160D+01    0.117D-06
    0.794D+00    0.131D+01    0.131D+01    0.588D-08
    0.905D+00    0.109D+01    0.109D+01    0.670D-07
    0.976D+00    0.950D+00    0.950D+00    0.280D-07
    0.100D+01    0.905D+00    0.905D+00    0.203D-07
  ENORM=  0.106D-07       GERR=  0.117D-06
 SCALED LOCAL ERROR IS    0.279D+00
 ORDER RAISE CONSIDERED
 AT T=   0.121D+00 H=  0.230D-01  ORDER=  3
 SCALED LOCAL ERROR IS    0.287D+00
 AT T=   0.144D+00 H=  0.230D-01  ORDER=  4
 SCALED LOCAL ERROR IS    0.351D+00
 AT T=   0.167D+00 H=  0.230D-01  ORDER=  4
 SCALED LOCAL ERROR IS    0.177D+00
 AT T=   0.190D+00 H=  0.230D-01  ORDER=  4
 SCALED LOCAL ERROR IS    0.189D+00
 AT T=   0.213D+00 H=  0.230D-01  ORDER=  4
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.223D+01    0.223D+01    0.111D-06
    0.245D-01    0.222D+01    0.222D+01    0.111D-06
    0.955D-01    0.221D+01    0.221D+01    0.847D-07
    0.206D+00    0.213D+01    0.213D+01    0.836D-07
    0.345D+00    0.198D+01    0.198D+01    0.119D-06
    0.500D+00    0.173D+01    0.173D+01    0.281D-07
    0.655D+00    0.145D+01    0.145D+01    0.116D-06
    0.794D+00    0.118D+01    0.118D+01    0.287D-08
    0.905D+00    0.982D+00    0.982D+00    0.674D-07
    0.976D+00    0.859D+00    0.859D+00    0.313D-07
    0.100D+01    0.819D+00    0.819D+00    0.240D-07
  ENORM=  0.116D-07       GERR=  0.119D-06
 SCALED LOCAL ERROR IS    0.108D+00
 AT T=   0.236D+00 H=  0.230D-01  ORDER=  4
 SCALED LOCAL ERROR IS    0.403D-01
 AT T=   0.259D+00 H=  0.230D-01  ORDER=  4
 SCALED LOCAL ERROR IS    0.410D-01
 ORDER RAISE CONSIDERED
 AT T=   0.282D+00 H=  0.461D-01  ORDER=  4
 JAC EVAL
 SCALED LOCAL ERROR IS    0.168D+01
 ERROR TEST FAILED
 SCALED LOCAL ERROR IS    0.248D+00
 AT T=   0.313D+00 H=  0.311D-01  ORDER=  5
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.201D+01    0.201D+01    0.104D-06
    0.245D-01    0.201D+01    0.201D+01    0.104D-06
    0.955D-01    0.200D+01    0.200D+01    0.802D-07
    0.206D+00    0.193D+01    0.193D+01    0.790D-07
    0.345D+00    0.179D+01    0.179D+01    0.111D-06
    0.500D+00    0.157D+01    0.157D+01    0.281D-07
    0.655D+00    0.131D+01    0.131D+01    0.107D-06
    0.794D+00    0.107D+01    0.107D+01    0.443D-08
    0.905D+00    0.889D+00    0.889D+00    0.625D-07
    0.976D+00    0.778D+00    0.778D+00    0.296D-07
    0.100D+01    0.741D+00    0.741D+00    0.229D-07
  ENORM=  0.116D-07       GERR=  0.111D-06
 SCALED LOCAL ERROR IS    0.478D-01
 AT T=   0.344D+00 H=  0.311D-01  ORDER=  5
 SCALED LOCAL ERROR IS    0.706D-02
 AT T=   0.375D+00 H=  0.621D-01  ORDER=  5
 SCALED LOCAL ERROR IS    0.170D+01
 ERROR TEST FAILED
 SCALED LOCAL ERROR IS    0.248D+00
 AT T=   0.417D+00 H=  0.412D-01  ORDER=  5
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.182D+01    0.182D+01    0.914D-07
    0.245D-01    0.182D+01    0.182D+01    0.913D-07
    0.955D-01    0.181D+01    0.181D+01    0.697D-07
    0.206D+00    0.175D+01    0.175D+01    0.687D-07
    0.345D+00    0.162D+01    0.162D+01    0.978D-07
    0.500D+00    0.142D+01    0.142D+01    0.232D-07
    0.655D+00    0.119D+01    0.119D+01    0.953D-07
    0.794D+00    0.970D+00    0.970D+00    0.245D-08
    0.905D+00    0.804D+00    0.804D+00    0.553D-07
    0.976D+00    0.704D+00    0.704D+00    0.257D-07
    0.100D+01    0.670D+00    0.670D+00    0.197D-07
  ENORM=  0.109D-07       GERR=  0.978D-07
 SCALED LOCAL ERROR IS    0.856D-02
 AT T=   0.458D+00 H=  0.412D-01  ORDER=  5
 SCALED LOCAL ERROR IS    0.816D-01
 AT T=   0.499D+00 H=  0.412D-01  ORDER=  5
 SCALED LOCAL ERROR IS    0.167D-01
 AT T=   0.540D+00 H=  0.412D-01  ORDER=  5
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.165D+01    0.165D+01    0.847D-07
    0.245D-01    0.165D+01    0.165D+01    0.846D-07
    0.955D-01    0.163D+01    0.163D+01    0.650D-07
    0.206D+00    0.158D+01    0.158D+01    0.641D-07
    0.345D+00    0.146D+01    0.146D+01    0.902D-07
    0.500D+00    0.128D+01    0.128D+01    0.225D-07
    0.655D+00    0.107D+01    0.107D+01    0.875D-07
    0.794D+00    0.878D+00    0.878D+00    0.327D-08
    0.905D+00    0.728D+00    0.728D+00    0.509D-07
    0.976D+00    0.637D+00    0.637D+00    0.240D-07
    0.100D+01    0.607D+00    0.607D+00    0.185D-07
  ENORM=  0.107D-07       GERR=  0.902D-07
 SCALED LOCAL ERROR IS    0.294D-01
 AT T=   0.582D+00 H=  0.412D-01  ORDER=  5
 SCALED LOCAL ERROR IS    0.529D-01
 AT T=   0.623D+00 H=  0.412D-01  ORDER=  5
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.149D+01    0.149D+01    0.755D-07
    0.245D-01    0.149D+01    0.149D+01    0.754D-07
    0.955D-01    0.148D+01    0.148D+01    0.577D-07
    0.206D+00    0.143D+01    0.143D+01    0.569D-07
    0.345D+00    0.132D+01    0.132D+01    0.807D-07
    0.500D+00    0.116D+01    0.116D+01    0.195D-07
    0.655D+00    0.972D+00    0.972D+00    0.785D-07
    0.794D+00    0.794D+00    0.794D+00    0.237D-08
    0.905D+00    0.658D+00    0.658D+00    0.456D-07
    0.976D+00    0.576D+00    0.576D+00    0.213D-07
    0.100D+01    0.549D+00    0.549D+00    0.164D-07
  ENORM=  0.102D-07       GERR=  0.807D-07
 SCALED LOCAL ERROR IS    0.591D-01
 AT T=   0.664D+00 H=  0.412D-01  ORDER=  5
 SCALED LOCAL ERROR IS    0.455D-01
 AT T=   0.705D+00 H=  0.412D-01  ORDER=  5
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.135D+01    0.135D+01    0.658D-07
    0.245D-01    0.135D+01    0.135D+01    0.657D-07
    0.955D-01    0.134D+01    0.134D+01    0.497D-07
    0.206D+00    0.129D+01    0.129D+01    0.491D-07
    0.345D+00    0.120D+01    0.120D+01    0.707D-07
    0.500D+00    0.105D+01    0.105D+01    0.157D-07
    0.655D+00    0.880D+00    0.880D+00    0.694D-07
    0.794D+00    0.719D+00    0.719D+00    0.798D-09
    0.905D+00    0.596D+00    0.596D+00    0.401D-07
    0.976D+00    0.521D+00    0.521D+00    0.183D-07
    0.100D+01    0.497D+00    0.497D+00    0.139D-07
  ENORM=  0.947D-08       GERR=  0.707D-07
 SCALED LOCAL ERROR IS    0.338D-01
 AT T=   0.746D+00 H=  0.412D-01  ORDER=  5
 SCALED LOCAL ERROR IS    0.372D-01
 AT T=   0.788D+00 H=  0.412D-01  ORDER=  5
 SCALED LOCAL ERROR IS    0.473D-01
 AT T=   0.829D+00 H=  0.412D-01  ORDER=  5
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.122D+01    0.122D+01    0.560D-07
    0.245D-01    0.122D+01    0.122D+01    0.559D-07
    0.955D-01    0.121D+01    0.121D+01    0.415D-07
    0.206D+00    0.117D+01    0.117D+01    0.410D-07
    0.345D+00    0.108D+01    0.108D+01    0.608D-07
    0.500D+00    0.951D+00    0.951D+00    0.114D-07
    0.655D+00    0.796D+00    0.796D+00    0.605D-07
    0.794D+00    0.650D+00    0.650D+00    0.117D-08
    0.905D+00    0.539D+00    0.539D+00    0.347D-07
    0.976D+00    0.472D+00    0.472D+00    0.152D-07
    0.100D+01    0.449D+00    0.449D+00    0.112D-07
  ENORM=  0.859D-08       GERR=  0.608D-07
 SCALED LOCAL ERROR IS    0.482D-01
 AT T=   0.870D+00 H=  0.412D-01  ORDER=  5
 SCALED LOCAL ERROR IS    0.378D-01
 AT T=   0.911D+00 H=  0.412D-01  ORDER=  5
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.111D+01    0.111D+01    0.445D-07
    0.245D-01    0.110D+01    0.110D+01    0.445D-07
    0.955D-01    0.110D+01    0.110D+01    0.314D-07
    0.206D+00    0.106D+01    0.106D+01    0.313D-07
    0.345D+00    0.981D+00    0.981D+00    0.497D-07
    0.500D+00    0.861D+00    0.861D+00    0.559D-08
    0.655D+00    0.720D+00    0.720D+00    0.507D-07
    0.794D+00    0.588D+00    0.588D+00    0.431D-08
    0.905D+00    0.488D+00    0.488D+00    0.287D-07
    0.976D+00    0.427D+00    0.427D+00    0.114D-07
    0.100D+01    0.407D+00    0.407D+00    0.794D-08
  ENORM=  0.739D-08       GERR=  0.507D-07
 SCALED LOCAL ERROR IS    0.295D-01
 AT T=   0.953D+00 H=  0.412D-01  ORDER=  5
 SCALED LOCAL ERROR IS    0.348D-01
 AT T=   0.994D+00 H=  0.412D-01  ORDER=  5
 SCALED LOCAL ERROR IS    0.473D-01
 AT T=   0.104D+01 H=  0.412D-01  ORDER=  5
       MESH      NUM SOL          SOL       ERROR
    0.000D+00    0.100D+01    0.100D+01    0.342D-07
    0.245D-01    0.999D+00    0.999D+00    0.342D-07
    0.955D-01    0.991D+00    0.991D+00    0.224D-07
    0.206D+00    0.958D+00    0.958D+00    0.222D-07
    0.345D+00    0.887D+00    0.887D+00    0.393D-07
    0.500D+00    0.779D+00    0.779D+00    0.187D-09
    0.655D+00    0.652D+00    0.652D+00    0.418D-07
    0.794D+00    0.532D+00    0.532D+00    0.723D-08
    0.905D+00    0.441D+00    0.441D+00    0.232D-07
    0.976D+00    0.386D+00    0.386D+00    0.785D-08
    0.100D+01    0.368D+00    0.368D+00    0.486D-08
  ENORM=  0.621D-08       GERR=  0.418D-07
 NSTEPS =   61 NRESID =  130 JAC =   19 CPU=  0.000D+00
 TEST PROBLEM 3
 ***********
 POLY OF DEGREE =   6 NO OF ELEMENTS =    2
 JAC EVAL
 SCALED LOCAL ERROR IS    0.411D+01
 ERROR TEST FAILED
 JAC EVAL
 SCALED LOCAL ERROR IS    0.616D+00
 AT T=   0.314D-04 H=  0.283D-04  ORDER=  1
 SCALED LOCAL ERROR IS    0.261D-03
 AT T=   0.597D-04 H=  0.565D-04  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.192D-03
 AT T=   0.116D-03 H=  0.113D-03  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.701D-03
 AT T=   0.229D-03 H=  0.226D-03  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.266D-02
 AT T=   0.455D-03 H=  0.452D-03  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.107D-01
 AT T=   0.908D-03 H=  0.904D-03  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.423D-01
 AT T=   0.181D-02 H=  0.181D-02  ORDER=  1
 JAC EVAL
 SCALED LOCAL ERROR IS    0.167D+00
 AT T=   0.362D-02 H=  0.181D-02  ORDER=  1
 SCALED LOCAL ERROR IS    0.132D+00
 AT T=   0.543D-02 H=  0.181D-02  ORDER=  1
 SCALED LOCAL ERROR IS    0.132D+00
 ORDER RAISE CONSIDERED
 AT T=   0.724D-02 H=  0.362D-02  ORDER=  1
 SCALED LOCAL ERROR IS    0.965D-01
 AT T=   0.109D-01 H=  0.362D-02  ORDER=  2
 SCALED LOCAL ERROR IS    0.584D-01
 AT T=   0.145D-01 H=  0.723D-02  ORDER=  2
 JAC EVAL
 SCALED LOCAL ERROR IS    0.853D-01
 AT T=   0.217D-01 H=  0.723D-02  ORDER=  2
 SCALED LOCAL ERROR IS    0.216D-01
 AT T=   0.289D-01 H=  0.145D-01  ORDER=  2
 JAC EVAL
 SCALED LOCAL ERROR IS    0.160D+00
 AT T=   0.434D-01 H=  0.145D-01  ORDER=  2
 SCALED LOCAL ERROR IS    0.136D+00
 AT T=   0.579D-01 H=  0.145D-01  ORDER=  2
 SCALED LOCAL ERROR IS    0.148D+00
 AT T=   0.724D-01 H=  0.145D-01  ORDER=  2
 SCALED LOCAL ERROR IS    0.146D+00
 ORDER RAISE CONSIDERED
 AT T=   0.868D-01 H=  0.289D-01  ORDER=  2
 SCALED LOCAL ERROR IS    0.122D+00
 AT T=   0.116D+00 H=  0.289D-01  ORDER=  3
       MESH      NUM SOL          SOL       ERROR
   -0.100D+01   -0.698D-07   -0.139D-15    0.698D-07
   -0.933D+00    0.668D-02    0.668D-02    0.396D-06
   -0.750D+00    0.247D-01    0.247D-01    0.144D-05
   -0.500D+00    0.488D-01    0.488D-01    0.236D-05
   -0.250D+00    0.723D-01    0.723D-01    0.279D-05
   -0.670D-01    0.892D-01    0.892D-01    0.285D-05
    0.000D+00    0.953D-01    0.953D-01    0.282D-05
    0.670D-01    0.154D+00    0.154D+00    0.310D-05
    0.250D+00    0.300D+00    0.300D+00    0.126D-05
    0.500D+00    0.470D+00    0.470D+00    0.733D-06
    0.750D+00    0.615D+00    0.615D+00    0.105D-05
    0.933D+00    0.710D+00    0.710D+00    0.186D-05
    0.100D+01    0.742D+00    0.742D+00    0.153D-05
  ENORM=  0.170D-05       GERR=  0.310D-05
  INTERC ROUTINE CALLED WITH ITYPE = 2  AND INTERP. POINTS
          EQUAL TO BREAK-POINTS I.E.  COMPONENT NO (=I1) WITH
           VALUE (=R1)  IS CLOSE TO BREAK POINT(=I2) WITH
          VALUE (=R2).
          IN ABOVE MESSAGE I1 =         7   I2 =         2
         IN ABOVE,  R1 =  0.0000000000000D+00   R2 =  0.0000000000000D+0
 X = -0.100D+01 TRUE =   0.100D+00 CALC=   0.100D+00 ERR=  0.730D-05
 X = -0.933D+00 TRUE =   0.993D-01 CALC=   0.993D-01 ERR=  0.661D-05
 X = -0.750D+00 TRUE =   0.976D-01 CALC=   0.976D-01 ERR=  0.481D-05
 X = -0.500D+00 TRUE =   0.952D-01 CALC=   0.952D-01 ERR=  0.264D-05
 X = -0.250D+00 TRUE =   0.930D-01 CALC=   0.930D-01 ERR=  0.856D-06
 X = -0.670D-01 TRUE =   0.915D-01 CALC=   0.915D-01 ERR=  0.216D-06
 X =  0.000D+00 TRUE =   0.500D+00 CALC=   0.500D+00 ERR=  0.198D-04
 X =  0.670D-01 TRUE =   0.857D+00 CALC=   0.857D+00 ERR=  0.221D-04
 X =  0.250D+00 TRUE =   0.741D+00 CALC=   0.741D+00 ERR=  0.342D-04
 X =  0.500D+00 TRUE =   0.625D+00 CALC=   0.625D+00 ERR=  0.161D-04
 X =  0.750D+00 TRUE =   0.541D+00 CALC=   0.541D+00 ERR=  0.197D-04
 X =  0.933D+00 TRUE =   0.492D+00 CALC=   0.492D+00 ERR=  0.141D-04
 X =  0.100D+01 TRUE =   0.476D+00 CALC=   0.476D+00 ERR=  0.164D-04
 SCALED LOCAL ERROR IS    0.658D-01
 AT T=   0.145D+00 H=  0.289D-01  ORDER=  3
 SCALED LOCAL ERROR IS    0.760D-01
 AT T=   0.174D+00 H=  0.289D-01  ORDER=  3
 SCALED LOCAL ERROR IS    0.672D-01
 AT T=   0.203D+00 H=  0.289D-01  ORDER=  3
       MESH      NUM SOL          SOL       ERROR
   -0.100D+01    0.953D-01    0.953D-01    0.129D-06
   -0.933D+00    0.101D+00    0.101D+00    0.547D-07
   -0.750D+00    0.118D+00    0.118D+00    0.410D-06
   -0.500D+00    0.140D+00    0.140D+00    0.664D-06
   -0.250D+00    0.161D+00    0.161D+00    0.760D-06
   -0.670D-01    0.177D+00    0.177D+00    0.768D-06
    0.000D+00    0.182D+00    0.182D+00    0.761D-06
    0.670D-01    0.237D+00    0.237D+00    0.182D-06
    0.250D+00    0.372D+00    0.372D+00    0.101D-06
    0.500D+00    0.531D+00    0.531D+00    0.423D-06
    0.750D+00    0.668D+00    0.668D+00    0.558D-06
    0.933D+00    0.758D+00    0.758D+00    0.112D-05
    0.100D+01    0.788D+00    0.788D+00    0.906D-06
  ENORM=  0.591D-06       GERR=  0.112D-05
  INTERC ROUTINE CALLED WITH ITYPE = 2  AND INTERP. POINTS
          EQUAL TO BREAK-POINTS I.E.  COMPONENT NO (=I1) WITH
           VALUE (=R1)  IS CLOSE TO BREAK POINT(=I2) WITH
          VALUE (=R2).
          IN ABOVE MESSAGE I1 =         7   I2 =         2
         IN ABOVE,  R1 =  0.0000000000000D+00   R2 =  0.0000000000000D+0
 X = -0.100D+01 TRUE =   0.909D-01 CALC=   0.909D-01 ERR=  0.300D-05
 X = -0.933D+00 TRUE =   0.904D-01 CALC=   0.904D-01 ERR=  0.249D-05
 X = -0.750D+00 TRUE =   0.889D-01 CALC=   0.889D-01 ERR=  0.147D-05
 X = -0.500D+00 TRUE =   0.870D-01 CALC=   0.870D-01 ERR=  0.645D-06
 X = -0.250D+00 TRUE =   0.851D-01 CALC=   0.851D-01 ERR=  0.167D-06
 X = -0.670D-01 TRUE =   0.838D-01 CALC=   0.838D-01 ERR=  0.672D-07
 X =  0.000D+00 TRUE =   0.458D+00 CALC=   0.458D+00 ERR=  0.967D-05
 X =  0.670D-01 TRUE =   0.789D+00 CALC=   0.789D+00 ERR=  0.206D-04
 X =  0.250D+00 TRUE =   0.690D+00 CALC=   0.690D+00 ERR=  0.157D-04
 X =  0.500D+00 TRUE =   0.588D+00 CALC=   0.588D+00 ERR=  0.119D-04
 X =  0.750D+00 TRUE =   0.513D+00 CALC=   0.513D+00 ERR=  0.131D-04
 X =  0.933D+00 TRUE =   0.469D+00 CALC=   0.469D+00 ERR=  0.911D-05
 X =  0.100D+01 TRUE =   0.455D+00 CALC=   0.455D+00 ERR=  0.107D-04
 SCALED LOCAL ERROR IS    0.508D-01
 ORDER RAISE CONSIDERED
 AT T=   0.232D+00 H=  0.579D-01  ORDER=  3
 JAC EVAL
 SCALED LOCAL ERROR IS    0.252D+00
 AT T=   0.289D+00 H=  0.579D-01  ORDER=  4
 SCALED LOCAL ERROR IS    0.816D-01
 AT T=   0.347D+00 H=  0.579D-01  ORDER=  4
       MESH      NUM SOL          SOL       ERROR
   -0.100D+01    0.182D+00    0.182D+00    0.215D-07
   -0.933D+00    0.188D+00    0.188D+00    0.100D-06
   -0.750D+00    0.203D+00    0.203D+00    0.339D-06
   -0.500D+00    0.223D+00    0.223D+00    0.557D-06
   -0.250D+00    0.243D+00    0.243D+00    0.684D-06
   -0.670D-01    0.257D+00    0.257D+00    0.717D-06
    0.000D+00    0.262D+00    0.262D+00    0.717D-06
    0.670D-01    0.313D+00    0.313D+00    0.954D-06
    0.250D+00    0.438D+00    0.438D+00    0.448D-06
    0.500D+00    0.588D+00    0.588D+00    0.259D-06
    0.750D+00    0.718D+00    0.718D+00    0.396D-06
    0.933D+00    0.803D+00    0.803D+00    0.716D-06
    0.100D+01    0.833D+00    0.833D+00    0.565D-06
  ENORM=  0.488D-06       GERR=  0.954D-06
  INTERC ROUTINE CALLED WITH ITYPE = 2  AND INTERP. POINTS
          EQUAL TO BREAK-POINTS I.E.  COMPONENT NO (=I1) WITH
           VALUE (=R1)  IS CLOSE TO BREAK POINT(=I2) WITH
          VALUE (=R2).
          IN ABOVE MESSAGE I1 =         7   I2 =         2
         IN ABOVE,  R1 =  0.0000000000000D+00   R2 =  0.0000000000000D+0
 X = -0.100D+01 TRUE =   0.833D-01 CALC=   0.833D-01 ERR=  0.203D-05
 X = -0.933D+00 TRUE =   0.829D-01 CALC=   0.829D-01 ERR=  0.163D-05
 X = -0.750D+00 TRUE =   0.816D-01 CALC=   0.816D-01 ERR=  0.107D-05
 X = -0.500D+00 TRUE =   0.800D-01 CALC=   0.800D-01 ERR=  0.693D-06
 X = -0.250D+00 TRUE =   0.784D-01 CALC=   0.784D-01 ERR=  0.320D-06
 X = -0.670D-01 TRUE =   0.773D-01 CALC=   0.773D-01 ERR=  0.456D-07
 X =  0.000D+00 TRUE =   0.423D+00 CALC=   0.423D+00 ERR=  0.702D-05
 X =  0.670D-01 TRUE =   0.732D+00 CALC=   0.732D+00 ERR=  0.108D-04
 X =  0.250D+00 TRUE =   0.645D+00 CALC=   0.645D+00 ERR=  0.132D-04
 X =  0.500D+00 TRUE =   0.556D+00 CALC=   0.556D+00 ERR=  0.694D-05
 X =  0.750D+00 TRUE =   0.488D+00 CALC=   0.488D+00 ERR=  0.840D-05
 X =  0.933D+00 TRUE =   0.448D+00 CALC=   0.448D+00 ERR=  0.628D-05
 X =  0.100D+01 TRUE =   0.435D+00 CALC=   0.435D+00 ERR=  0.709D-05
 SCALED LOCAL ERROR IS    0.132D+00
 AT T=   0.405D+00 H=  0.579D-01  ORDER=  4
       MESH      NUM SOL          SOL       ERROR
   -0.100D+01    0.262D+00    0.262D+00    0.791D-07
   -0.933D+00    0.268D+00    0.268D+00    0.203D-06
   -0.750D+00    0.281D+00    0.281D+00    0.512D-06
   -0.500D+00    0.300D+00    0.300D+00    0.834D-06
   -0.250D+00    0.318D+00    0.318D+00    0.104D-05
   -0.670D-01    0.332D+00    0.332D+00    0.111D-05
    0.000D+00    0.336D+00    0.336D+00    0.112D-05
    0.670D-01    0.383D+00    0.383D+00    0.140D-05
    0.250D+00    0.501D+00    0.501D+00    0.122D-05
    0.500D+00    0.642D+00    0.642D+00    0.613D-06
    0.750D+00    0.765D+00    0.765D+00    0.180D-06
    0.933D+00    0.847D+00    0.847D+00    0.178D-06
    0.100D+01    0.875D+00    0.875D+00    0.798D-07
  ENORM=  0.648D-06       GERR=  0.140D-05
  INTERC ROUTINE CALLED WITH ITYPE = 2  AND INTERP. POINTS
          EQUAL TO BREAK-POINTS I.E.  COMPONENT NO (=I1) WITH
           VALUE (=R1)  IS CLOSE TO BREAK POINT(=I2) WITH
          VALUE (=R2).
          IN ABOVE MESSAGE I1 =         7   I2 =         2
         IN ABOVE,  R1 =  0.0000000000000D+00   R2 =  0.0000000000000D+0
 X = -0.100D+01 TRUE =   0.769D-01 CALC=   0.769D-01 ERR=  0.187D-05
 X = -0.933D+00 TRUE =   0.765D-01 CALC=   0.765D-01 ERR=  0.182D-05
 X = -0.750D+00 TRUE =   0.755D-01 CALC=   0.755D-01 ERR=  0.153D-05
 X = -0.500D+00 TRUE =   0.741D-01 CALC=   0.741D-01 ERR=  0.104D-05
 X = -0.250D+00 TRUE =   0.727D-01 CALC=   0.727D-01 ERR=  0.577D-06
 X = -0.670D-01 TRUE =   0.718D-01 CALC=   0.718D-01 ERR=  0.258D-06
 X =  0.000D+00 TRUE =   0.393D+00 CALC=   0.393D+00 ERR=  0.363D-05
 X =  0.670D-01 TRUE =   0.682D+00 CALC=   0.682D+00 ERR=  0.866D-05
 X =  0.250D+00 TRUE =   0.606D+00 CALC=   0.606D+00 ERR=  0.859D-05
 X =  0.500D+00 TRUE =   0.526D+00 CALC=   0.526D+00 ERR=  0.350D-05
 X =  0.750D+00 TRUE =   0.465D+00 CALC=   0.465D+00 ERR=  0.693D-05
 X =  0.933D+00 TRUE =   0.429D+00 CALC=   0.429D+00 ERR=  0.404D-05
 X =  0.100D+01 TRUE =   0.417D+00 CALC=   0.417D+00 ERR=  0.476D-05
 SCALED LOCAL ERROR IS    0.510D-01
 AT T=   0.463D+00 H=  0.579D-01  ORDER=  4
 SCALED LOCAL ERROR IS    0.370D-01
 AT T=   0.521D+00 H=  0.579D-01  ORDER=  4
       MESH      NUM SOL          SOL       ERROR
   -0.100D+01    0.336D+00    0.336D+00    0.101D-06
   -0.933D+00    0.341D+00    0.341D+00    0.178D-06
   -0.750D+00    0.354D+00    0.354D+00    0.360D-06
   -0.500D+00    0.372D+00    0.372D+00    0.542D-06
   -0.250D+00    0.389D+00    0.389D+00    0.657D-06
   -0.670D-01    0.401D+00    0.401D+00    0.702D-06
    0.000D+00    0.405D+00    0.405D+00    0.712D-06
    0.670D-01    0.449D+00    0.449D+00    0.907D-06
    0.250D+00    0.560D+00    0.560D+00    0.887D-06
    0.500D+00    0.693D+00    0.693D+00    0.735D-06
    0.750D+00    0.811D+00    0.811D+00    0.649D-06
    0.933D+00    0.889D+00    0.889D+00    0.485D-06
    0.100D+01    0.916D+00    0.916D+00    0.573D-06
  ENORM=  0.492D-06       GERR=  0.907D-06
  INTERC ROUTINE CALLED WITH ITYPE = 2  AND INTERP. POINTS
          EQUAL TO BREAK-POINTS I.E.  COMPONENT NO (=I1) WITH
           VALUE (=R1)  IS CLOSE TO BREAK POINT(=I2) WITH
          VALUE (=R2).
          IN ABOVE MESSAGE I1 =         7   I2 =         2
         IN ABOVE,  R1 =  0.0000000000000D+00   R2 =  0.0000000000000D+0
 X = -0.100D+01 TRUE =   0.714D-01 CALC=   0.714D-01 ERR=  0.118D-05
 X = -0.933D+00 TRUE =   0.711D-01 CALC=   0.711D-01 ERR=  0.111D-05
 X = -0.750D+00 TRUE =   0.702D-01 CALC=   0.702D-01 ERR=  0.878D-06
 X = -0.500D+00 TRUE =   0.690D-01 CALC=   0.690D-01 ERR=  0.587D-06
 X = -0.250D+00 TRUE =   0.678D-01 CALC=   0.678D-01 ERR=  0.336D-06
 X = -0.670D-01 TRUE =   0.670D-01 CALC=   0.670D-01 ERR=  0.167D-06
 X =  0.000D+00 TRUE =   0.367D+00 CALC=   0.367D+00 ERR=  0.240D-05
 X =  0.670D-01 TRUE =   0.638D+00 CALC=   0.638D+00 ERR=  0.614D-05
 X =  0.250D+00 TRUE =   0.571D+00 CALC=   0.571D+00 ERR=  0.503D-05
 X =  0.500D+00 TRUE =   0.500D+00 CALC=   0.500D+00 ERR=  0.350D-05
 X =  0.750D+00 TRUE =   0.444D+00 CALC=   0.444D+00 ERR=  0.420D-05
 X =  0.933D+00 TRUE =   0.411D+00 CALC=   0.411D+00 ERR=  0.315D-05
 X =  0.100D+01 TRUE =   0.400D+00 CALC=   0.400D+00 ERR=  0.308D-05
 SCALED LOCAL ERROR IS    0.333D-01
 ORDER RAISE CONSIDERED
 AT T=   0.579D+00 H=  0.116D+00  ORDER=  4
 JAC EVAL
 SCALED LOCAL ERROR IS    0.146D+00
 AT T=   0.695D+00 H=  0.116D+00  ORDER=  5
       MESH      NUM SOL          SOL       ERROR
   -0.100D+01    0.405D+00    0.405D+00    0.384D-07
   -0.933D+00    0.410D+00    0.410D+00    0.288D-07
   -0.750D+00    0.422D+00    0.422D+00    0.193D-06
   -0.500D+00    0.438D+00    0.438D+00    0.369D-06
   -0.250D+00    0.454D+00    0.454D+00    0.489D-06
   -0.670D-01    0.466D+00    0.466D+00    0.542D-06
    0.000D+00    0.470D+00    0.470D+00    0.554D-06
    0.670D-01    0.511D+00    0.511D+00    0.738D-06
    0.250D+00    0.615D+00    0.615D+00    0.797D-06
    0.500D+00    0.742D+00    0.742D+00    0.748D-06
    0.750D+00    0.854D+00    0.854D+00    0.767D-06
    0.933D+00    0.929D+00    0.929D+00    0.709D-06
    0.100D+01    0.956D+00    0.956D+00    0.784D-06
  ENORM=  0.439D-06       GERR=  0.797D-06
  INTERC ROUTINE CALLED WITH ITYPE = 2  AND INTERP. POINTS
          EQUAL TO BREAK-POINTS I.E.  COMPONENT NO (=I1) WITH
           VALUE (=R1)  IS CLOSE TO BREAK POINT(=I2) WITH
          VALUE (=R2).
          IN ABOVE MESSAGE I1 =         7   I2 =         2
         IN ABOVE,  R1 =  0.0000000000000D+00   R2 =  0.0000000000000D+0
 X = -0.100D+01 TRUE =   0.667D-01 CALC=   0.667D-01 ERR=  0.103D-05
 X = -0.933D+00 TRUE =   0.664D-01 CALC=   0.664D-01 ERR=  0.976D-06
 X = -0.750D+00 TRUE =   0.656D-01 CALC=   0.656D-01 ERR=  0.817D-06
 X = -0.500D+00 TRUE =   0.645D-01 CALC=   0.645D-01 ERR=  0.591D-06
 X = -0.250D+00 TRUE =   0.635D-01 CALC=   0.635D-01 ERR=  0.370D-06
 X = -0.670D-01 TRUE =   0.628D-01 CALC=   0.628D-01 ERR=  0.212D-06
 X =  0.000D+00 TRUE =   0.344D+00 CALC=   0.344D+00 ERR=  0.122D-05
 X =  0.670D-01 TRUE =   0.600D+00 CALC=   0.600D+00 ERR=  0.487D-05
 X =  0.250D+00 TRUE =   0.541D+00 CALC=   0.541D+00 ERR=  0.326D-05
 X =  0.500D+00 TRUE =   0.476D+00 CALC=   0.476D+00 ERR=  0.272D-05
 X =  0.750D+00 TRUE =   0.426D+00 CALC=   0.426D+00 ERR=  0.262D-05
 X =  0.933D+00 TRUE =   0.395D+00 CALC=   0.395D+00 ERR=  0.248D-05
 X =  0.100D+01 TRUE =   0.385D+00 CALC=   0.385D+00 ERR=  0.205D-05
 SCALED LOCAL ERROR IS    0.197D+00
 AT T=   0.810D+00 H=  0.116D+00  ORDER=  5
       MESH      NUM SOL          SOL       ERROR
   -0.100D+01    0.470D+00    0.470D+00    0.287D-07
   -0.933D+00    0.474D+00    0.474D+00    0.838D-07
   -0.750D+00    0.486D+00    0.486D+00    0.164D-06
   -0.500D+00    0.501D+00    0.501D+00    0.159D-06
   -0.250D+00    0.516D+00    0.516D+00    0.862D-07
   -0.670D-01    0.527D+00    0.527D+00    0.170D-07
    0.000D+00    0.531D+00    0.531D+00    0.876D-08
    0.670D-01    0.569D+00    0.569D+00    0.326D-06
    0.250D+00    0.668D+00    0.668D+00    0.778D-06
    0.500D+00    0.788D+00    0.788D+00    0.837D-06
    0.750D+00    0.896D+00    0.896D+00    0.638D-06
    0.933D+00    0.968D+00    0.968D+00    0.489D-06
    0.100D+01    0.993D+00    0.993D+00    0.534D-06
  ENORM=  0.349D-06       GERR=  0.837D-06
  INTERC ROUTINE CALLED WITH ITYPE = 2  AND INTERP. POINTS
          EQUAL TO BREAK-POINTS I.E.  COMPONENT NO (=I1) WITH
           VALUE (=R1)  IS CLOSE TO BREAK POINT(=I2) WITH
          VALUE (=R2).
          IN ABOVE MESSAGE I1 =         7   I2 =         2
         IN ABOVE,  R1 =  0.0000000000000D+00   R2 =  0.0000000000000D+0
 X = -0.100D+01 TRUE =   0.625D-01 CALC=   0.625D-01 ERR=  0.944D-06
 X = -0.933D+00 TRUE =   0.622D-01 CALC=   0.622D-01 ERR=  0.706D-06
 X = -0.750D+00 TRUE =   0.615D-01 CALC=   0.615D-01 ERR=  0.205D-06
 X = -0.500D+00 TRUE =   0.606D-01 CALC=   0.606D-01 ERR=  0.195D-06
 X = -0.250D+00 TRUE =   0.597D-01 CALC=   0.597D-01 ERR=  0.360D-06
 X = -0.670D-01 TRUE =   0.591D-01 CALC=   0.591D-01 ERR=  0.386D-06
 X =  0.000D+00 TRUE =   0.324D+00 CALC=   0.324D+00 ERR=  0.639D-06
 X =  0.670D-01 TRUE =   0.566D+00 CALC=   0.566D+00 ERR=  0.624D-05
 X =  0.250D+00 TRUE =   0.513D+00 CALC=   0.513D+00 ERR=  0.836D-06
 X =  0.500D+00 TRUE =   0.455D+00 CALC=   0.455D+00 ERR=  0.141D-05
 X =  0.750D+00 TRUE =   0.408D+00 CALC=   0.408D+00 ERR=  0.274D-05
 X =  0.933D+00 TRUE =   0.380D+00 CALC=   0.380D+00 ERR=  0.152D-05
 X =  0.100D+01 TRUE =   0.370D+00 CALC=   0.370D+00 ERR=  0.151D-05
       MESH      NUM SOL          SOL       ERROR
   -0.100D+01    0.531D+00    0.531D+00    0.143D-06
   -0.933D+00    0.535D+00    0.535D+00    0.328D-06
   -0.750D+00    0.545D+00    0.545D+00    0.730D-06
   -0.500D+00    0.560D+00    0.560D+00    0.106D-05
   -0.250D+00    0.574D+00    0.574D+00    0.120D-05
   -0.670D-01    0.584D+00    0.584D+00    0.119D-05
    0.000D+00    0.588D+00    0.588D+00    0.117D-05
    0.670D-01    0.624D+00    0.624D+00    0.854D-06
    0.250D+00    0.718D+00    0.718D+00    0.101D-06
    0.500D+00    0.833D+00    0.833D+00    0.445D-06
    0.750D+00    0.936D+00    0.936D+00    0.442D-06
    0.933D+00    0.101D+01    0.101D+01    0.322D-06
    0.100D+01    0.103D+01    0.103D+01    0.353D-06
  ENORM=  0.536D-06       GERR=  0.120D-05
  INTERC ROUTINE CALLED WITH ITYPE = 2  AND INTERP. POINTS
          EQUAL TO BREAK-POINTS I.E.  COMPONENT NO (=I1) WITH
           VALUE (=R1)  IS CLOSE TO BREAK POINT(=I2) WITH
          VALUE (=R2).
          IN ABOVE MESSAGE I1 =         7   I2 =         2
         IN ABOVE,  R1 =  0.0000000000000D+00   R2 =  0.0000000000000D+0
 X = -0.100D+01 TRUE =   0.588D-01 CALC=   0.588D-01 ERR=  0.292D-05
 X = -0.933D+00 TRUE =   0.586D-01 CALC=   0.586D-01 ERR=  0.261D-05
 X = -0.750D+00 TRUE =   0.580D-01 CALC=   0.580D-01 ERR=  0.181D-05
 X = -0.500D+00 TRUE =   0.571D-01 CALC=   0.571D-01 ERR=  0.896D-06
 X = -0.250D+00 TRUE =   0.563D-01 CALC=   0.563D-01 ERR=  0.187D-06
 X = -0.670D-01 TRUE =   0.558D-01 CALC=   0.558D-01 ERR=  0.225D-06
 X =  0.000D+00 TRUE =   0.306D+00 CALC=   0.306D+00 ERR=  0.914D-06
 X =  0.670D-01 TRUE =   0.536D+00 CALC=   0.536D+00 ERR=  0.626D-05
 X =  0.250D+00 TRUE =   0.488D+00 CALC=   0.488D+00 ERR=  0.192D-05
 X =  0.500D+00 TRUE =   0.435D+00 CALC=   0.435D+00 ERR=  0.230D-05
 X =  0.750D+00 TRUE =   0.392D+00 CALC=   0.392D+00 ERR=  0.196D-05
 X =  0.933D+00 TRUE =   0.366D+00 CALC=   0.366D+00 ERR=  0.106D-05
 X =  0.100D+01 TRUE =   0.357D+00 CALC=   0.357D+00 ERR=  0.112D-05
 SCALED LOCAL ERROR IS    0.211D+00
 AT T=   0.926D+00 H=  0.116D+00  ORDER=  5
       MESH      NUM SOL          SOL       ERROR
   -0.100D+01    0.588D+00    0.588D+00    0.276D-06
   -0.933D+00    0.592D+00    0.592D+00    0.454D-06
   -0.750D+00    0.602D+00    0.602D+00    0.909D-06
   -0.500D+00    0.615D+00    0.615D+00    0.141D-05
   -0.250D+00    0.629D+00    0.629D+00    0.173D-05
   -0.670D-01    0.638D+00    0.638D+00    0.184D-05
    0.000D+00    0.642D+00    0.642D+00    0.186D-05
    0.670D-01    0.677D+00    0.677D+00    0.184D-05
    0.250D+00    0.765D+00    0.765D+00    0.145D-05
    0.500D+00    0.875D+00    0.875D+00    0.542D-06
    0.750D+00    0.975D+00    0.975D+00    0.106D-06
    0.933D+00    0.104D+01    0.104D+01    0.261D-06
    0.100D+01    0.106D+01    0.106D+01    0.305D-06
  ENORM=  0.832D-06       GERR=  0.186D-05
  INTERC ROUTINE CALLED WITH ITYPE = 2  AND INTERP. POINTS
          EQUAL TO BREAK-POINTS I.E.  COMPONENT NO (=I1) WITH
           VALUE (=R1)  IS CLOSE TO BREAK POINT(=I2) WITH
          VALUE (=R2).
          IN ABOVE MESSAGE I1 =         7   I2 =         2
         IN ABOVE,  R1 =  0.0000000000000D+00   R2 =  0.0000000000000D+0
 X = -0.100D+01 TRUE =   0.556D-01 CALC=   0.556D-01 ERR=  0.269D-05
 X = -0.933D+00 TRUE =   0.553D-01 CALC=   0.553D-01 ERR=  0.263D-05
 X = -0.750D+00 TRUE =   0.548D-01 CALC=   0.548D-01 ERR=  0.231D-05
 X = -0.500D+00 TRUE =   0.541D-01 CALC=   0.541D-01 ERR=  0.167D-05
 X = -0.250D+00 TRUE =   0.533D-01 CALC=   0.533D-01 ERR=  0.897D-06
 X = -0.670D-01 TRUE =   0.528D-01 CALC=   0.528D-01 ERR=  0.317D-06
 X =  0.000D+00 TRUE =   0.289D+00 CALC=   0.289D+00 ERR=  0.135D-05
 X =  0.670D-01 TRUE =   0.508D+00 CALC=   0.508D+00 ERR=  0.201D-05
 X =  0.250D+00 TRUE =   0.465D+00 CALC=   0.465D+00 ERR=  0.207D-05
 X =  0.500D+00 TRUE =   0.417D+00 CALC=   0.417D+00 ERR=  0.452D-05
 X =  0.750D+00 TRUE =   0.377D+00 CALC=   0.377D+00 ERR=  0.569D-06
 X =  0.933D+00 TRUE =   0.353D+00 CALC=   0.353D+00 ERR=  0.138D-05
 X =  0.100D+01 TRUE =   0.345D+00 CALC=   0.345D+00 ERR=  0.800D-06
 SCALED LOCAL ERROR IS    0.124D+00
 AT T=   0.104D+01 H=  0.116D+00  ORDER=  5
       MESH      NUM SOL          SOL       ERROR
   -0.100D+01    0.642D+00    0.642D+00    0.274D-06
   -0.933D+00    0.645D+00    0.645D+00    0.413D-06
   -0.750D+00    0.655D+00    0.655D+00    0.739D-06
   -0.500D+00    0.668D+00    0.668D+00    0.108D-05
   -0.250D+00    0.681D+00    0.681D+00    0.131D-05
   -0.670D-01    0.690D+00    0.690D+00    0.142D-05
    0.000D+00    0.693D+00    0.693D+00    0.144D-05
    0.670D-01    0.726D+00    0.726D+00    0.158D-05
    0.250D+00    0.811D+00    0.811D+00    0.173D-05
    0.500D+00    0.916D+00    0.916D+00    0.130D-05
    0.750D+00    0.101D+01    0.101D+01    0.615D-06
    0.933D+00    0.108D+01    0.108D+01    0.351D-06
    0.100D+01    0.110D+01    0.110D+01    0.314D-06
  ENORM=  0.784D-06       GERR=  0.173D-05
  INTERC ROUTINE CALLED WITH ITYPE = 2  AND INTERP. POINTS
          EQUAL TO BREAK-POINTS I.E.  COMPONENT NO (=I1) WITH
           VALUE (=R1)  IS CLOSE TO BREAK POINT(=I2) WITH
          VALUE (=R2).
          IN ABOVE MESSAGE I1 =         7   I2 =         2
         IN ABOVE,  R1 =  0.0000000000000D+00   R2 =  0.0000000000000D+0
 X = -0.100D+01 TRUE =   0.526D-01 CALC=   0.526D-01 ERR=  0.217D-05
 X = -0.933D+00 TRUE =   0.524D-01 CALC=   0.524D-01 ERR=  0.199D-05
 X = -0.750D+00 TRUE =   0.519D-01 CALC=   0.519D-01 ERR=  0.159D-05
 X = -0.500D+00 TRUE =   0.513D-01 CALC=   0.513D-01 ERR=  0.114D-05
 X = -0.250D+00 TRUE =   0.506D-01 CALC=   0.506D-01 ERR=  0.727D-06
 X = -0.670D-01 TRUE =   0.502D-01 CALC=   0.502D-01 ERR=  0.415D-06
 X =  0.000D+00 TRUE =   0.275D+00 CALC=   0.275D+00 ERR=  0.221D-05
 X =  0.670D-01 TRUE =   0.484D+00 CALC=   0.484D+00 ERR=  0.985D-06
 X =  0.250D+00 TRUE =   0.444D+00 CALC=   0.444D+00 ERR=  0.452D-06
 X =  0.500D+00 TRUE =   0.400D+00 CALC=   0.400D+00 ERR=  0.347D-05
 X =  0.750D+00 TRUE =   0.364D+00 CALC=   0.364D+00 ERR=  0.154D-05
 X =  0.933D+00 TRUE =   0.341D+00 CALC=   0.341D+00 ERR=  0.134D-05
 X =  0.100D+01 TRUE =   0.333D+00 CALC=   0.333D+00 ERR=  0.793D-06
 NSTEPS =   33 NRESID =   65 JAC =   12 CPU=  0.000D+00


 RTOL=   0.100D-04 ATOL=   0.100D-04 ITRACE AND IDEV=   0   4


 SOLUTION TO B.P. POOL EVAPORATION PROBLEM USING        DASSL INTEGRATOR
   ATOL =   0.100D-04  RTOL =   0.100D-04  NPTS =    22

   I=  1 XOUT=  0.00000D+00    LOG10=  0.00000D+00
   I=  2 XOUT=  0.12700D-03    LOG10=  0.17609D+00
   I=  3 XOUT=  0.25400D-03    LOG10=  0.30103D+00
   I=  4 XOUT=  0.38100D-03    LOG10=  0.39794D+00
   I=  5 XOUT=  0.50800D-03    LOG10=  0.47712D+00
   I=  6 XOUT=  0.63500D-03    LOG10=  0.54407D+00
   I=  7 XOUT=  0.76200D-03    LOG10=  0.60206D+00
   I=  8 XOUT=  0.88900D-03    LOG10=  0.65321D+00
   I=  9 XOUT=  0.10000D-02    LOG10=  0.69346D+00
   I= 10 XOUT=  0.30000D-02    LOG10=  0.11076D+01
   I= 11 XOUT=  0.50000D-02    LOG10=  0.13157D+01
   I= 12 XOUT=  0.75000D-02    LOG10=  0.14847D+01
   I= 13 XOUT=  0.10000D-01    LOG10=  0.16061D+01
   I= 14 XOUT=  0.30000D-01    LOG10=  0.20759D+01
   I= 15 XOUT=  0.50000D-01    LOG10=  0.22963D+01
   I= 16 XOUT=  0.75000D-01    LOG10=  0.24717D+01
   I= 17 XOUT=  0.10000D+00    LOG10=  0.25963D+01
   I= 18 XOUT=  0.15000D+00    LOG10=  0.27720D+01
   I= 19 XOUT=  0.20000D+00    LOG10=  0.28967D+01
   I= 20 XOUT=  0.22000D+00    LOG10=  0.29381D+01
  INICHB ROUTINE HAS FOUND THAT COUPLING  POINT (=I1) HAS
          VALUE (=R1) WHICH IS VERY CLOSE TO  BREAK-POINT
          (=I2) WITH VALUE (=R2)
          IN ABOVE MESSAGE I1 =         4   I2 =         2
         IN ABOVE,  R1 =  0.2540000000000D-03   R2 =  0.2540000000000D-0
  INICHB ROUTINE HAS FOUND THAT COUPLING  POINT (=I1) HAS
          VALUE (=R1) WHICH IS VERY CLOSE TO  BREAK-POINT
          (=I2) WITH VALUE (=R2)
          IN ABOVE MESSAGE I1 =         7   I2 =         3
         IN ABOVE,  R1 =  0.5080000000000D-03   R2 =  0.5080000000000D-0
  INICHB ROUTINE HAS FOUND THAT COUPLING  POINT (=I1) HAS
          VALUE (=R1) WHICH IS VERY CLOSE TO  BREAK-POINT
          (=I2) WITH VALUE (=R2)
          IN ABOVE MESSAGE I1 =        10   I2 =         4
         IN ABOVE,  R1 =  0.7620000000000D-03   R2 =  0.7620000000000D-0
  INICHB ROUTINE HAS FOUND THAT COUPLING  POINT (=I1) HAS
          VALUE (=R1) WHICH IS VERY CLOSE TO  BREAK-POINT
          (=I2) WITH VALUE (=R2)
          IN ABOVE MESSAGE I1 =        13   I2 =         5
         IN ABOVE,  R1 =  0.1016000000000D-02   R2 =  0.1016000000000D-0
  INICHB ROUTINE HAS FOUND THAT COUPLING  POINT (=I1) HAS
          VALUE (=R1) WHICH IS VERY CLOSE TO  BREAK-POINT
          (=I2) WITH VALUE (=R2)
          IN ABOVE MESSAGE I1 =        16   I2 =         6
         IN ABOVE,  R1 =  0.5588000000000D-02   R2 =  0.5588000000000D-0
  INICHB ROUTINE HAS FOUND THAT COUPLING  POINT (=I1) HAS
          VALUE (=R1) WHICH IS VERY CLOSE TO  BREAK-POINT
          (=I2) WITH VALUE (=R2)
          IN ABOVE MESSAGE I1 =        19   I2 =         7
         IN ABOVE,  R1 =  0.6146800000000D-01   R2 =  0.6146800000000D-0
 INITIAL VALUES ARE =  0.385D-01  0.000D+00  0.000D+00  0.000D+00  0.000
 INITIAL VALUES ARE =  0.000D+00  0.000D+00  0.000D+00  0.000D+00  0.000
 INITIAL VALUES ARE =  0.000D+00  0.000D+00  0.000D+00  0.000D+00  0.000
 INITIAL VALUES ARE =  0.000D+00  0.000D+00  0.000D+00  0.000D+00  0.000
 INITIAL VALUES ARE =  0.000D+00  0.000D+00
 0.0 U     0.385D-01  0.000D+00  0.000D+00  0.000D+00  0.000D+00  0.000D
 X AND Y VALUES ARE   0.0000E+00  0.1000E+01
 X AND Y VALUES ARE   0.1761E+00 -0.1667E+00
 X AND Y VALUES ARE   0.3010E+00  0.0000E+00
 X AND Y VALUES ARE   0.3979E+00  0.0000E+00
 X AND Y VALUES ARE   0.4771E+00  0.0000E+00
 X AND Y VALUES ARE   0.5441E+00  0.0000E+00
 X AND Y VALUES ARE   0.6021E+00  0.0000E+00
 X AND Y VALUES ARE   0.6532E+00  0.0000E+00
 X AND Y VALUES ARE   0.6935E+00  0.0000E+00
 X AND Y VALUES ARE   0.1108E+01  0.0000E+00
 X AND Y VALUES ARE   0.1316E+01  0.0000E+00
 X AND Y VALUES ARE   0.1485E+01  0.0000E+00
 X AND Y VALUES ARE   0.1606E+01  0.0000E+00
 X AND Y VALUES ARE   0.2076E+01  0.0000E+00
 X AND Y VALUES ARE   0.2296E+01  0.0000E+00
 X AND Y VALUES ARE   0.2472E+01  0.0000E+00
 X AND Y VALUES ARE   0.2596E+01  0.0000E+00
 X AND Y VALUES ARE   0.2772E+01  0.0000E+00
 X AND Y VALUES ARE   0.2897E+01  0.0000E+00
 X AND Y VALUES ARE   0.2938E+01  0.0000E+00

  T/X      0.000D+00  0.254D-03  0.508D-03  0.762D-03  0.100D-02  0.500D

  T/X      0.200D+00
 AT TIME T =   0.100D-03 DASSL RETURNED IDID =  3
 0.0 U     0.385D-01 -0.379D-04  0.201D-07 -0.111D-10  0.497D-14  0.313D
 Q1 , Q2 AND Q3 ARE   0.61252D-06  0.51090D-06 -0.10161D-06
 X AND Y VALUES ARE   0.0000E+00  0.1000E+01
 X AND Y VALUES ARE   0.1761E+00  0.2723E-01
 X AND Y VALUES ARE   0.3010E+00  0.7576E-02
 X AND Y VALUES ARE   0.3979E+00 -0.9850E-03
 X AND Y VALUES ARE   0.4771E+00  0.4300E-04
 X AND Y VALUES ARE   0.5441E+00 -0.2942E-05
 X AND Y VALUES ARE   0.6021E+00  0.5224E-06
 X AND Y VALUES ARE   0.6532E+00 -0.1793E-07
 X AND Y VALUES ARE   0.6935E+00  0.6562E-08
 X AND Y VALUES ARE   0.1108E+01 -0.2882E-09
 X AND Y VALUES ARE   0.1316E+01  0.8455E-10
 X AND Y VALUES ARE   0.1485E+01  0.1823E-12
 X AND Y VALUES ARE   0.1606E+01  0.1292E-12
 X AND Y VALUES ARE   0.2076E+01 -0.4027E-13
 X AND Y VALUES ARE   0.2296E+01  0.6115E-14
 X AND Y VALUES ARE   0.2472E+01  0.8134E-18
 X AND Y VALUES ARE   0.2596E+01  0.6765E-18
 X AND Y VALUES ARE   0.2772E+01  0.4403E-18
 X AND Y VALUES ARE   0.2897E+01  0.2504E-18
 X AND Y VALUES ARE   0.2938E+01  0.1865E-18
 AT TIME T =   0.100D-02 DASSL RETURNED IDID =  3
 0.0 U     0.385D-01 -0.123D-03  0.286D-06 -0.132D-08  0.287D-11  0.106D
 Q1 , Q2 AND Q3 ARE   0.25518D-05  0.23813D-05 -0.17044D-06
 AT TIME T =   0.100D-01 DASSL RETURNED IDID =  3
 0.0 U     0.385D-01  0.777D-02  0.561D-03 -0.308D-04  0.526D-06  0.189D
 Q1 , Q2 AND Q3 ARE   0.10948D-04  0.10852D-04 -0.95811D-07
 X AND Y VALUES ARE   0.0000E+00  0.1000E+01
 X AND Y VALUES ARE   0.1761E+00  0.7058E+00
 X AND Y VALUES ARE   0.3010E+00  0.4291E+00
 X AND Y VALUES ARE   0.3979E+00  0.2018E+00
 X AND Y VALUES ARE   0.4771E+00  0.3737E-01
 X AND Y VALUES ARE   0.5441E+00  0.2322E-01
 X AND Y VALUES ARE   0.6021E+00  0.1458E-01
 X AND Y VALUES ARE   0.6532E+00  0.9107E-02
 X AND Y VALUES ARE   0.6935E+00  0.5998E-02
 X AND Y VALUES ARE   0.1108E+01 -0.8013E-03
 X AND Y VALUES ARE   0.1316E+01  0.1979E-03
 X AND Y VALUES ARE   0.1485E+01  0.1926E-04
 X AND Y VALUES ARE   0.1606E+01  0.1367E-04
 X AND Y VALUES ARE   0.2076E+01 -0.4229E-05
 X AND Y VALUES ARE   0.2296E+01  0.6220E-06
 X AND Y VALUES ARE   0.2472E+01  0.4902E-08
 X AND Y VALUES ARE   0.2596E+01  0.4077E-08
 X AND Y VALUES ARE   0.2772E+01  0.2654E-08
 X AND Y VALUES ARE   0.2897E+01  0.1509E-08
 X AND Y VALUES ARE   0.2938E+01  0.1124E-08
 AT TIME T =   0.500D-01 DASSL RETURNED IDID =  3
 0.1 U     0.385D-01  0.137D-01  0.416D-02  0.286D-03  0.219D-04  0.606D
 Q1 , Q2 AND Q3 ARE   0.34233D-04  0.34161D-04 -0.71581D-07
 AT TIME T =   0.100D+00 DASSL RETURNED IDID =  3
 0.1 U     0.385D-01  0.151D-01  0.584D-02  0.119D-02  0.167D-03  0.693D
 Q1 , Q2 AND Q3 ARE   0.59954D-04  0.59886D-04 -0.67327D-07
 X AND Y VALUES ARE   0.0000E+00  0.1000E+01
 X AND Y VALUES ARE   0.1761E+00  0.7969E+00
 X AND Y VALUES ARE   0.3010E+00  0.5941E+00
 X AND Y VALUES ARE   0.3979E+00  0.3925E+00
 X AND Y VALUES ARE   0.4771E+00  0.1932E+00
 X AND Y VALUES ARE   0.5441E+00  0.1702E+00
 X AND Y VALUES ARE   0.6021E+00  0.1519E+00
 X AND Y VALUES ARE   0.6532E+00  0.1368E+00
 X AND Y VALUES ARE   0.6935E+00  0.1255E+00
 X AND Y VALUES ARE   0.1108E+01  0.3105E-01
 X AND Y VALUES ARE   0.1316E+01  0.1120E-01
 X AND Y VALUES ARE   0.1485E+01  0.6007E-02
 X AND Y VALUES ARE   0.1606E+01  0.4327E-02
 X AND Y VALUES ARE   0.2076E+01 -0.1208E-02
 X AND Y VALUES ARE   0.2296E+01  0.1078E-03
 X AND Y VALUES ARE   0.2472E+01  0.1802E-04
 X AND Y VALUES ARE   0.2596E+01  0.1499E-04
 X AND Y VALUES ARE   0.2772E+01  0.9763E-05
 X AND Y VALUES ARE   0.2897E+01  0.5562E-05
 X AND Y VALUES ARE   0.2938E+01  0.4147E-05
 AT TIME T =   0.150D+00 DASSL RETURNED IDID =  3
 0.1 U     0.385D-01  0.158D-01  0.678D-02  0.191D-02  0.404D-03  0.246D
 Q1 , Q2 AND Q3 ARE   0.84571D-04  0.84506D-04 -0.65201D-07
 AT TIME T =   0.250D+00 DASSL RETURNED IDID =  3
 0.3 U     0.385D-01  0.167D-01  0.794D-02  0.299D-02  0.914D-03  0.776D
 Q1 , Q2 AND Q3 ARE   0.13206D-03  0.13199D-03 -0.62684D-07
 X AND Y VALUES ARE   0.0000E+00  0.1000E+01
 X AND Y VALUES ARE   0.1761E+00  0.8110E+00
 X AND Y VALUES ARE   0.3010E+00  0.6220E+00
 X AND Y VALUES ARE   0.3979E+00  0.4335E+00
 X AND Y VALUES ARE   0.4771E+00  0.2459E+00
 X AND Y VALUES ARE   0.5441E+00  0.2240E+00
 X AND Y VALUES ARE   0.6021E+00  0.2064E+00
 X AND Y VALUES ARE   0.6532E+00  0.1916E+00
 X AND Y VALUES ARE   0.6935E+00  0.1804E+00
 X AND Y VALUES ARE   0.1108E+01  0.7780E-01
 X AND Y VALUES ARE   0.1316E+01  0.4570E-01
 X AND Y VALUES ARE   0.1485E+01  0.3197E-01
 X AND Y VALUES ARE   0.1606E+01  0.2376E-01
 X AND Y VALUES ARE   0.2076E+01 -0.4934E-02
 X AND Y VALUES ARE   0.2296E+01 -0.8292E-04
 X AND Y VALUES ARE   0.2472E+01  0.2016E-03
 X AND Y VALUES ARE   0.2596E+01  0.1679E-03
 X AND Y VALUES ARE   0.2772E+01  0.1096E-03
 X AND Y VALUES ARE   0.2897E+01  0.6266E-04
 X AND Y VALUES ARE   0.2938E+01  0.4685E-04
 AT TIME T =   0.500D+00 DASSL RETURNED IDID =  3
 0.5 U     0.385D-01  0.179D-01  0.959D-02  0.470D-02  0.194D-02  0.176D
 Q1 , Q2 AND Q3 ARE   0.24505D-03  0.24499D-03 -0.59215D-07
 AT TIME T =   0.650D+00 DASSL RETURNED IDID =  3
 0.6 U     0.385D-01  0.183D-01  0.102D-01  0.537D-02  0.241D-02  0.223D
 Q1 , Q2 AND Q3 ARE   0.31036D-03  0.31030D-03 -0.57922D-07
 X AND Y VALUES ARE   0.0000E+00  0.1000E+01
 X AND Y VALUES ARE   0.1761E+00  0.8253E+00
 X AND Y VALUES ARE   0.3010E+00  0.6507E+00
 X AND Y VALUES ARE   0.3979E+00  0.4763E+00
 X AND Y VALUES ARE   0.4771E+00  0.3022E+00
 X AND Y VALUES ARE   0.5441E+00  0.2818E+00
 X AND Y VALUES ARE   0.6021E+00  0.2653E+00
 X AND Y VALUES ARE   0.6532E+00  0.2513E+00
 X AND Y VALUES ARE   0.6935E+00  0.2407E+00
 X AND Y VALUES ARE   0.1108E+01  0.1395E+00
 X AND Y VALUES ARE   0.1316E+01  0.1020E+00
 X AND Y VALUES ARE   0.1485E+01  0.7928E-01
 X AND Y VALUES ARE   0.1606E+01  0.6268E-01
 X AND Y VALUES ARE   0.2076E+01 -0.1871E-02
 X AND Y VALUES ARE   0.2296E+01 -0.1470E-03
 X AND Y VALUES ARE   0.2472E+01  0.5789E-03
 X AND Y VALUES ARE   0.2596E+01  0.4834E-03
 X AND Y VALUES ARE   0.2772E+01  0.3181E-03
 X AND Y VALUES ARE   0.2897E+01  0.1846E-03
 X AND Y VALUES ARE   0.2938E+01  0.1395E-03
 AT TIME T =   0.800D+00 DASSL RETURNED IDID =  3
 0.8 U     0.385D-01  0.187D-01  0.107D-01  0.588D-02  0.280D-02  0.299D
 Q1 , Q2 AND Q3 ARE   0.37441D-03  0.37435D-03 -0.56940D-07
 AT TIME T =   0.100D+01 DASSL RETURNED IDID =  3
 1.0 U     0.385D-01  0.190D-01  0.112D-01  0.641D-02  0.324D-02  0.478D
 Q1 , Q2 AND Q3 ARE   0.45833D-03  0.45828D-03 -0.55941D-07
 X AND Y VALUES ARE   0.0000E+00  0.1000E+01
 X AND Y VALUES ARE   0.1761E+00  0.8313E+00
 X AND Y VALUES ARE   0.3010E+00  0.6627E+00
 X AND Y VALUES ARE   0.3979E+00  0.4941E+00
 X AND Y VALUES ARE   0.4771E+00  0.3257E+00
 X AND Y VALUES ARE   0.5441E+00  0.3060E+00
 X AND Y VALUES ARE   0.6021E+00  0.2900E+00
 X AND Y VALUES ARE   0.6532E+00  0.2765E+00
 X AND Y VALUES ARE   0.6935E+00  0.2662E+00
 X AND Y VALUES ARE   0.1108E+01  0.1666E+00
 X AND Y VALUES ARE   0.1316E+01  0.1281E+00
 X AND Y VALUES ARE   0.1485E+01  0.1032E+00
 X AND Y VALUES ARE   0.1606E+01  0.8423E-01
 X AND Y VALUES ARE   0.2076E+01  0.6509E-02
 X AND Y VALUES ARE   0.2296E+01  0.2203E-02
 X AND Y VALUES ARE   0.2472E+01  0.1242E-02
 X AND Y VALUES ARE   0.2596E+01  0.1038E-02
 X AND Y VALUES ARE   0.2772E+01  0.6846E-03
 X AND Y VALUES ARE   0.2897E+01  0.3989E-03
 X AND Y VALUES ARE   0.2938E+01  0.3023E-03
 RATE OF EVAPORATION AT SURFACE OF POOL Q1 =  0.4583313D-03
 QUANTITY OF VAPOUR ABOVE END OF POOL   Q2 =  0.4582754D-03
 ABSOLUTE DIFFERENCE Q3 =  0.5594D-07
********************************************************

CNSTEPS =   93 NRESID =  186 JAC =   19 CPU=  0.000D+00


 RTOL=   0.100D-04 ATOL=   0.100D-04 ITRACE AND IDEV=   0   4


 SOLUTION TO FOURTH ORDER P.D.E. PROBLEM USING          DASSL INTEGRATOR
   ATOL =   0.100D-04  RTOL =   0.100D-04  NPTS =    41

 X -0.100D+01 -0.600D+00 -0.200D+00  0.200D+00  0.600D+00  0.100D+01
 AT TIME T =   0.100D-03 DASSL RETURNED IDID =  3
 LEFT SOL=  0.100D+01 -0.248D+01 RIGHT SOL= -0.100D+01  0.248D+01
 U  0.100D+01  0.809D+00  0.309D+00 -0.309D+00 -0.809D+00 -0.100D+01
 V -0.248D+01 -0.200D+01 -0.762D+00  0.762D+00  0.200D+01  0.248D+01
 AT TIME T =   0.100D-02 DASSL RETURNED IDID =  3
 LEFT SOL=  0.100D+01 -0.255D+01 RIGHT SOL= -0.100D+01  0.255D+01
 U  0.100D+01  0.809D+00  0.309D+00 -0.309D+00 -0.809D+00 -0.100D+01
 V -0.255D+01 -0.199D+01 -0.761D+00  0.761D+00  0.199D+01  0.255D+01
 AT TIME T =   0.100D-01 DASSL RETURNED IDID =  3
 LEFT SOL=  0.100D+01 -0.272D+01 RIGHT SOL= -0.100D+01  0.272D+01
 U  0.100D+01  0.805D+00  0.307D+00 -0.307D+00 -0.805D+00 -0.100D+01
 V -0.272D+01 -0.195D+01 -0.744D+00  0.744D+00  0.195D+01  0.272D+01
 AT TIME T =   0.100D+00 DASSL RETURNED IDID =  3
 LEFT SOL=  0.100D+01 -0.303D+01 RIGHT SOL= -0.100D+01  0.303D+01
 U  0.100D+01  0.793D+00  0.297D+00 -0.297D+00 -0.793D+00 -0.100D+01
 V -0.303D+01 -0.180D+01 -0.625D+00  0.625D+00  0.180D+01  0.303D+01
 AT TIME T =   0.100D+01 DASSL RETURNED IDID =  3
 LEFT SOL=  0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01  0.310D+01
 U  0.100D+01  0.790D+00  0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01
 V -0.310D+01 -0.177D+01 -0.586D+00  0.586D+00  0.177D+01  0.310D+01
 AT TIME T =   0.100D+02 DASSL RETURNED IDID =  3
 LEFT SOL=  0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01  0.310D+01
 U  0.100D+01  0.790D+00  0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01
 V -0.310D+01 -0.177D+01 -0.586D+00  0.586D+00  0.177D+01  0.310D+01
 AT TIME T =   0.200D+02 DASSL RETURNED IDID =  3
 LEFT SOL=  0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01  0.310D+01
 U  0.100D+01  0.790D+00  0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01
 V -0.310D+01 -0.177D+01 -0.586D+00  0.586D+00  0.177D+01  0.310D+01
 AT TIME T =   0.400D+02 DASSL RETURNED IDID =  3
 LEFT SOL=  0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01  0.310D+01
 U  0.100D+01  0.790D+00  0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01
 V -0.310D+01 -0.177D+01 -0.586D+00  0.586D+00  0.177D+01  0.310D+01
 AT TIME T =   0.600D+02 DASSL RETURNED IDID =  3
 LEFT SOL=  0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01  0.310D+01
 U  0.100D+01  0.790D+00  0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01
 V -0.310D+01 -0.177D+01 -0.586D+00  0.586D+00  0.177D+01  0.310D+01
 AT TIME T =   0.800D+02 DASSL RETURNED IDID =  3
 LEFT SOL=  0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01  0.310D+01
 U  0.100D+01  0.790D+00  0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01
 V -0.310D+01 -0.177D+01 -0.586D+00  0.586D+00  0.177D+01  0.310D+01
 AT TIME T =   0.100D+03 DASSL RETURNED IDID =  3
 LEFT SOL=  0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01  0.310D+01
 U  0.100D+01  0.790D+00  0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01
 V -0.310D+01 -0.177D+01 -0.586D+00  0.586D+00  0.177D+01  0.310D+01
 AT TIME T =   0.100D+04 DASSL RETURNED IDID =  2
 LEFT SOL=  0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01  0.310D+01
 U  0.100D+01  0.790D+00  0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01
 V -0.310D+01 -0.177D+01 -0.586D+00  0.586D+00  0.177D+01  0.310D+01
 NSTEPS =  264 NRESID =  366 JAC =  201
