      SUBROUTINE D8XTRP(TSTART,TSTOP,XA,FCN,BETA,GAMMA,DELTA,NX,DT,N,
     1                  KMAX,MMAX,XPOLY,ERROR,SERROR,ERRPAR,OUTPUT,SOUT,
     2                  PESPAR,LOGN,HOPT,HOPTO,NG,X0,X1,LOZNGE,F,
     3                  POW,WORK,LNWORK,COST)
C
      COMMON /D9XTRP/MC,KOPTC,ICOST,KHIC,IHOPT,IRCNT,HUP,ILOZNG,KMAXC
C
      DOUBLE PRECISION TSTART,TSTOP,BETA,GAMMA,DELTA,DT,LOGN(MMAX),
     1                 NG(MMAX),X0(NX),X1(NX),LOZNGE(NX,KMAX)
      REAL ERRPAR(2),PESPAR,HOPT(1),HOPTO(1),
     1     F(KMAX),POW(KMAX),WORK(MMAX),LNWORK(MMAX),COST(1)
C     REAL HOPT(KMAX+1),HOPTO(KMAX+1),COST(KMAX+1)
      INTEGER N(MMAX)
      LOGICAL XPOLY,ERROR,SERROR
      EXTERNAL XA,FCN,ERROR,SERROR,OUTPUT,SOUT
C
      DOUBLE PRECISION CLOSE,DTSAVE,TEMP,TBAD,T0,T1,DTNEW,D1MACH,DLOG
      REAL LOGLO,LOGHI,HUP0,HUPMAX,HUP,RTEMP
      LOGICAL D8XTRD,LOGGED,FAILED,PRSTRT,D8XTRL,EEQ0,OK
C
      COMMON /CSTAK/DS
      DOUBLE PRECISION DS(500)
      REAL RS(1000)
      EQUIVALENCE (DS(1),RS(1))
C
C  IF T0 AND T1 ARE ON THE SAME SIDE OF TSTOP AND T1 IS WITHIN
C  CLOSE*ABS(DT) OF TSTOP, THEN T1=TSTOP IS CHOSEN.
C
C  MRCNT LOGARITHMIC BISECTION STEPS ARE TAKEN AFTER EACH RESTART.
C
C  ALLOW HOPT(NEW)/HOPT(OLD) TO RISE BY AT MOST EXP(HUP) WHERE
C  HUP=HUP0 AT THE END OF A RESTART SEQUENCE AND EACH SUCCESSFUL STEP
C  THEREAFTER RESULTS IN HUP=MIN(2*HUP,HUPMAX).
C
      DATA CLOSE/1.0D-2/,MRCNT/3/,HUP0/0.1E0/,HUPMAX/7.0E0/
C
C ... GET THE LOGARITHMS OF THE LARGEST AND SMALLEST NUMBERS IN THE
C ... MACHINE.
C
      LOGLO=DLOG(D1MACH(1))
      LOGHI=DLOG(D1MACH(2))
C
C/6S
C     IF ((DT/DABS(DT))*(TSTOP-TSTART).LE.0.0D0) CALL SETERR
C    1   (30HDSXTRP - DT HAS THE WRONG SIGN,30,12,2)
C/7S
      IF ((DT/DABS(DT))*(TSTOP-TSTART).LE.0.0D0) CALL SETERR
     1   ('DSXTRP - DT HAS THE WRONG SIGN',30,12,2)
C/
C
C ... INITIALIZE.
C
      MUSED=0
      KOPTC=0
      IRCNT=0
      KOPTO=1
      T1=TSTART
      HUP=HUPMAX
      PRSTRT=.FALSE.
C
C ... TAKE A TIME-STEP.
C
 10      T0=T1
         T1=T0+DT
C
         IF ((DT/DABS(DT))*(T1-TSTOP).GE.0.0D0) T1=TSTOP
         IF (DABS(T1-TSTOP).LE.CLOSE*DABS(DT)) T1=TSTOP
C
         DT=T1-T0
C/6S
C        IF (T0+DT.EQ.T0) CALL SETERR
C    1      (13HDSXTRP - DT=0,13,13,1)
C/7S
         IF (T0+DT.EQ.T0) CALL SETERR
     1      ('DSXTRP - DT=0',13,13,1)
C/
         IF (T0+DT.EQ.T0) GO TO 140
C
         DO 40 MT=1,MMAX
C
            FAILED=.FALSE.
            LOGGED=.FALSE.
            M=MT
            MC=M
