      subroutine ADAM(Y,YP,WT,YY,PHI,FOURU)
        common/ADDATA/ T,TOUT,RELERR,ABSERR,DTSGN,NEQN,IFLAG,
     &                IOLD,KLE4,INIT,KOP
        common/STDATA/ X,H,HOLD,EPS,RVAR(86),NEQ,KOLD,ICRASH,K,
     &                NFE,NS,NORND,PHASE1,START
      double precision ABSDT,ABSEPS,ABSERR,
     &                 DT,DTSGN,EPS,H,HOLD,
     &                 PHI,RELEPS,RELERR,RVAR,T,TEND,TOUT,
     &                 WT,X,Y,YP,YY
        double precision FOURU
        integer IFLAG,INIT,IOLD,KOP,L,MAXNFE,MFLAG,NEQ,NEQN,NFE
        integer ICRASH,K,KLE4,KOLD,NS
        logical NORND,PHASE1,START
        dimension Y(NEQN),YP(NEQN),YY(NEQN),WT(NEQN),PHI(NEQN,16)
      data MAXNFE/1000/
      MFLAG = iabs(IFLAG)
      if ((MFLAG.gt.7).or.(MFLAG.eq.0).or.(NEQN.lt.1)) go to 180
      if ((RELERR.lt.0.0).or.(ABSERR.lt.0.0)) go to 180
      EPS = dmax1(RELERR,ABSERR)
      if (EPS.le.0.0) go to 180
      NEQ = NEQN
      DT = TOUT-T
      ABSDT = dabs(DT)
      TEND = T+10.*DT
      if (IFLAG.lt.0) TEND = TOUT
      RELEPS = RELERR/EPS
      ABSEPS = ABSERR/EPS
      if (MFLAG.eq.1) go to 140
      if (T.eq.TOUT) go to 180
      if (INIT.eq.0) go to 170
      if (IOLD.lt.0) go to 150
      if (DTSGN*DT.lt.0.0) go to 150
100   continue
      if (dabs(X-T).lt.ABSDT) go to 110
      call SINTRP (TOUT,Y,YP,YY,PHI)
      IOLD = IFLAG
      IFLAG = 2
      T = TOUT
      return
110   continue
      if ((IFLAG.lt.0).and.(dabs(TOUT-X).lt.FOURU*dabs(X))) go to 190
      if (NFE.gt.MAXNFE) go to 210
      if (dabs(H).lt.dabs(TEND-X)) go to 120
      KOP = KOP+1
      if (KOP.gt.50) go to 240
      H = TEND-X
120   continue
      do 130 L = 1, NEQN
         WT(L) = RELEPS*dabs(YY(L))+ABSEPS
         if (WT(L).eq.0.0) go to 230
130   continue
      call STEP (YY,YP,WT,PHI,Y,FOURU)
      if (ICRASH.ne.0) go to 220
      if (KLE4.ge.50) go to 100
      KLE4 = KLE4+1
      if (KOLD.gt.4) KLE4 = 0
      go to 100
140   continue
      NFE = 0
150   continue
      START = .true.
      KLE4 = 0
      INIT = 0
      KOP = 0
      X = T
      do 160 L = 1, NEQN
         YY(L) = Y(L)
160   continue
      if (T.ne.TOUT) go to 170
      call FCT (X,YY,YP)
      NFE = NFE+1
      IFLAG = 2
      return
170   continue
      INIT = 1
      DTSGN = DT
      H = dsign(dmax1(dabs(TOUT-X),FOURU*dabs(X)),TOUT-X)
      go to 100
180   continue
      IFLAG = 9
      return
190   continue
      H = TOUT-X
      call FCT (X,YY,YP)
      NFE = NFE+1
      do 200 L = 1, NEQN
         Y(L) = YY(L)+H*YP(L)
200   continue
      IFLAG = 2
      T = TOUT
      call FCT (T,Y,YP)
      NFE = NFE+1
      IOLD = -1
      return
210   continue
      IFLAG = isign(5,IFLAG)
      if (KLE4.ge.50) IFLAG = isign(6,IFLAG)
      NFE = NFE-MAXNFE
      KLE4 = 0
      go to 250
220   continue
      IFLAG = isign(4,IFLAG)
      if (ICRASH.eq.2) IFLAG = isign(3,IFLAG)
      RELERR = EPS*RELEPS
      ABSERR = EPS*ABSEPS
      go to 250
230   continue
      IFLAG = 8
      go to 250
240   continue
      KOP = 0
      IFLAG = isign(7,IFLAG)
250   continue
      T = X
      IOLD = -1
      do 260 L = 1, NEQN
         Y(L) = YY(L)
         YP(L) = PHI(L,1)
260   continue
      return
      end
