*DECK PCHQK5
      SUBROUTINE PCHQK5 (LUN, KPRINT, IPASS)
C***BEGIN PROLOGUE  PCHQK5
C***PURPOSE  Test the PCH to B-spline conversion routine PCHBS.
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      SINGLE PRECISION (PCHQK5-S, DPCHQ5-D)
C***KEYWORDS  PCHIP CONVERSION ROUTINE QUICK CHECK
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C              PCHIP QUICK CHECK NUMBER 5
C
C     TESTS THE CONVERSION ROUTINE:  PCHBS.
C *Usage:
C
C        INTEGER  LUN, KPRINT, IPASS
C
C        CALL PCHQK5 (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 tests a constructed data set with four different
C   KNOTYP settings.  It computes the function and derivatives of the
C   resulting B-representation via BVALU and compares with PCH data.
C
C *Caution:
C   This routine assumes BVALU has already been successfully tested.
C
C***ROUTINES CALLED  BVALU, PCHBS, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   900411  DATE WRITTEN
C   900412  Corrected minor errors in initial implementation.
C   900430  Corrected errors in prologue.
C   900501  Corrected declarations.
C   930317  Improved output formats.  (FNF)
C***END PROLOGUE  PCHQK5
C
C*Internal Notes:
C  TOL  is the tolerance to use for quantities that should only
C       theoretically be equal.
C  TOLZ is the tolerance to use for quantities that should be exactly
C       equal.
C
C**End
C
C  Declare arguments.
C
      INTEGER  LUN, KPRINT, IPASS
C
C  Declare externals.
C
      REAL  BVALU, R1MACH
      EXTERNAL  BVALU, PCHBS, R1MACH
C
C  Declare variables.
C
      INTEGER  I, IERR, IFAIL, INBV, J, KNOTYP, K, N, NDIM, NKNOTS
      PARAMETER  (N = 9)
      REAL  BCOEF(2*N), D(N), DCALC, DERR, DERMAX, F(N), FCALC, FERR,
     *      FERMAX, T(2*N+4), TERR, TERMAX, TOL, TOLZ, TSAVE(2*N+4),
     *      WORK(16*N), X(N), ZERO
      PARAMETER  (ZERO = 0.0E0)
      LOGICAL  FAIL
C
C  Define relative error function.
C
      REAL  ANS, ERR, RELERR
      RELERR (ERR, ANS) = ABS(ERR) / MAX(1.0E-5,ABS(ANS))
C
C  Define test data.
C
      DATA  X /-2.2E0,   -1.2E0,   -1.0E0,   -0.5E0,   -0.01E0,
     *          0.5E0,    1.0E0,    2.0E0,    2.2E0/
      DATA  F / 0.0079E0, 0.2369E0, 0.3679E0, 0.7788E0, 0.9999E0,
     *          0.7788E0, 0.3679E0, 0.1083E0, 0.0079E0/
      DATA  D / 0.0000E0, 0.3800E0, 0.7173E0, 0.5820E0, 0.0177E0,
     *         -0.5696E0,-0.5135E0,-0.0778E0,-0.0025E0/
C
C  Initialize.
C
C***FIRST EXECUTABLE STATEMENT  PCHQK5
      IFAIL = 0
      TOL = 100*R1MACH(4)
      TOLZ = ZERO
C
      IF (KPRINT.GE.3)  WRITE (LUN, 1000)
      IF (KPRINT.GE.2)  WRITE (LUN, 1001)
C
C  Loop over a series of values of KNOTYP.
C
      IF (KPRINT.GE.3)  WRITE (LUN, 1010)
      DO 300  KNOTYP = 2, -1, -1
C        ------------
         CALL PCHBS (N, X, F, D, 1, KNOTYP, NKNOTS, T, BCOEF, NDIM, K,
     *               IERR)
C        ------------
         IF (KPRINT.GE.3)
     *       WRITE (LUN, 2000) KNOTYP, NKNOTS, NDIM, K, IERR
         IF ( IERR.NE.0 )  THEN
            IFAIL = IFAIL + 1
            IF (KPRINT.GE.3)  WRITE (LUN, 2001)
         ELSE
C             Compare evaluated results with inputs to PCHBS.
            INBV = 1
            FERMAX = ZERO
            DERMAX = ZERO
            IF (KPRINT.GE.3)  THEN
               WRITE (LUN, 2002)
               WRITE (LUN, 2003)  T(1), T(2)
               J = 1
            ENDIF
            DO 100  I = 1, N
               FCALC = BVALU (T, BCOEF, NDIM, K, 0, X(I), INBV, WORK)
               FERR = F(I) - FCALC
               FERMAX = MAX(FERMAX, RELERR(FERR,F(I)) )
               DCALC = BVALU (T, BCOEF, NDIM, K, 1, X(I), INBV, WORK)
               DERR = D(I) - DCALC
               DERMAX = MAX(DERMAX, RELERR(DERR,D(I)) )
               IF (KPRINT.GE.3)  THEN
                  J = J + 2
                  WRITE (LUN, 2004)  X(I), T(J), T(J+1), F(I), FERR,
     *                                                   D(I), DERR
               ENDIF
  100       CONTINUE
            IF (KPRINT.GE.3)  THEN
               J = J + 2
               WRITE (LUN, 2003)  T(J), T(J+1)
            ENDIF
            FAIL = (FERMAX.GT.TOL).OR.(DERMAX.GT.TOL)
            IF (FAIL)  IFAIL = IFAIL + 1
            IF ((KPRINT.GE.3).OR.(KPRINT.GE.2).AND.FAIL)
     *         WRITE (LUN, 2005)  FERMAX, DERMAX, TOL
         ENDIF
C
C          Special check for KNOTYP=-1.
         IF (KNOTYP.EQ.0)  THEN
C             Save knot vector for next test.
            DO 200  I = 1, NKNOTS
               TSAVE(I) = T(I)
  200       CONTINUE
         ELSE IF (KNOTYP.EQ.-1)  THEN
C             Check that knot vector is unchanged.
            TERMAX = ZERO
            DO 250  I = 1, NKNOTS
               TERR = ABS(T(I) - TSAVE(I))
               TERMAX = MAX(TERMAX, TERR)
  250       CONTINUE
            IF (TERMAX.GT.TOLZ)  THEN
               IFAIL = IFAIL + 1
               IF (KPRINT.GE.2)  WRITE (LUN, 2007)  TERMAX, TOLZ
            ENDIF
         ENDIF
  300 CONTINUE
C
C  PRINT SUMMARY AND TERMINATE.
C
      IF ((KPRINT.GE.2).AND.(IFAIL.NE.0))  WRITE (LUN, 3001)  IFAIL
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 PCH TO B-SPLINE CONVERTER')
 1001 FORMAT (//10X,'PCHQK5 RESULTS'/10X,'--------------')
 1010 FORMAT (/4X,'(Results should be the same for all KNOTYP values.)')
 2000 FORMAT (/4X,'KNOTYP =',I2,':  NKNOTS =',I3,',  NDIM =',I3,
     *                        ',  K =',I2,',  IERR =',I3)
 2001 FORMAT (' *** Failed -- bad IERR value.')
 2002 FORMAT (/15X,'X',9X,'KNOTS',10X,'F',7X,'FERR',8X,'D',7X,'DERR')
 2003 FORMAT (18X,2F8.2)
 2004 FORMAT (10X,3F8.2,F10.4,1P,E10.2,0P,F10.4,1P,E10.2)
 2005 FORMAT (/5X,'Maximum relative errors:'
     *       /15X,'F-error =',1P,E13.5,5X,'D-error =',E13.5
     *        /5X,'Both should be less than  TOL =',E13.5)
 2007 FORMAT (/' *** T-ARRAY MAXIMUM CHANGE =',1P,E13.5,
     *           ';  SHOULD NOT EXCEED TOLZ =',E13.5)
 3001 FORMAT (/' *** TROUBLE ***',I5,' CONVERSION TESTS FAILED.')
99998 FORMAT (/' ------------  PCHIP PASSED  ALL CONVERSION TESTS',
     *        ' ------------')
99999 FORMAT (/' ************  PCHIP FAILED SOME CONVERSION TESTS',
     *        ' ************')
C------------- LAST LINE OF PCHQK5 FOLLOWS -----------------------------
      END