C
C ......... GET X1=T(DT/N(M)).
C
            CALL XA(T0,X0,T1,X1,NX,N(M),FCN,OK)
C
            IF (.NOT.OK) GO TO 130
C
C ......... EXTRAPOLATE THE RESULTS.
C
            ITEMP=ILOZNG
            IF (MIN0(M,KMAX).GT.MUSED) ITEMP=ISTKMD(NX*MIN0(M,KMAX))
C/6S
C           IF (ILOZNG.NE.ITEMP) CALL SETERR
C    1         (47HDSXTRP - SOMEBODY IS LEAVING STUFF ON THE STACK,47,
C    2          18,2)
C/7S
            IF (ILOZNG.NE.ITEMP) CALL SETERR
     1         ('DSXTRP - SOMEBODY IS LEAVING STUFF ON THE STACK',47,
     2          18,2)
C/
            MUSED=MAX0(M,MUSED)
C
            IE=ISTKGT(NX,3)
            IE2=ISTKGT(MAX0(1,NX*MIN0(M-1,KMAX)),3)
            CALL DXTRAP(X1,M,NX,NG,KMAX,XPOLY,LOZNGE,RS(IE2),RS(IE))
C
C ......... CHECK FOR CONVERGENCE.
C
            IF (M.EQ.1) GO TO 40
C
            IF (SERROR(X1,NX,T1,DT,ERRPAR,DELTA,RS(IE),ERROR)) GO TO 60
C
            IF (M.LE.KOPTO) GO TO 40
C
C ......... SEE IF A RE-START IS NECESSARY.
C
            EEQ0=D8XTRL(RS(IE2),RS(IE),NX,M,KMAX,POW,LOGLO)
            LOGGED=.TRUE.
C
            IF (EEQ0) CALL ISTKRL(2)
            IF (EEQ0) GO TO 140
C
C ......... IF WILL NOT CONVERGE IN THIS LOZENGE, RESTART.
C
            FAILED=D8XTRD(RS(IE2),NX,M,MMAX,KMAX,LOGN,BETA,GAMMA,DELTA,
     1                    F,POW,L,LDONE,KOPTO)
C
            IF (FAILED) GO TO 50
C
C ......... SEE IF A RE-START WOULD BE MORE EFFICIENT.
C
            IF (M.EQ.KOPTO+1) GO TO 40
C
            CALL D8XTRO(RS(IE2),NX,M,MMAX,KMAX,LOGN,GAMMA,F,POW,KOPT,
     1                  DT,HOPT,LNWORK,COST,LOGLO,LOGHI)
C
            RTEMP=SNGL(DT/HOPT(KOPT+1))
            IF (RTEMP.GT.1.0E+3     .AND.
     1          WORK(M)+WORK(KOPT+2)*RTEMP.GT.WORK(L)) GO TO 40
C
            IF (RTEMP.GT.1.0E+3) GO TO 30
C
            IRTEMP=IFIX(RTEMP)
            RTEMP=(RTEMP-FLOAT(IRTEMP))*HOPT(KOPT+1)
            KF=KOPT+1
C
            DO 20 I=1,KOPT
 20            IF (ABS(RTEMP).LE.ABS(HOPT(I)).AND.KF.GT.KOPT) KF=I
C
            IF (RTEMP*SNGL(DT/DABS(DT)).GT.0.0E0     .AND.
     1          WORK(M)+WORK(KOPT+2)*FLOAT(IRTEMP)+WORK(KF+1).GT.
     2                       WORK(L)     ) GO TO 40
            IF (RTEMP*SNGL(DT/DABS(DT)).LE.0.0E0     .AND.
     1          WORK(M)+WORK(KOPT+2)*FLOAT(IRTEMP).GT.
     2                       WORK(L)     ) GO TO 40
C
C ......... SIGNAL A RESTART.
C
 30         T1=T0
            GO TO 70
C
 40         IF (M.LT.MMAX) CALL ISTKRL(2)
C
C ...... DID NOT CONVERGE, TRY IT OVER AGAIN.
C
 50      T1=T0
C
C ...... FIND THE OPTIMAL DT AND M FOR THE NEXT TIME-STEP.
C
 60      IF (.NOT.LOGGED)
     1      EEQ0=D8XTRL(RS(IE2),RS(IE),NX,M,KMAX,POW,LOGLO)
C
         IF (EEQ0) CALL ISTKRL(2)
         IF (EEQ0) GO TO 140
