relibc_openlibm/slatec/bfqad.f

*DECK BFQAD
      SUBROUTINE BFQAD (F, T, BCOEF, N, K, ID, X1, X2, TOL, QUAD, IERR,
     +   WORK)
C***BEGIN PROLOGUE  BFQAD
C***PURPOSE  Compute the integral of a product of a function and a
C            derivative of a B-spline.
C***LIBRARY   SLATEC
C***CATEGORY  H2A2A1, E3, K6
C***TYPE      SINGLE PRECISION (BFQAD-S, DBFQAD-D)
C***KEYWORDS  INTEGRAL OF B-SPLINE, QUADRATURE
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BFQAD computes the integral on (X1,X2) of a product of a
C         function F and the ID-th derivative of a K-th order B-spline,
C         using the B-representation (T,BCOEF,N,K).  (X1,X2) must be
C         a subinterval of T(K) .LE. X .le. T(N+1).  An integration
C         routine BSGQ8 (a modification
C         of GAUS8), integrates the product on sub-
C         intervals of (X1,X2) formed by included (distinct) knots.
C
C     Description of Arguments
C         Input
C           F      - external function of one argument for the
C                    integrand BF(X)=F(X)*BVALU(T,BCOEF,N,K,ID,X,INBV,
C                    WORK)
C           T      - knot array of length N+K
C           BCOEF  - coefficient array of length N
C           N      - length of coefficient array
C           K      - order of B-spline, K .GE. 1
C           ID     - order of the spline derivative, 0 .LE. ID .LE. K-1
C                    ID=0 gives the spline function
C           X1,X2  - end points of quadrature interval in
C                    T(K) .LE. X .LE. T(N+1)
C           TOL    - desired accuracy for the quadrature, suggest
C                    10.*STOL .LT. TOL .LE. 0.1 where STOL is the single
C                    precision unit roundoff for the machine = R1MACH(4)
C
C         Output
C           QUAD   - integral of BF(X) on (X1,X2)
C           IERR   - a status code
C                    IERR=1  normal return
C                         2  some quadrature on (X1,X2) does not meet
C                            the requested tolerance.
C           WORK   - work vector of length 3*K
C
C     Error Conditions
C         X1 or X2 not in T(K) .LE. X .LE. T(N+1) is a fatal error.
C         TOL not greater than the single precision unit roundoff or
C         less than 0.1 is a fatal error.
C         Some quadrature fails to meet the requested tolerance.
C
C***REFERENCES  D. E. Amos, Quadrature subroutines for splines and
C                 B-splines, Report SAND79-1825, Sandia Laboratories,
C                 December 1979.
C***ROUTINES CALLED  BSGQ8, INTRV, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BFQAD
C
C
      INTEGER ID, IERR, IFLG, ILO, IL1, IL2, K, LEFT, MFLAG, N, NPK, NP1
      REAL A,AA,ANS,B,BB,BCOEF,Q,QUAD,T,TA,TB,TOL,WORK,WTOL, X1,
     1 X2
      REAL R1MACH, F
      DIMENSION T(*), BCOEF(*), WORK(*)
      EXTERNAL F
C***FIRST EXECUTABLE STATEMENT  BFQAD
      IERR = 1
      QUAD = 0.0E0
      IF(K.LT.1) GO TO 100
      IF(N.LT.K) GO TO 105
      IF(ID.LT.0 .OR. ID.GE.K) GO TO 110
      WTOL = R1MACH(4)
      IF (TOL.LT.WTOL .OR. TOL.GT.0.1E0) GO TO 30
      AA = MIN(X1,X2)
      BB = MAX(X1,X2)
      IF (AA.LT.T(K)) GO TO 20
      NP1 = N + 1
      IF (BB.GT.T(NP1)) GO TO 20
      IF (AA.EQ.BB) RETURN
      NPK = N + K
C
      ILO = 1
      CALL INTRV(T, NPK, AA, ILO, IL1, MFLAG)
      CALL INTRV(T, NPK, BB, ILO, IL2, MFLAG)
      IF (IL2.GE.NP1) IL2 = N
      INBV = 1
      Q = 0.0E0
      DO 10 LEFT=IL1,IL2
        TA = T(LEFT)
        TB = T(LEFT+1)
        IF (TA.EQ.TB) GO TO 10
        A = MAX(AA,TA)
        B = MIN(BB,TB)
        CALL BSGQ8(F,T,BCOEF,N,K,ID,A,B,INBV,TOL,ANS,IFLG,WORK)
        IF (IFLG.GT.1) IERR = 2
        Q = Q + ANS
   10 CONTINUE
      IF (X1.GT.X2) Q = -Q
      QUAD = Q
      RETURN
C
C
   20 CONTINUE
      CALL XERMSG ('SLATEC', 'BFQAD',
     +   'X1 OR X2 OR BOTH DO NOT SATISFY T(K).LE.X.LE.T(N+1)', 2, 1)
      RETURN
   30 CONTINUE
      CALL XERMSG ('SLATEC', 'BFQAD',
     +   'TOL IS LESS THAN THE SINGLE PRECISION TOLERANCE OR ' //
     +   'GREATER THAN 0.1', 2, 1)
      RETURN
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'BFQAD', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'BFQAD', 'N DOES NOT SATISFY N.GE.K', 2,
     +   1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'BFQAD',
     +   'ID DOES NOT SATISFY 0 .LE. ID .LT. K', 2, 1)
      RETURN
      END