*DECK PCHQK2
      SUBROUTINE PCHQK2 (LUN, KPRINT, IPASS)
C***BEGIN PROLOGUE  PCHQK2
C***PURPOSE  Test the PCHIP integrators PCHIA and PCHID.
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      SINGLE PRECISION (PCHQK2-S, DPCHQ2-D)
C***KEYWORDS  PCHIP INTEGRATOR QUICK CHECK
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C              PCHIP QUICK CHECK NUMBER 2
C
C     TESTS THE INTEGRATORS:  PCHIA, PCHID.
C *Usage:
C
C        INTEGER  LUN, KPRINT, IPASS
C
C        CALL PCHQK2 (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   This routine constructs data from a cubic, integrates it with PCHIA
C   and compares the results with the correct answer.
C   Since PCHIA calls PCHID, this tests both integrators.
C
C***ROUTINES CALLED  PCHIA, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   890306  Changed IPASS to the more accurate name IFAIL.  (FNF)
C   890316  Added declarations as in DPCHQ2.  (FNF)
C   890629  Appended E0 to real constants to reduce S.P./D.P.
C           differences.
C   890706  Cosmetic changes to prologue.  (WRB)
C   891004  Cosmetic changes to prologue.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900314  Improved some output formats.  (FNF)
C   900315  Revised prologue and improved some output formats.  (FNF)
C   900316  Additional minor cosmetic changes.  (FNF)
C   900321  Removed IFAIL from call sequence for SLATEC standards and
C           made miscellaneous cosmetic changes.  (FNF)
C   901130  Added 1P's to formats; changed to allow KPRINT.gt.3.  (FNF)
C   910708  Minor modifications in use of KPRINT.  (WRB)
C   930317  Improved output formats.  (FNF)
C***END PROLOGUE  PCHQK2
C
C  Declare arguments.
C
      INTEGER  LUN, KPRINT, IPASS
C
C  DECLARE VARIABLES.
C
      INTEGER  I, IEREXP(17), IERR, IFAIL, N, NPAIRS
      REAL  A(17), B(17), CALC, D(7), ERRMAX, ERROR, F(7), MACHEP,
     *      ONE, THREE, THRQTR, TOL, TRUE, TWO, X(7)
      LOGICAL  FAIL, SKIP
C
C  DECLARE EXTERNALS.
C
      REAL  PCHIA, R1MACH
C
C  DEFINE TEST FUNCTIONS.
C
      REAL  AX, FCN, DERIV, ANTDER
      FCN(AX) = THREE*AX*AX*(AX-TWO)
      DERIV(AX) = THREE*AX*(TWO*(AX-TWO) + AX)
      ANTDER(AX) = AX**3 * (THRQTR*AX - TWO)
C
C  INITIALIZE.
C
      DATA  THRQTR /0.75E0/,  ONE /1.E0/,  TWO /2.E0/,  THREE /3.E0/
      DATA  N /7/
      DATA  X /-4.E0, -2.E0, -0.9E0, 0.E0, 0.9E0, 2.E0, 4.E0/
      DATA  NPAIRS /17/
      DATA  A /-3.0E0, 3.0E0,-0.5E0,-0.5E0,-0.5E0,-4.0E0,-4.0E0, 3.0E0,
     *  -5.0E0,-5.0E0,-6.0E0, 6.0E0,-1.5E0,-1.5E0,-3.0E0, 3.0E0, 0.5E0/
      DATA  B / 3.0E0,-3.0E0, 1.0E0, 2.0E0, 5.0E0,-0.5E0, 4.0E0, 5.0E0,
     *  -3.0E0, 5.0E0,-5.0E0, 5.0E0,-0.5E0,-1.0E0,-2.5E0, 3.5E0, 0.5E0/
      DATA  IEREXP /0,0,0,0,2,0,0,2,1,3,3,3,0,0,0,0,0/
C
C  SET PASS/FAIL TOLERANCE.
C
C***FIRST EXECUTABLE STATEMENT  PCHQK2
      MACHEP = R1MACH(4)
      TOL = 100.E0*MACHEP
C
C  SET UP PCH FUNCTION DEFINITION.
C
      DO 10  I = 1, N
         F(I) =   FCN(X(I))
         D(I) = DERIV(X(I))
   10 CONTINUE
C
      IF (KPRINT .GE. 3)  WRITE (LUN, 1000)
      IF (KPRINT .GE. 2)  WRITE (LUN, 1001)
      IF (KPRINT .GE. 3)  WRITE (LUN, 1002)  (X(I), F(I), D(I), I=1,N)
C
C  LOOP OVER (A,B)-PAIRS.
C
      IF (KPRINT .GE. 3)  WRITE (LUN, 2000)
C
      IFAIL = 0
C
      SKIP = .FALSE.
      DO 20  I = 1, NPAIRS
C               ---------------------------------------------
         CALC = PCHIA (N, X, F, D, 1, SKIP, A(I), B(I), IERR)
C               ---------------------------------------------
         IF (IERR .GE. 0)  THEN
            FAIL = IERR .NE. IEREXP(I)
            TRUE = ANTDER(B(I)) - ANTDER(A(I))
            ERROR = CALC - TRUE
            IF (KPRINT .GE. 3)  THEN
               IF (FAIL)  THEN
                 WRITE (LUN, 2001) A(I), B(I), IERR, TRUE, CALC, ERROR,
     *                                          IEREXP(I)
               ELSE
                 WRITE (LUN, 2002) A(I), B(I), IERR, TRUE, CALC, ERROR
               ENDIF
            ENDIF
C
            ERROR = ABS(ERROR) / MAX(ONE, ABS(TRUE))
            IF (FAIL .OR. (ERROR.GT.TOL))  IFAIL = IFAIL + 1
            IF (I .EQ. 1)  THEN
               ERRMAX = ERROR
            ELSE
               ERRMAX = MAX(ERRMAX, ERROR)
            ENDIF
         ELSE
            IF (KPRINT .GE. 3)  WRITE (LUN, 2002)  A(I), B(I), IERR
            IFAIL = IFAIL + 1
         ENDIF
   20 CONTINUE
C
C  PRINT SUMMARY.
C
      IF (KPRINT .GE. 2)  THEN
         WRITE (LUN, 2003)  ERRMAX, TOL
         IF (IFAIL .NE. 0)  WRITE (LUN, 3001)  IFAIL
      ENDIF
C
C  TERMINATE.
C
      IF (IFAIL.EQ.0)  THEN
         IPASS = 1
         IF (KPRINT.GE.2) WRITE(LUN,99998)
      ELSE
         IPASS = 0
         IF (KPRINT.GE.1) WRITE(LUN,99999)
      ENDIF
C
      RETURN
C
C  FORMATS.
C
 1000 FORMAT ('1'//10X,'TEST PCHIP INTEGRATORS')
 1001 FORMAT (//10X,'PCHQK2 RESULTS'/10X,'--------------')
 1002 FORMAT (// 5X,'DATA:' //11X,'X',9X,'F',9X,'D' /(5X,3F10.3) )
 2000 FORMAT (// 5X,'TEST RESULTS:'
     *        //'    A     B    ERR     TRUE',16X,'CALC',15X,'ERROR')
 2001 FORMAT (2F6.1,I5,1P,2E20.10,E15.5,'  (',I1,') *****' )
 2002 FORMAT (2F6.1,I5,1P,2E20.10,E15.5)
 2003 FORMAT (/'  MAXIMUM RELATIVE ERROR IS:',1P,E15.5,
     *                       ',   TOLERANCE:',1P,E15.5)
 3001 FORMAT (/' *** TROUBLE ***',I5,' INTEGRATION TESTS FAILED.')
99998 FORMAT (/' ------------  PCHIP PASSED  ALL INTEGRATION TESTS',
     *        ' ------------')
99999 FORMAT (/' ************  PCHIP FAILED SOME INTEGRATION TESTS',
     *        ' ************')
C------------- LAST LINE OF PCHQK2 FOLLOWS -----------------------------
      END