C
         CALL D8XTRO(RS(IE2),NX,M,MMAX,KMAX,LOGN,GAMMA,F,POW,KOPT,
     1               DT,HOPT,LNWORK,COST,LOGLO,LOGHI)
C
 70      CALL ISTKRL(1)
C
C ...... IF HAVE A RESTART, SAVE THE BAD VALUE OF T AND
C ...... SET IRCNT=MRCNT. IF STEP WAS SUCCESSFUL, SAVE DT.
C
         IF (T0.EQ.T1) TBAD=T0+DT
         IF (T0.EQ.T1.AND.T0.NE.TSTART) IRCNT=MRCNT
         IF (T0.NE.T1) DTSAVE=DT
C
C ...... GET THE DT FOR THE NEXT TIME-STEP.
C
         KOPT=MIN0(KOPT,KOPTO+1)
         KOPTM=KOPT
         IF (T0.EQ.T1) KOPTM=MIN0(KOPT,KOPTO)
         DTNEW=(DT/DABS(DT))*PESPAR*
     1          AMIN1(ABS(SNGL(DT))*EXP(HUP),ABS(HOPT(KOPTM+1)))
C
C ...... TWO RESTARTS IN A ROW CAUSE DT TO DECREASE BY AT LEAST A
C ...... FACTOR OF 10**3.
C
         IF (PRSTRT .AND. T0.EQ.T1)
     1      DTNEW=(DT/DABS(DT))*DMIN1(DABS(DTNEW),DABS(DT)*1.0D-3)
         DT=DTNEW
C
         IF (T0.EQ.T1) PRSTRT=.TRUE.
C
C/6S
C        IF (T1+DT.EQ.T1) CALL SETERR
C    1      (13HDSXTRP - DT=0,13,13,1)
C/7S
         IF (T1+DT.EQ.T1) CALL SETERR
     1      ('DSXTRP - DT=0',13,13,1)
C/
         IF (T1+DT.EQ.T1) CALL ISTKRL(1)
         IF (T1+DT.EQ.T1) GO TO 140
C
         KHI=MIN0(M,KMAX+1)
C
C ...... SET THE INFORMATION IN COMMON AND COMPUTE THE
C ...... COST/UNIT TIME-STEP FOR EACH LOZENGE SIZE.
C
         KOPTC=KOPT
         KHIC=KHI
C
         DO 80 K=1,KHI
 80         COST(K)=WORK(K+1)/ABS(HOPT(K))
C
         IF (T0.EQ.TSTART.OR.T0.EQ.T1) GO TO 90
C
C ...... IF ABS(HOPT(NEW)).LT.ABS(HOPT(OLD)), BE CONSERVATIVE.
C
         IDX=MIN0(KOPT+1,MOLD-1,M-1)
         IF (DABS(DT).GT.1.0D-2*ABS(HOPT(IDX)))
     1   DT=DT*AMIN1(AMAX1(ABS(HOPT(IDX)/HOPTO(IDX)),1.0E-2),1.0E0)
C/6S
C        IF (T1+DT.EQ.T1) CALL SETERR
C    1      (13HDSXTRP - DT=0,13,13,1)
C/7S
         IF (T1+DT.EQ.T1) CALL SETERR
     1      ('DSXTRP - DT=0',13,13,1)
C/
         IF (T1+DT.EQ.T1) CALL ISTKRL(1)
         IF (T1+DT.EQ.T1) GO TO 140
C
         IF (IRCNT.LE.0) GO TO 90
C
C ...... LOGARITHMIC BISECTION FOR MRCNT STEPS AFTER A RESTART.
C
         IRCNT=IRCNT-1
         IF (IRCNT.EQ.0) HUP=0.5E0*HUP0
         TEMP=(TBAD-T1)/DTSAVE
         IF (TEMP.GT.0.99D0)
     1       DT=(DT/DABS(DT))*DMIN1(DABS(TBAD-T1)*0.5D0,DABS(DT),
     2                              DSQRT(TEMP)*DABS(DTSAVE))
C/6S
C        IF (T1+DT.EQ.T1) CALL SETERR
C    1      (13HDSXTRP - DT=0,13,13,1)
C/7S
         IF (T1+DT.EQ.T1) CALL SETERR
     1      ('DSXTRP - DT=0',13,13,1)
C/
         IF (T1+DT.EQ.T1) CALL ISTKRL(1)
         IF (T1+DT.EQ.T1) GO TO 140
