#include "fpreproc/library_names.h"
      program dpolft_test

      implicit NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      !-------------------------------------------------------------
      ! standard  test...

      integer ipass

      !-------------------------------------------------------------
      ! local test...

      integer, parameter :: nx=111
      integer, parameter :: mxdeg1=14   ! max polynomial degree, +1
      integer, parameter :: ntest=20001 ! no. of test evals
      integer, parameter :: nprin=1000  ! print every n'th test eval

      integer, parameter :: ndegmul=3   ! degree multiplier for rep transform

      integer :: ndeg1                  ! actual polynomial degree +1

      real*8 :: xorig(nx),forig(nx),w(nx),w2(nx)
      real*8 :: wk1(3*nx),wk2(2*mxdeg1),a(mxdeg1,mxdeg1),s(mxdeg1)
      real*8 :: xtest(ntest),fvals(ntest,0:2)
      real*8 :: f_e02adf(ntest,0:2),f_dpolft(ntest,0:2)
      real*8 :: f_chbfit(ntest,0:2),zpi
      real*8 :: zcpu(3),zcp1,zcp2,hcf(mxdeg1,0:2),hcf2(mxdeg1,0:2)

      real*8 :: hcftmp(ndegmul*mxdeg1),hcfsum1,hcfsum2,hcfsum3

      real*8 :: xmin,xmax,xbar
      real*8, parameter :: ZERO = 0.0d0
      real*8, parameter :: ONE = 1.0d0
      real*8 :: chbval,yval,deriv(2),zeps

      real*8 fdp
      external fdp

      integer i,j,iprin,ifail,ierr,ifun
      character*20 flbl

      integer, parameter :: ncomm=1000
      real*8 :: adp(ncomm)
      integer nadp,kdeg
      common/dpadp/ adp,nadp,kdeg

      !-------------------------------------------------------------
      !  initialize COMMON  --  for dp1vlu function wrapper

      if(ncomm.lt.(3*mxdeg1+3*nx)) then
         write(6,*) ' increase parameter ncomm to ',3*mxdeg1+3*nx
         call errmsg_exit('dpfitt -- fix & recompile & relink needed.')
      endif
      adp = ZERO
      nadp= ncomm
      kdeg= 0

      !-------------------------------------------------------------

      write(6,*) '=============> standard tests <============='
      call dpfitt(6,3,ipass)
      write(6,*) 'dpfitt_exec exit, ipass = ',ipass

      if(ipass.ne.1) then
         write(6,*) 'EXIT: standard tests failed.'
      endif

      !-------------------------------------------------------------

      call uinitg("DPOLFT_TEST")

      write(6,*) '=============> local tests <============='

      ndeg1 = mxdeg1

 100  continue

      write(6,1000) ndeg1-1
 1000 format(' choose function: for x in range [-pi,pi]:'/
     >   ' 1.  f(x) = arc tan(x)'/
     >   ' 2.  f(x) = sinh(x)'/
     >   ' 3.  f(x) = cosh(x)'/
     >   ' 4.  f(x) = exp(x)'/
     >   ' 5.  f(x) = x + sin(3*x)'//
     >   ' *** enter "-1" to set degree of fit, currently: ',i2/)
      ifun=0
      call ureadi(' enter function no. (btw 1 and 5), 0 to exit:$$',
     >   ifun)
      ifun=max(-1,min(5,ifun))
      if(ifun.eq.0) then
         write(6,*) ' all done.'
         call uexita(0)
         stop
      else if(ifun.eq.-1) then
         write(6,1003) mxdeg1-1
 1003    format(' max degree of fit: ',i2,'; min degree of fit: 4')
         call ureadi(' degree of fit:$$',kdeg)
         kdeg=max(4,min((mxdeg1-1),kdeg))
         ndeg1=kdeg+1
         go to 100
      endif

      !  weight profiles

      w=1
      w(1)=2
      w(2:3)=0.5_r8
      w(nx-2:nx-1)=0.5_r8
      w(nx)=2
      w2 = w*w

      ! test function:  x in [-pi,pi], f = x+sin(3*x)
      ! f' = 1 + 3*cos(3*x)  f'' = -9*sin(3*x)

      ! grid for setting up approximation:
      zpi=abs(acos(-1.0_R8))
      do i=1,nx
         xorig(i)=-zpi + (2*zpi*(i-1))/(nx-1)
         if(ifun.eq.1) then
            forig(i)=atan(xorig(i))
            flbl = '      f = arc tan(x)'
         else if(ifun.eq.2) then
            forig(i)=sinh(xorig(i))
            flbl = '         f = sinh(x)'
         else if(ifun.eq.3) then
            forig(i)=cosh(xorig(i))
            flbl = '         f = cosh(x)'
         else if(ifun.eq.4) then
            forig(i)=exp(xorig(i))
            flbl = '          f = exp(x)'
         else if(ifun.eq.5) then
            forig(i)=xorig(i) + sin(3*xorig(i))
            flbl = '     f = x + sin(3x)'
         endif
      enddo

      ! grid for testing:
      do i=1,ntest
         xtest(i)=-zpi + (2*zpi*(i-1))/(ntest-1)
         if(ifun.eq.1) then
            fvals(i,0)=atan(xtest(i))
            fvals(i,1)=ONE/(ONE+xtest(i)**2)
            fvals(i,2)=-2*xtest(i)/(ONE+xtest(i)**2)**2
         else if(ifun.eq.2) then
            fvals(i,0)=sinh(xtest(i))
            fvals(i,1)=cosh(xtest(i))
            fvals(i,2)=sinh(xtest(i))
         else if(ifun.eq.3) then
            fvals(i,0)=cosh(xtest(i))
            fvals(i,1)=sinh(xtest(i))
            fvals(i,2)=cosh(xtest(i))
         else if(ifun.eq.4) then
            fvals(i,0)=exp(xtest(i))
            fvals(i,1)=exp(xtest(i))
            fvals(i,2)=exp(xtest(i))
         else if(ifun.eq.5) then
            fvals(i,0)=xtest(i) + sin(3*xtest(i))
            fvals(i,1)=1 + 3*cos(3*xtest(i))
            fvals(i,2)= -9*sin(3*xtest(i))
         endif
      enddo

      xmin=-zpi
      xmax=zpi

      f_e02adf = 0
      f_dpolft = 0
      f_chbfit = 0

      zcpu = 0

      ifail=0
      a=0

      !  Chebyshev least squares fit
      call e02adf(nx,ndeg1,mxdeg1,xorig,forig,w,wk1,wk2,a,s,ifail)
      if(ifail.ne.0) call errmsg_exit(' ?e02adf error!')

      zeps=ZERO
      !  SLATEC least squares fit
      call dpolft(nx,xorig,forig,w2,ndeg1-1,kdeg,zeps,wk1,ierr,adp)
      write(6,*) ' %dpolft: kdeg = ',kdeg,' ndeg1 =',ndeg1,' ierr=',ierr
      if((ierr.ne.1).and.(ierr.ne.3)) then
         call errmsg_exit(' ?dpolft error!')
      endif

      hcf(1:ndeg1,0)=a(ndeg1,1:ndeg1)
      call chbder(-zpi,zpi,hcf(1:ndeg1,0),hcf(1:ndeg1,1),ndeg1-1)
      call chbder(-zpi,zpi,hcf(1:ndeg1,1),hcf(1:ndeg1,2),ndeg1-1)

      !  SLATEC -> Chebyshev convertor
      hcftmp = ZERO
      call chbfit(-zpi,zpi,hcftmp,ndegmul*ndeg1-1,fdp)

      hcf2(1:ndeg1,0)=hcftmp(1:ndeg1)
      call chbder(-zpi,zpi,hcf2(1:ndeg1,0),hcf2(1:ndeg1,1),ndeg1-1)
      call chbder(-zpi,zpi,hcf2(1:ndeg1,1),hcf2(1:ndeg1,2),ndeg1-1)

      hcfsum1=ZERO
      hcfsum2=ZERO
      hcfsum3=ZERO
      do i=1,ndeg1
         hcfsum1=hcfsum1+hcf(i,0)*hcf2(i,0)
         hcfsum2=hcfsum2+hcf(i,0)*hcf(i,0)
         hcfsum3=hcfsum3+hcf2(i,0)*hcf2(i,0)
      enddo
      if(hcfsum2.gt.ZERO) then
         write(6,*) '*** hcf comparison: ',
     >      min(hcfsum1/hcfsum2,hcfsum3/hcfsum2),
     >      max(hcfsum1/hcfsum2,hcfsum3/hcfsum2)
      endif

      !-------------------------------------------------------------
      !  function approximation evaluations

      call cptimr8(zcp1)
      do i=1,ntest
         xbar=(2*xtest(i)-xmax-xmin)/(xmax-xmin)
         xbar=max(-ONE,min(ONE,xbar))
         f_e02adf(i,0)=chbval(xbar,hcf(:,0),ndeg1-1)
         f_e02adf(i,1)=chbval(xbar,hcf(:,1),ndeg1-1)
         f_e02adf(i,2)=chbval(xbar,hcf(:,2),ndeg1-1)
      enddo
      call cptimr8(zcp2)
      zcpu(1)=zcp2-zcp1

      call cptimr8(zcp1)
      do i=1,ntest
         call dp1vlu(kdeg,2,xtest(i),yval,deriv,adp)
         f_dpolft(i,0)=yval
         f_dpolft(i,1)=deriv(1)
         f_dpolft(i,2)=deriv(2)
      enddo
      call cptimr8(zcp2)
      zcpu(2)=zcp2-zcp1

      call cptimr8(zcp1)
      do i=1,ntest
         xbar=(2*xtest(i)-xmax-xmin)/(xmax-xmin)
         xbar=max(-ONE,min(ONE,xbar))
         f_chbfit(i,0)=chbval(xbar,hcf2(:,0),ndeg1-1)
         f_chbfit(i,1)=chbval(xbar,hcf2(:,1),ndeg1-1)
         f_chbfit(i,2)=chbval(xbar,hcf2(:,2),ndeg1-1)
      enddo
      call cptimr8(zcp2)
      zcpu(3)=zcp2-zcp1

      !-------------------------------------------------------------
      !  function value results

      call fprint('function value',ntest,nprin,xtest,
     >   fvals(1:ntest,0),f_e02adf(1:ntest,0),f_dpolft(1:ntest,0),
     >   f_chbfit(1:ntest,0),zcpu)

      call r8_grafx4(xtest,fvals(1:ntest,0),f_e02adf(1:ntest,0),
     >   f_dpolft(1:ntest,0),f_chbfit(1:ntest,0),ntest,'x','f',
     >   'function values','debug plot',
     >   flbl//', f_e02adf, f_dpolft, f_chbfit')

      !-------------------------------------------------------------
      !  1st derivative results

      call fprint('1st derivative',ntest,nprin,xtest,
     >   fvals(1:ntest,1),f_e02adf(1:ntest,1),f_dpolft(1:ntest,1),
     >   f_chbfit(1:ntest,1),zcpu)

      call r8_grafx4(xtest,fvals(1:ntest,1),f_e02adf(1:ntest,1),
     >   f_dpolft(1:ntest,1),f_chbfit(1:ntest,1),ntest,'x','df/dx',
     >   '1st derivative','debug plot',
     >   flbl//', f_e02adf, f_dpolft, f_chbfit')

      !-------------------------------------------------------------
      !  2nd derivative results

      call fprint('2nd derivative',ntest,nprin,xtest,
     >   fvals(1:ntest,2),f_e02adf(1:ntest,2),f_dpolft(1:ntest,2),
     >   f_chbfit(1:ntest,2),zcpu)

      call r8_grafx4(xtest,fvals(1:ntest,2),f_e02adf(1:ntest,2),
     >   f_dpolft(1:ntest,2),f_chbfit(1:ntest,2),ntest,'x','d2f/dx2',
     >   '2nd derivative','debug plot',
     >   flbl//', f_e02adf, f_dpolft, f_chbfit')

      !-------------------------------------------------------------
      go to 100

      end
 
      !-------------------------------------------------------------
      subroutine fprint(label,ntest,nprin,x,f,fa1,fa2,fa3,zcpu)

      implicit NONE

      character*(*), intent(in) :: label
      integer, intent(in) :: ntest,nprin
      real*8, intent(in) :: x(ntest),f(ntest)
      real*8, intent(in) :: fa1(ntest),fa2(ntest),fa3(ntest),zcpu(3)

      integer i
      real*8, parameter :: ZERO = 0.0d0
      real*8 :: fabsmax,fadiff(3),fbdiff
      
      !  printout

      fabsmax=maxval(abs(f))

      write(6,*) ' ----------------------- '
      write(6,*) ' => ',label
      write(6,*) ' '
      write(6,*) ' x              f(x)           f_e02adf       ',
     >   'f_dpolft       f_chbfit'
      write(6,*) ' '
      do i = 1,ntest,nprin
cxx         write(6,1001) x(i),f(i),fa1(i),fa2(i),fa3(i)
         write(6,1001) x(i),f(i),fa1(i),fa2(i),fa3(i)
      enddo
      write(6,*) ' '
      write(6,*) ' normalized maximum deviation (fine grid test): '
      fadiff = ZERO
      fbdiff = ZERO
      do i=1,ntest
         fadiff(1)=max(fadiff(1),abs(f(i)-fa1(i)))
         fadiff(2)=max(fadiff(2),abs(f(i)-fa2(i)))
         fadiff(3)=max(fadiff(3),abs(f(i)-fa3(i)))
         fbdiff   =max(fbdiff,abs(fa1(i)-fa3(i)))
      enddo
      fadiff = fadiff/fabsmax
      write(6,1001) ZERO,ZERO,fadiff(1:3)
cxx      write(6,*) ' cpu time: '
cxx      write(6,1001) ZERO,ZERO,zcpu(1:3)
      write(6,1002) 'f_e02adf-f_chbfit max deviation:',fbdiff
      write(6,*) ' '
 1001 format(5(1x,1pe14.7))
 1002 format(1x,a,1x,1pe14.7)

      return
      end
      !-------------------------------------------------------------

      real*8 function fdp(x)

      implicit NONE
      real*8, intent(in) :: x           ! input argument

      !  COMMON from main prog

      integer, parameter :: ncomm=1000
      real*8 :: adp(ncomm)
      integer nadp,kdeg
      common/dpadp/ adp,nadp,kdeg

      !  LOCAL

      real*8 dummy(2),y

      call dp1vlu(kdeg,0,x,y,dummy,adp)

      fdp = y

      return
      end

      !-------------------------------------------------------------

*DECK DPFITT
      SUBROUTINE DPFITT (LUN, KPRINT, IPASS)
C***BEGIN PROLOGUE  DPFITT
C***PURPOSE  Quick check for DPOLFT, DPCOEF and DP1VLU.
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (PFITQX-S, DPFITT-D)
C***AUTHOR  (UNKNOWN)
C***ROUTINES CALLED  D1MACH, DCMPAR, DP1VLU, DPCOEF, DPOLFT, PASS,
C                    XERCLR, XGETF, XSETF
C***COMMON BLOCKS    DCHECK
C***REVISION HISTORY  (YYMMDD)
C   ??????  DATE WRITTEN
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890921  Realigned order of variables in the COMMON block.
C           (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900911  Test problem changed and cosmetic changes to code.  (WRB)
C   901205  Changed usage of D1MACH(3) to D1MACH(4) and modified the
C           FORMATs.  (RWC)
C   910708  Minor modifications in use of KPRINT.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900911  Test problem changed and cosmetic changes to code.  (WRB)
C   920214  Code restructured to test for all values of KPRINT and to
C           provide more PASS/FAIL information.  (WRB)
C***END PROLOGUE  DPFITT
C     .. Scalar Arguments ..
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER kontrl
!============
      INTEGER IPASS, KPRINT, LUN
C     .. Scalars in Common ..
      REAL*8 EPS, RP, SVEPS, TOL
      INTEGER IERP, IERR, NORD, NORDP
C     .. Arrays in Common ..
      REAL*8 R(11)
C     .. Local Scalars ..
      REAL*8 YFIT
      INTEGER I, ICNT, M, MAXORD
C     .. Local Arrays ..
      REAL*8 A(97), TC(5), W(11), X(11), Y(11), YP(5)
      INTEGER ITEST(9)
C     .. External Functions ..
      REAL*8 D1MACH
      EXTERNAL D1MACH
C     .. External Subroutines ..
      EXTERNAL DCMPAR, PASS, DPCOEF, DPOLFT, DP1VLU
C     .. Intrinsic Functions ..
      INTRINSIC ABS, SQRT
C     .. Common blocks ..
      COMMON /DCHECK/ EPS, R, RP, SVEPS, TOL, NORDP, NORD, IERP, IERR
C***FIRST EXECUTABLE STATEMENT  DPFITT
      IF (KPRINT .GE. 2) WRITE (LUN,FMT=9000)
C
C     Initialize variables for testing passage or failure of tests
C
      DO 100 I = 1,9
        ITEST(I) = 0
  100 CONTINUE
      ICNT = 0
      TOL = SQRT(D1MACH(4))
      M = 11
      DO 110 I = 1,M
        X(I) = I - 6
        Y(I) = X(I)**4
  110 CONTINUE
C
C     Test DPOLFT
C     Input EPS is negative - specified level
C
      W(1) = -1.0_R8
      EPS = -0.01_R8
      SVEPS = EPS
      MAXORD = 8
      NORDP = 4
      RP = 625.0_R8
      IERP = 1
      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
C
C     See if test passed
C
      CALL DCMPAR (ICNT, ITEST)
C
C     Check for suppression of printing.
C
      IF (KPRINT .EQ. 0) GO TO 130
      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 130
      WRITE (LUN,FMT=9010)
      WRITE (LUN,FMT=9020)
      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 120
      WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP
      WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR
C
C     Send message indicating passage or failure of test
C
  120 CALL PASS (LUN, ICNT, ITEST(ICNT))
C
C     Input EPS is negative - computed level
C
  130 EPS = -1.0_R8
      SVEPS = EPS
      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
C
C     See if test passed
C
      CALL DCMPAR (ICNT, ITEST)
C
C     Check for suppression of printing.
C
      IF (KPRINT .EQ. 0) GO TO 150
      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 150
      WRITE (LUN,FMT=9050)
      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 140
      WRITE (LUN,FMT=9060) MAXORD
      WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP
      WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR
C
C     Send message indicating passage or failure of test
C
  140 CALL PASS (LUN, ICNT, ITEST(ICNT))
C
C     Input EPS is zero
C
  150 W(1) = -1.0_R8
      EPS = 0.0_R8
      SVEPS = EPS
      NORDP = 5
      MAXORD = 5
      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
C
C     See if test passed
C
      CALL DCMPAR (ICNT, ITEST)
C
C     Check for suppression of printing.
C
      IF (KPRINT .EQ. 0) GO TO 170
      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 170
      WRITE (LUN,FMT=9070)
      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 160
      WRITE (LUN,FMT=9060) MAXORD
      WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP
      WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR
C
C     Send message indicating passage or failure of test
C
  160 CALL PASS (LUN, ICNT, ITEST(ICNT))
C
C     Input EPS is positive
C
  170 IERP = 1
      NORDP = 4
      EPS = 75.0_R8*D1MACH(4)
      SVEPS = EPS
      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
C
C     See if test passed
C
      CALL DCMPAR (ICNT, ITEST)
C
C     Check for suppression of printing.
C
      IF (KPRINT .EQ. 0) GO TO 190
      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 190
      WRITE (LUN,FMT=9080)
      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 180
      WRITE (LUN,FMT=9060) MAXORD
      WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP
      WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR
C
C     Send message indicating passage or failure of test
C
  180 CALL PASS (LUN, ICNT, ITEST(ICNT))
C
C     Improper input
C
  190 IERP = 2
      M = -2
C
C     Check for suppression of printing.
C
      CALL XGETF (KONTRL)
      IF (KPRINT .LE. 2) THEN
         CALL XSETF (0)
      ELSE
         CALL XSETF (1)
      ENDIF
      CALL XERCLR
C
cxx      IF (KPRINT .GE. 3) WRITE (LUN,9090)
cxx      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
C
C     See if test passed
C
      ICNT = ICNT + 1
      ITEST(ICNT) = 1                   ! skip "invalid" test, avoid scary msg
cxx      IF (IERR .EQ. 2) THEN
cxx        ITEST(ICNT) = 1
cxx        IF (KPRINT .GE. 3) THEN
cxx          WRITE (LUN, 9100) 'PASSED', IERR
cxx        ENDIF
cxx      ELSE
cxx        IF (KPRINT .GE. 2) THEN
cxx          WRITE (LUN, 9100) 'FAILED', IERR
cxx        ENDIF
cxx      ENDIF
C
C     Check for suppression of printing.
C
      IF (KPRINT .EQ. 0) GO TO 210
      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 210
      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 200
C
C     Send message indicating passage or failure of test
C
  200 CALL PASS (LUN, ICNT, ITEST(ICNT))
C
      CALL XERCLR
      CALL XSETF (KONTRL)
C
C     MAXORD too small to meet RMS error
C
  210 M = 11
      W(1) = -1.0_R8
      EPS = 5.0_R8*D1MACH(4)
      SVEPS = EPS
      RP = 553.0_R8
      MAXORD = 2
      IERP = 3
      NORDP = 2
      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
C
C     See if test passed
C
      CALL DCMPAR (ICNT, ITEST)
C
C     Check for suppression of printing.
C
      IF (KPRINT .EQ. 0) GO TO 230
      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 230
      WRITE (LUN,FMT=9110)
      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 220
      WRITE (LUN,FMT=9060) MAXORD
      WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP
      WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR
C
C     Send message indicating passage or failure of test
C
  220 CALL PASS (LUN, ICNT, ITEST(ICNT))
C
C     MAXORD too small to meet statistical test
C
  230 NORDP = 4
      IERP = 4
      RP = 625.0_R8
      EPS = -0.01_R8
      SVEPS = EPS
      MAXORD = 5
      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
C
C     See if test passed
C
      CALL DCMPAR (ICNT, ITEST)
C
C     Check for suppression of printing.
C
      IF (KPRINT .EQ. 0) GO TO 250
      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 250
      WRITE (LUN,FMT=9120)
      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 240
      WRITE (LUN,FMT=9060) MAXORD
      WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP
      WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR
C
C     Send message indicating passage or failure of test
C
  240 CALL PASS (LUN, ICNT, ITEST(ICNT))
C
C     Test DPCOEF
C
  250 MAXORD = 6
      EPS = 0.0_R8
      SVEPS = EPS
      Y(6) = 1.0_R8
      DO 260 I = 1,M
        W(I) = 1.0_R8/(Y(I)**2)
  260 CONTINUE
      Y(6) = 0.0_R8
      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
      CALL DPCOEF (4, 5.0_R8, TC, A)
C
C     See if test passed
C
      ICNT = ICNT + 1
      IF (ABS(R(11)-TC(1)) .LE. TOL) ITEST(ICNT) = 1
C
C     Check for suppression of printing
C
      IF (KPRINT .EQ. 0) GO TO 280
      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 280
      WRITE (LUN,FMT=9130)
      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 270
      WRITE (LUN,FMT=9140) R(11),TC(1)
C
C     Send message indicating passage or failure of test
C
  270 CALL PASS (LUN, ICNT, ITEST(ICNT))
C
C     Test DP1VLU
C     Normal call
C
  280 CALL DP1VLU (6, 0, X(8), YFIT, YP, A)
C
C     See if test passed
C
      ICNT = ICNT + 1
      IF (ABS(R(8)-YFIT) .LE. TOL) ITEST(ICNT) = 1
C
C     Check for suppression of printing
C
      IF (KPRINT .EQ. 0) GO TO 300
      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 300
      WRITE (LUN,FMT=9150)
      WRITE (LUN,FMT=9160)
      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 290
      WRITE (LUN,FMT=9170) X(8),R(8),YFIT
C
C     Send message indicating passage or failure of test
C
  290 CALL PASS (LUN, ICNT, ITEST(ICNT))
C
C     Check to see if all tests passed
C
  300 IPASS = 1
      DO 310 I = 1,9
        IPASS = IPASS*ITEST(I)
  310 CONTINUE
C
      IF (IPASS.EQ.1 .AND. KPRINT.GE.3) WRITE (LUN,FMT=9180)
      IF (IPASS.EQ.0 .AND. KPRINT.GE.2) WRITE (LUN,FMT=9190)
      RETURN
C
 9000 FORMAT ('1' / ' Test DPOLFT, DPCOEF and DP1VLU')
 9010 FORMAT (' Exercise DPOLFT')
 9020 FORMAT (' Input EPS is negative - specified significance level')
 9030 FORMAT (' Input EPS =  ', E15.8, '   correct order =  ', I3,
     +        '   R(1) = ', E15.8, '   IERR = ', I1)
 9040 FORMAT (' Output EPS = ', E15.8, '   computed order = ', I3,
     +        '   R(1) = ', E15.8, '   IERR = ', I1)
 9050 FORMAT (/ ' Input EPS is negative - computed significance level')
 9060 FORMAT (' Maximum order = ', I2)
 9070 FORMAT (/ ' Input EPS is zero')
 9080 FORMAT (/ ' Input EPS is positive')
 9090 FORMAT (/ ' Invalid input')
 9100 FORMAT (' DPOLFT incorrect argument test ', A /
     +        ' IERR should be 2.  It is ', I4)
 9110 FORMAT (/ ' Cannot meet RMS error requirement')
 9120 FORMAT (/ ' Cannot satisfy statistical test')
 9130 FORMAT (/ ' Exercise DPCOEF')
 9140 FORMAT (/ ' For C=1.0, correct coefficient = ', E15.8,
     +        '   computed = ', E15.8)
 9150 FORMAT (/ ' Exercise DP1VLU')
 9160 FORMAT (' Normal execution')
 9170 FORMAT (' For X = ', F5.2, '   correct P(X) = ', E15.8,
     +        '    P(X) from DP1VLU = ', E15.8)
 9180 FORMAT (/' ***************DPOLFT PASSED ALL TESTS***************')
 9190 FORMAT (/' ***************DPOLFT FAILED SOME TESTS**************')
      END
