*DECK QXDABM
      SUBROUTINE QXDABM (LUN, KPRINT, IPASS)
C***BEGIN PROLOGUE  QXDABM
C***PURPOSE  Test the DEPAC routine DDEABM.
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (QXABM-S, QXDABM-D)
C***KEYWORDS  QUICK CHECK
C***AUTHOR  Chow, Jeff, (LANL)
C***DESCRIPTION
C
C *Usage:
C
C        INTEGER  LUN, KPRINT, IPASS
C
C        CALL QXDABM (LUN, KPRINT, IPASS)
C
C *Arguments:
C
C     LUN   :IN  is the unit number to which output is to be written.
C
C     KPRINT:IN  controls the amount of output, as specified in the
C                SLATEC Guidelines.
C
C     IPASS:OUT  will contain a pass/fail flag.  IPASS=1 is good.
C                IPASS=0 indicates one or more tests failed.
C
C *Description:
C
C   DDEABM is tested by solving the equations of motion of a body
C   moving in a plane about a spherical earth, namely
C           (D/DT)(D/DT)X = -G*X/R**3
C           (D/DT)(D/DT)Y = -G*Y/R**3
C   where G = 1, R = SQRT(X**2 + Y**2) and
C           X(0) = 1
C           (D/DT)X(0) = 0
C           Y(0) = 0
C           (D/DT)Y(0) = 1.
C
C***ROUTINES CALLED  D1MACH, DDEABM, DFDEQC
C***REVISION HISTORY  (YYMMDD)
C   810801  DATE WRITTEN
C   890618  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900415  Code extensively revised.  (WRB)
C***END PROLOGUE  QXDABM
C
C     Declare arguments.
C
      INTEGER  LUN, KPRINT, IPASS
C
C     Declare local variables.
C
      INTEGER  IDID, INFO(15), IPAR, IWORK(51), N, LIW, LRW, NSTEP
      DOUBLE PRECISION ABSERR, D1MACH, R, RELERR, RELTOL, RPAR,
     +                 RWORK(214), T, TOUT, U(4)
      EXTERNAL DFDEQC
C***FIRST EXECUTABLE STATEMENT  QXDABM
      IF (KPRINT .GE. 2)  WRITE (LUN, 9000)
C
C     Initialize problem.
C
      N = 4
      LRW = 214
      LIW = 51
      T = 0.0D0
      TOUT = 8.0D0*ATAN(1.0D0)
      U(1) = 1.0D0
      U(2) = 0.0D0
      U(3) = 0.0D0
      U(4) = 1.0D0
      IPASS = 1
      NSTEP = 0
      RELTOL = SQRT(D1MACH(4))
      RELERR = 0.1D0*RELTOL
      ABSERR = RELERR**1.5D0
      INFO(1) = 0
      INFO(2) = 0
      INFO(3) = 1
      INFO(4) = 0
      IF (KPRINT .GT. 2) WRITE (LUN, 9010) RELERR, ABSERR, T, (1.0D0)
C
  100 CALL DDEABM (DFDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR,
     +             IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR)
      R = SQRT(U(1)*U(1)+U(2)*U(2))
      IF (ABS(R-1.0D0) .GT. RELTOL) IPASS = 0
      IF (KPRINT .GT. 2) WRITE (LUN, 9020) T, R
      INFO(1) = 1
      IF (IDID .EQ. 1) GO TO 100
C
C     For the double precision version, we allow the integrator to take
C     up to 2000 steps before we declare failure.
C
      IF (IDID .EQ. -1) THEN
         NSTEP = NSTEP + 500
         IF (NSTEP .LT. 2000) GOTO 100
      ENDIF
C
C     Finish up.
C
      IF (IDID .LT. 1) IPASS = 0
      IF (KPRINT.GT.1 .AND. IDID.LT.1)  WRITE (LUN, 9030) IDID
      IF (KPRINT.GT.1 .AND. IPASS.EQ.1) WRITE (LUN, 9040)
      IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN, 9050)
      RETURN
C
C     FORMATs.
C
 9000 FORMAT ('1'/' ------------  DDEABM QUICK CHECK OUTPUT',
     +        ' ------------')
 9010 FORMAT (/ ' RELERR = ', D16.8, '   ABSERR =', D16.8 /
     +        12X, 'T', 19X, 'R' / 2D20.8)
 9020 FORMAT (2D20.8)
 9030 FORMAT (1X, 'ERROR RETURN FROM DDEABM.  IDID = ', I3)
 9040 FORMAT (/ ' ------------  DDEABM PASSED TESTS  ------------')
 9050 FORMAT (/ ' ************  DDEABM FAILED TESTS  ************')
      END