C
C ...... OUTPUT THE RESULTS FOR THIS TIME-STEP.
C
 90      CALL SOUT(T0,X0,T1,X1,NX,DT,TSTOP,OK,OUTPUT,RS(IE))
C
         CALL ISTKRL(1)
C
C/6S
C        IF (T1+DT.EQ.T1) CALL SETERR
C    1      (30HDSXTRP - DT=0 RETURNED BY SOUT,30,14,1)
C/7S
         IF (T1+DT.EQ.T1) CALL SETERR
     1      ('DSXTRP - DT=0 RETURNED BY SOUT',30,14,1)
C/
         IF (T1+DT.EQ.T1) GO TO 140
C
C/6S
C        IF ((DT/DABS(DT))*(TSTOP-T1).LT.0.0D0) CALL SETERR
C    1      (47HDSXTRP - DT RETURNED BY SOUT HAS THE WRONG SIGN,47,15,2)
C/7S
         IF ((DT/DABS(DT))*(TSTOP-T1).LT.0.0D0) CALL SETERR
     1      ('DSXTRP - DT RETURNED BY SOUT HAS THE WRONG SIGN',47,15,2)
C/
C
         IF (T0.EQ.T1) KOPTO=MIN0(KOPT,KOPTO)
         IF (T0.EQ.T1) GO TO 120
C
C ...... UPDATE X0, HOPT AND HUP IF CONVERGED.
C
         DO 100 I=1,NX
 100        X0(I)=X1(I)
C
         DO 110 K=1,KHI
 110        HOPTO(K)=HOPT(K)
C
         HUP=AMIN1(2.0E0*HUP,HUPMAX)
C
         MOLD=M
         KOPTO=KOPT
         PRSTRT=.FALSE.
C
 120     IF (T1.EQ.TSTOP) GO TO 140
C
C ...... GO DO THE NEXT TIME-STEP.
C
         GO TO 10
C
C ...... THINGS ARE NOT OK.
C
 130     T1=T0
         PRSTRT=.TRUE.
C
C ...... DO NOT LET THE USER RAISE DT WHEN OK=.FALSE.
C
         TEMP=DT
C
C ...... GO INTO A FULL RESTART SEQUENCE.
C
         IF (T0.NE.TSTART) IRCNT=MRCNT
         TBAD=T0+DT
C
         CALL SOUT(T0,X0,T1,X1,NX,DT,TSTOP,OK,OUTPUT,RS(1))
C
C/6S
C        IF (T1+DT.EQ.T1) CALL SETERR
C    1      (30HDSXTRP - DT=0 RETURNED BY SOUT,30,14,1)
C/7S
         IF (T1+DT.EQ.T1) CALL SETERR
     1      ('DSXTRP - DT=0 RETURNED BY SOUT',30,14,1)
C/
         IF (T1+DT.EQ.T1) GO TO 140
C
C/6S
C        IF ((DT/DABS(DT))*(TSTOP-T1).LT.0.0D0) CALL SETERR
C    1      (47HDSXTRP - DT RETURNED BY SOUT HAS THE WRONG SIGN,47,15,2)
C/7S
         IF ((DT/DABS(DT))*(TSTOP-T1).LT.0.0D0) CALL SETERR
     1      ('DSXTRP - DT RETURNED BY SOUT HAS THE WRONG SIGN',47,15,2)
C/
C
C/6S
C        IF (DABS(TEMP).LT.DABS(DT)) CALL SETERR
C    1      (42HDSXTRP - DT RAISED BY SOUT WHEN OK=.FALSE.,42,16,2)
C/7S
         IF (DABS(TEMP).LT.DABS(DT)) CALL SETERR
     1      ('DSXTRP - DT RAISED BY SOUT WHEN OK=.FALSE.',42,16,2)
C/
C
C ...... THE DEFAULT RESPONSE IS TO LOWER DT BY 10**3.
C
         IF (DABS(DT).EQ.DABS(TEMP)) DT=DT/1.0D+3
C
C/6S
C        IF (T0+DT.EQ.T0) CALL SETERR
C    1      (13HDSXTRP - DT=0,13,13,1)
C/7S
         IF (T0+DT.EQ.T0) CALL SETERR
     1      ('DSXTRP - DT=0',13,13,1)
C/
         IF (T0+DT.EQ.T0) GO TO 140
C
         IF (T1.NE.TSTOP) GO TO 10
C
 140  RETURN
C
      END
