smpint.f

      SUBROUTINE smpint( ND, NF, MINCLS, MAXCLS, FUNSUB,
     &                   EPSABS, EPSREL, KEY, SBRGNS, WRKLEN, VRTWRK, 
     &                   RESTAR, VALUE, ERROR, FUNCLS, INFORM )
*
****BEGIN PROLOGUE SMPINT
****AUTHOR
*
*            Alan Genz 
*            Department of Mathematics
*            Washington State University 
*            Pullman, WA 99164-3113, USA
*            Email: alangenz@wsu.edu
*
****LAST MODIFICATION 2002-9
****KEYWORDS automatic multidimensional integrator,
*            n-dimensional simplex, general purpose, global adaptive
****PURPOSE  To calculate an approximation to a vector of integrals
*
*               I = I (F ,F ,...,F   ) DS
*                    S  1  2      NF       
*
*            where S is a collection ND-dimensional simplices,
*            and  F = F (X ,X ,...,X  ), K = 1, 2, ..., NF,
*                  K   K  1  2      ND
*            and try to satisfy for each component I(K) of I 
*              ABS( I(K) - VALUE(K) ) < MAX( EPSABS, EPSREL*ABS(I(K)) )
*
****DESCRIPTION Computation of integrals over simplical regions.
*            SMPINT is a driver for the integration routine SMPSAD, 
*            which repeatedly subdivides the region of integration and 
*            estimates the integrals and the errors over the subregions 
*            with greatest estimated errors until the error request
*            is met or MAXCLS function evaluations have been used.
*
*   ON ENTRY
*
*     ND     Integer, number of variables. 1 < ND 
*     NF     Integer, number of components of the integral.
*     MINCLS Integer, minimum number of FUNSUB calls.
*     MAXCLS Integer, maximum number of FUNSUB calls.
*            RULCLS is number FUNSUB calls for each subregion (see WRKLEN),
*            DIFCLS = 1 + 2*ND*( ND + 1 ).              
*            If RESTAR = 0, MAXCLS must be >= MAX(SBRGNS*RULCLS,MINCLS).
*            If RESTAR = 1, MAXCLS must be >= MAX(4*RULCLS+DIFCLS,MINCLS).
*     FUNSUB Externally declared subroutine for computing components of
*            the integrand at the given evaluation point.
*            It must have parameters (ND,X,NF,FUNVLS)
*            Input parameters:
*              ND   Integer that gives the dimension of I
*              X      Real array of dimension ND that contains the 
*                     evaluation point.
*              NF Integer that gives the number of components of I.
*            Output parameter:
*              FUNVLS Real array of dimension NF that contains the
*                     components of the integrand.
*     EPSABS Real.
*            Requested absolute accuracy.
*     EPSREL Real requested relative accuracy.
*     KEY    Integer, key to selected local integration rule.
*            KEY = 3 gives the user a (default) degree 7 integration rule.
*            KEY = 1 gives the user a degree 3 integration rule.
*            KEY = 2 gives the user a degree 5 integration rule.
*            KEY = 3 gives the user a degree 7 integration rule.
*            KEY = 4 gives the user a degree 9 integration rule.
*     WRKLEN Integer, length of the working array VRTWRK.
*             WRKLEN should be >= WRKSBS*( ND*(ND+1) + 2*NF + 3 ) 
*                                + (ND+1)*(ND+2) + 7*NF,      where 
*             WRKSBS = SBRGNS + 3*( MAXCLS/RULCLS - SBRGNS*(1-RESTAR) )/4. 
*            If  
*              KEY = 0, RULCLS = (ND+4)*(ND+3)*(ND+2)/6 + (ND+2)*(ND+1);
*              KEY = 1, RULCLS = 2*ND+3;
*              KEY = 2, RULCLS = (ND+3)*(ND+2)/2 + 2*(ND+1);
*              KEY = 3, RULCLS = (ND+4)*(ND+3)*(ND+2)/6 + (ND+2)*(ND+1);
*              KEY = 4, RULCLS = (ND+5)*(ND+4)*(ND+3)*(ND+2)/24 
*                                 + 5*(ND+2)*(ND+1)/2 .             
*     SBRGNS Integer, initial number of simplices.
*     VRTWRK Real array of dimension WRKLEN.
*            Work should contain the simplex vertices for SBRGNS 
*            simplices; the coordinates of vertex J for simplex K
*            must be in VRTWRK(I+J*ND+(K-1)*ND*(ND+1)), 
*            for I = 1, ..., ND; J = 0, ..., ND; K = 1, ..., SBRGNS.
*            The rest of VRTWRK is used as working storage; see below.
*     RESTAR Integer.
*            If RESTAR = 0, this is the first attempt to compute
*             the integrals over SBRGNS simplices.
*            If RESTAR = 1, then we restart a previous attempt.
*             In this case the only parameters for SMPINT that may
*             be changed (with respect to the previous call of SMPINT)
*             are MINCLS, MAXCLS, EPSABS, EPSREL, KEY and RESTAR.
*   ON RETURN
*
*     SBRGNS Integer.
*            SBRGNS contains the current number of simplices. They
*            were obtained by subdividing the input simplicies.
*     VRTWRK   Real array of dimension WRKLEN.
*            Used as working storage.
*            Let MAXSUB = (WRKLEN-(ND+1)*(ND+2)-7*NF)/(ND*(ND+1)+2*NF+3). 
*            VRTWRK(1), ..., VRTWRK(ND*(ND+1)), ..., 
*             VRTWRK(ND*(ND+1)*SBRGNS) contain subregion vertices.
*            VRTWRK(ND*(ND+1)*MAXSUB+1), ..., 
*             VRTWRK(ND*(ND+1)*MAXSUB+NF*SBRGNS) contain
*             estimated components of the integrals over the subregions.
*            VRTWRK(ND*(ND+1)*MAXSUB+NF*MAXSUB+1), ..., 
*             VRTWRK(ND*(ND+1)*MAXSUB+NF*(MAXSUB+SBRGNS)) 
*             contain estimated errors for the subregions.
*            VRTWRK(ND*(ND+1)*MAXSUB+2*NF*MAXSUB+1), ..., 
*             VRTWRK(ND*(ND+1)*MAXSUB+2*NF*MAXSUB+SBRGNS)) 
*             contain volumes of the subregions (scaled by ND!).
*            VRTWRK(ND*(ND+1)*MAXSUB+(2*NF+1)*MAXSUB+1), ..., 
*             VRTWRK(ND*(ND+1)*MAXSUB+(2*NF+1)*MAXSUB+SBRGNS) 
*             contain greatest errors in each subregion.
*            VRTWRK(ND*(ND+1)*MAXSUB+(2*NF+2)*MAXSUB+1), ..., 
*             VRTWRK(ND*(ND+1)*MAXSUB+(2*NF+2)*MAXSUB+SBRGNS) 
*             contain pointers for the subregion heap.
*            The rest of VRTWRK is used as temporary storage in SMPSAD.
*     VALUE  Real array of dimension NF of integral approximations.
*     ERROR  Real array of dimension NF, of absolute accuracy estimates.
*     FUNCLS Integer, number of FUNSUB calls used by SMPINT.
*     INFORM Integer.
*            INFORM = 0 for normal exit, when ERROR(K) <=  EPSABS or
*              ERROR(K) <=  ABS(VALUE(K))*EPSREL with MAXCLS or less
*              function evaluations for all values of K, 1 <= K <= NF.
*            INFORM = 1 if MAXCLS was too small for SMPINT to obtain
*              the required accuracy. In this case SMPINT returns
*              values VALUE with estimated absolute accuracies ERROR.
*            INFORM = 2 if KEY < 0 or KEY > 4,
*            INFORM = 3 if ND < 2, 
*            INFORM = 4 if NF < 1,
*            INFORM = 5 if EPSABS < 0 and EPSREL < 0,
*            INFORM = 6 if WRKLEN is too small,
*            INFORM = 7 if RESTAR < 0 or RESTAR > 1,
*            INFORM = 8 if SBRGNS <= 0.
*
****ROUTINES CALLED SMPCHC,SMPSAD
****END PROLOGUE SMPINT
*
*   Global variables.
*
      EXTERNAL funsub
      INTEGER ND, NF, MINCLS, MAXCLS, SBRGNS
      INTEGER KEY, WRKLEN, RESTAR, FUNCLS, INFORM
      DOUBLE PRECISION EPSABS, EPSREL
      DOUBLE PRECISION VALUE(NF), ERROR(NF), VRTWRK(WRKLEN)
*
*   Local variables.
*
*   MAXSUB Integer, maximum allowed number of subdivisions
*          for the given values of KEY, ND and NF.
*
      INTEGER MAXSUB, RULCLS, I1, I2, I3, I4, I5, I6
*
****FIRST PROCESSING STATEMENT SMPINT
*
*   Compute MAXSUB and RULCLS, and check the input parameters.
*
*     
      CALL smpchc( nd, nf, mincls, maxcls, epsabs, epsrel, sbrgns,
     &             key, wrklen, restar, rulcls, maxsub, inform )
      IF ( inform .EQ. 0 ) THEN
*
*   Split up the work space and call SMPSAD.
*
         i1 =  1 + maxsub*nd*(nd+1)
         i2 = i1 + maxsub*nf
         i3 = i2 + maxsub*nf
         i4 = i3 + maxsub
         i5 = i4 + maxsub
         i6 = i5 + maxsub
         CALL smpsad( nd, nf, funsub, mincls, maxcls, epsabs, epsrel,
     &        restar, key, rulcls, maxsub, sbrgns, vrtwrk, 
     &        vrtwrk(i1), vrtwrk(i2), vrtwrk(i3), vrtwrk(i4), 
     &        vrtwrk(i5), vrtwrk(i6), VALUE, error, funcls, inform )
      ELSE
         funcls = 0
      ENDIF
*
****END SMPINT
*
      END
      SUBROUTINE smpchc( ND, NF, MINCLS, MAXCLS, EPSABS, EPSREL, SBRGNS,
     &                   KEY, WRKLEN, RESTAR, RULCLS, MAXSUB, INFORM )
*
****BEGIN PROLOGUE SMPCHC
****AUTHOR
*
*            Alan Genz 
*            Department of Mathematics 
*            Washington State University 
*            Pullman, WA 99164-3113, USA
*
****LAST MODIFICATION 2001-07
****PURPOSE  SMPCHC checks validity of input parameters for SMPINT.
****DESCRIPTION
*            SMPCHC computes MAXSUB, RULCLS and INFORM as functions of 
*             input parameters for SMPINT, and checks the validity of
*             input parameters for SMPINT.
*
*   ON ENTRY
*
*     ND   Integer, number of variables,  ND > 1. 
*     NF Integer, number of components of the integral.
*     MINCLS Integer, minimum number of new FUNSUB calls.
*     MAXCLS Integer, maximum number of new FUNSUB calls.
*            The number of function values for each subregion is RULCLS. 
*            If
*             KEY = 0, RULCLS = (ND+4)*(ND+3)*(ND+2)/6 + (ND+2)*(ND+1);
*             KEY = 1, RULCLS = 2*ND+3;
*             KEY = 2, RULCLS = (ND+3)*(ND+2)/2 + 2*(ND+1);
*             KEY = 3, RULCLS = (ND+4)*(ND+3)*(ND+2)/6 + (ND+2)*(ND+1);
*             KEY = 4, RULCLS = (ND+5)*(ND+4)*(ND+3)*(ND+2)/24 
*                               + 5*(ND+2)*(ND+1)/2 .
*            DIFCLS = 1 + 2*ND*( ND + 1 ).              
*            If RESTAR = 0, MAXCLS must be >= MAX(SBRGNS*RULCLS,MINCLS).
*            If RESTAR = 1, MAXCLS must be >= MAX(4*RULCLS+DIFCLS,MINCLS).
*     EPSABS Real, requested absolute accuracy.
*     EPSREL Real, requested relative accuracy.
*     SBRGNS Integer, initial number of simplices.
*     KEY    Integer, key to selected local integration rule.
*            KEY = 0 gives the user a (default)degree 7 integration rule.
*            KEY = 1 gives the user a degree 3 integration rule.
*            KEY = 2 gives the user a degree 5 integration rule.
*            KEY = 3 gives the user a degree 7 integration rule.
*            KEY = 4 gives the user a degree 9 integration rule.
*     WRKLEN Integer, length of the working array WORK.
*             WRKLEN should be >= WRKSBS*( ND*(ND+1) + 2*NF + 3 )
*                                + (ND+1)*(ND+2) + 7*NF, where
*             WRKSBS = SBRGNS + 3*( MAXCLS/RULCLS - SBRGNS*(1-RESTAR) )/4. 
*     RESTAR Integer.
*            If RESTAR = 0, this is the first attempt to compute
*             the integral over the SBRGNS input simplices.
*            If RESTAR = 1, then we restart a previous attempt.
*
*   ON RETURN
*
*     RULCLS Integer, number of function values for each subregion. 
*            If
*             KEY = 0, RULCLS = (ND+4)*(ND+3)*(ND+2)/6 + (ND+2)*(ND+1);
*             KEY = 1, RULCLS = 2*ND+3;
*             KEY = 2, RULCLS = (ND+3)*(ND+2)/2 + 2*(ND+1);
*             KEY = 3, RULCLS = (ND+4)*(ND+3)*(ND+2)/6 + (ND+2)*(ND+1);
*             KEY = 4, RULCLS = (ND+5)*(ND+4)*(ND+3)*(ND+2)/24 
*                               + 5*(ND+2)*(ND+1)/2 .
*     MAXSUB Integer, maximum allowed number of subregions for the
*            given values of MAXCLS, WRKLEN, KEY and ND.
*     INFORM Integer.
*            INFORM = 0 for normal exit,
*            INFORM = 2 if KEY < 0 or KEY > 4,
*            INFORM = 3 if ND < 2, 
*            INFORM = 4 if NF < 1,
*            INFORM = 5 if EPSABS < 0 and EPSREL < 0.,
*            INFORM = 6 if WRKLEN is too small,
*            INFORM = 7 if RESTAR < 0 or RESTAR > 1,
*            INFORM = 8 if SBRGNS <= 0.
*
****END PROLOGUE SMPCHC
*
*   Global variables.
*
      INTEGER ND, NF, MINCLS, MAXCLS, KEY, MAXSUB
      INTEGER WRKLEN, INFORM, RESTAR, RULCLS, SBRGNS
      DOUBLE PRECISION EPSABS, EPSREL
*
*     Local variables.
*
      INTEGER WRKDIF, DIFCLS
*
****FIRST PROCESSING STATEMENT SMPCHC
*
      inform = 0
*
*     Check valid KEY.
*     
      IF ( key .LT. 0 .OR. key .GT. 4 ) inform = 2
*
*     Check valid ND.
*
      IF ( nd .LT. 2 ) inform = 3
*
*     Check positive NF.
*
      IF ( nf .LT. 1 ) inform = 4
*
*     Check valid accuracy requests.
*
      IF ( epsabs .LT. 0 .AND. epsrel .LT. 0 ) inform = 5
*
*     Check workspace.
*
      wrkdif = (nd+1)*(nd+2) + 7*nf
      maxsub = ( wrklen - wrkdif )/( (nd+1)*nd + 2*nf + 3 ) 
      IF ( maxsub .LE. sbrgns ) inform = 6
*
*     Check valid RESTAR.
*
      IF ( restar .NE. 0 .AND. restar .NE. 1 ) inform = 7
*
*     Check valid SBRGNS.
*
      IF ( sbrgns .LE. 0 ) inform = 8
*
*     Compute RULCLS as a function of KEY and ND and check MAXCLS.
*
      IF ( inform .EQ. 0 ) THEN
         difcls = 1 + 2*nd*( nd + 1 )
         IF (key .EQ. 0) rulcls = (nd+4)*(nd+3)*(nd+2)/6 + (nd+2)*(nd+1)
         IF (key .EQ. 1) rulcls = 2*nd + 3
         IF (key .EQ. 2) rulcls = (nd+3)*(nd+2)/2 + 2*(nd+1)
         IF (key .EQ. 3) rulcls = (nd+4)*(nd+3)*(nd+2)/6 + (nd+2)*(nd+1)
         IF (key .EQ. 4) rulcls = (nd+5)*(nd+4)*(nd+3)*(nd+2)/24 
     &                           + 5*(nd+2)*(nd+1)/2
         IF ( restar.EQ.0 .AND. maxcls.LT.max(sbrgns*rulcls,mincls) .OR.
     &        restar.EQ.1 .AND. maxcls.LT.max(4*rulcls+difcls,mincls) )      
     &        inform = 1
      ENDIF
*
****END SMPCHC
*
      END
*
      SUBROUTINE smpsad( ND, NF, FUNSUB, MINCLS, MAXCLS, EPSABS, EPSREL, 
     &      RESTAR, KEY, RULCLS, MAXSUB, SBRGNS, VERTCS, VALUES, ERRORS,
     &      VOLUMS, GREATS, PONTRS, WORK, VALUE, ERROR, FUNCLS, INFORM )
*
****BEGIN PROLOGUE SMPSAD
****KEYWORDS automatic multidimensional integrator,
*            n-dimensional simplex,
*            general purpose, global adaptive
****AUTHOR
*
*            Alan Genz 
*            Department of Mathematics 
*            Washington State University 
*            Pullman, WA 99164-3113, USA
*
****LAST MODIFICATION 2001-07
****PURPOSE  The routine calculates an approximation to a given
*            vector of definite integrals, I, over a hyper-rectangular
*            region hopefully satisfying for each component of I the
*            following claim for accuracy:
*            ABS( I(K) - VALUE(K) ) .LE. MAX( EPSABS, EPSREL*ABS(I(K) ) )
****DESCRIPTION Computation of integrals over hyper-rectangular regions.
*            SMPSAD repeatedly subdivides the regions of integration 
*            and estimates the integrals and the errors over the 
*            subregions with  greatest estimated errors until the error
*            request is met or MAXSUB subregions are stored. The regions 
*            are divided into three or four equally sized parts along
*            the direction(s) with greatest absolute fourth difference.
*
*   ON ENTRY
*
*     ND     Integer, number of variables, ND > 1.
*     NF     Integer, number of components of the integral.
*     FUNSUB Externally declared subroutine for computing components of
*            the integrand at the given evaluation point.
*            It must have parameters (ND,X,NF,FUNVLS)
*            Input parameters:
*              ND Integer that gives the dimension of I
*              X  Real array of dimension ND that contains the 
*                     evaluation point.
*              NF Integer that gives the number of components of I.
*            Output parameter:
*              FUNVLS Real array of dimension NF that contains the
*                     components of the integrand.
*     MINCLS Integer.
*            The computations proceed until there are at least
*            MINCLS FUNSUB calls.
*     MAXCLS Integer.
*            The computations proceed until further subdivision would
*            require more than MAXCLS FUNSUB calls. When RESTAR = 1,
*            this is the number of new FUNSUB calls.
*     EPSABS Real, requested absolute accuracy.
*     EPSREL Real, requested relative accuracy.
*     RESTAR Integer.
*            If RESTAR = 0, this is the first attempt to compute
*             the integral.
*            If RESTAR = 1, then we restart a previous attempt.
*             (In this case the output parameters from SMPSAD
*             must not be changed since the last exit from SMPSAD.)
*     KEY    Integer, key to selected local integration rule.
*            KEY = 1 gives the user a degree 3 integration rule.
*            KEY = 2 gives the user a degree 5 integration rule.
*            KEY = 3 gives the user a degree 7 integration rule.
*            KEY = 4 gives the user a degree 9 integration rule.
*     RULCLS Integer, number of FUNSUB calls needed for each subregion.
*     MAXSUB Integer; computations proceed until there are at most
*            MAXSUB subregions in the data structure.
*     SBRGNS Integer.
*            If RESTAR = 0, then SBRGNS must specify the number
*            of subregions stored in a previous call to SMPSAD.
*     VERTCS Real array of dimension (ND,0:ND,*).
*            Simplex vertices for each subregion; for subregion K vertex
*            J must have components VERTEX(I,J,K), I = 1, 2, ..., ND.
*     VALUES Real array of dimension (NF,*), for estimated values of the 
*             integrals over the subregions.
*     ERRORS Real array of dimension (NF,*).
*            Used to store the corresponding estimated errors.
*            Used to store the half widths of the stored subregions.
*     GREATS Real array of dimension (*).
*            Used to store the greatest estimated errors in subregions.
*     PONTRS Real array of dimension (*), for the pointers from the 
*             subregion heap to the actual subregions.
*     WORK   Real array, used in SMPVOL, SMPDFS, and SMPRUL.
*
*   ON RETURN
*
*     SBRGNS Integer, number of stored subregions.
*     VALUE  Real array of dimension NF.
*            Approximations to all components of the integral.
*     ERROR  Real array of dimension NF.
*            Estimates of absolute accuracies.
*     FUNCLS Integer, number of new FUNSUB calls used by SMPSAD.
*     INFORM Integer.
*            INFORM = 0 for normal exit, when ERROR(K) <=  EPSABS or
*              ERROR(K) <=  ABS(VALUE(K))*EPSREL, 1 <= K <= NF, 
*              with MAXSUB or fewer subregions processed.              
*            INFORM = 1 if MAXSUB was too small for SMPSAD
*              to obtain the required accuracy. In this case SMPSAD
*              returns values of VALUE with estimated absolute
*              accuracies ERROR.
*
****REFERENCES
****ROUTINES CALLED SMPSTR, SMPVOL, SMPRUL
****END PROLOGUE SMPSAD
*
*   Global variables.
*
      EXTERNAL funsub
      INTEGER ND, NF, RULCLS, MINCLS, MAXCLS, MAXSUB, KEY, RESTAR
      INTEGER FUNCLS, SBRGNS, INFORM
      DOUBLE PRECISION EPSABS, EPSREL, VALUE(NF), ERROR(NF)
      DOUBLE PRECISION VALUES(NF,*), ERRORS(NF,*), VERTCS(ND,0:ND,*)
      DOUBLE PRECISION VOLUMS(*), GREATS(*), PONTRS(*), WORK(*)
*
*   Local variables.
*
*
*   MXNWSB is the maxiumum number of new subregions per subdivision.
*
      INTEGER I, INDEX, J, TOP, MXNWSB, NEWSBS, DFCOST, RGNCLS
      PARAMETER ( MXNWSB = 4 )
      double precision smpvol, tune
      parameter( tune = 1 )
*
****FIRST PROCESSING STATEMENT SMPSAD
*     
*
*   Initialize for rule parameters.
*
      funcls = 0
      dfcost = 1 + 2*nd*( nd + 1 )
*
*   If RESTAR = 0, initialize for first call.
*
      IF ( restar .EQ. 0 ) THEN
*
*     Initialize FUNCLS, and VALUE and ERROR arrays.
*     
         DO j = 1, nf
            value(j) = 0
            error(j) = 0
         END DO
         DO index = 1, sbrgns
*     
*     Call SMPVOL to compute the simplex volume(s).
*     
            volums(index) = smpvol( nd, vertcs(1,0,index), work )
*
*     Apply basic rule over each simplex.
*
            CALL smprul( tune, nd, vertcs(1,0,index), volums(index), 
     &           nf, funsub, key, values(1,index), errors(1,index), 
     &           greats(index), work, work(2*nd+2) )
*
*     Add new contributions to VALUE and ERROR.
*     Store results in heap.
*     
            DO j = 1, nf
               value(j) = value(j) + values(j,index)
               error(j) = error(j) + errors(j,index)
            END DO
            CALL smpstr( index, index, pontrs, greats )
            funcls = funcls + rulcls
         END DO
      END IF
      inform = max( 0, min( mincls - funcls, 1 ) )
      DO j = 1, nf
         IF( error(j) .GT. max(epsabs,epsrel*abs(value(j))) ) inform = 1
      END DO
*
*     End initialisation.
*
      DO WHILE ( inform .GT. 0 .AND. sbrgns + mxnwsb - 1 .LE. maxsub 
     &           .AND. funcls + dfcost + mxnwsb*rulcls .LE. maxcls )
*
*     Begin loop while error is too large, and FUNCLS and SBRGNS
*     are not too large.
*
*     Adjust VALUE and ERROR.
*     
         top = pontrs(1)
         DO j = 1, nf
            value(j) = value(j) - values(j,top)
            error(j) = error(j) - errors(j,top)
         END DO
*     
*     Determine NEWSBS new subregions.
*
         CALL smpdfs( nd, nf, funsub, top, sbrgns, vertcs, 
     &                volums, work, work(nd+1), work(2*nd+1), 
     &                work(3*nd+1), work(3*nd+1+5*nf), newsbs )       
*
*     Apply basic rule, store results in heap and
*     add new contributions to VALUE and ERROR.
*     
         index = top
         DO i = 1, newsbs
            CALL smprul( tune, nd, vertcs(1,0,index), volums(index), nf,
     &                   funsub, key, values(1,index), errors(1,index), 
     &                   greats(index), work, work(2*nd+2) )
            CALL smpstr( index, sbrgns+i-1, pontrs, greats )
            DO j = 1, nf 
               value(j) = value(j) + values(j,index)
               error(j) = error(j) + errors(j,index)
            END DO
            index = sbrgns + i
         END DO
         funcls = funcls + dfcost + newsbs*rulcls
         sbrgns = sbrgns + newsbs - 1
*     
*     Check for error termination.
*
         inform = max( 0, min( mincls - funcls, 1 ) )
         DO j = 1, nf
            IF( error(j) .GT. max(epsabs,epsrel*abs(value(j))) ) 
     &           inform = 1
         END DO
      END DO
*
*     Compute more accurate values of VALUE and ERROR.
*
      DO i = 1, nf
         value(i) = 0
         error(i) = 0
         DO j = 1, sbrgns
            value(i) = value(i) + values(i,j)
            error(i) = error(i) + errors(i,j)
         END DO
      END DO
*
****END SMPSAD
*
      END
*
      DOUBLE PRECISION FUNCTION smpvol( ND, VERTEX, WORK )
*
****BEGIN PROLOGUE SMPVOL
****KEYWORDS simplex volume
****PURPOSE  Function to compute the scaled volume of a simplex.
****AUTHOR
*
*            Alan Genz 
*            Department of Mathematics 
*            Washington State University 
*            Pullman, WA 99164-3113, USA
*
****LAST MODIFICATION 96-12
****DESCRIPTION SMPVOL computes the volume of an ND-simplex scaled by
*                      using Gauss elimination to compute a determinant.
*
*   ON ENTRY
*
*   ND     Integer, number of variables.
*   VERTEX Real array of dimension (ND,0:ND), of simplex vertices; 
*          vertex J must have components VERTEX(I,J), I = 1, 2, ..., ND.
*   WORK   Real work array of dimension at least ND*ND.
*
*   ON RETURN
*
*   SMPVOL Real, value for the volume. 
*
****ROUTINES CALLED: None.
*
****END PROLOGUE SMPVOL
*
*   Global variables.
*
      INTEGER ND
      DOUBLE PRECISION VERTEX(ND,0:ND), WORK(ND,*)
*
*   Local variables.
*
      INTEGER I, J, K, PIVPOS
      DOUBLE PRECISION MULT, VOL, WTEMP
*
****FIRST PROCESSING STATEMENT SMPVOL
*
*
*     Copy vertex differences to WORK array.
*
      DO j = 1, nd
         DO i = 1, nd
            work(i,j) = vertex(i,j) - vertex(i,0)
         END DO
      END DO
*
*     Use Gauss elimination with partial pivoting.
*
      vol = 1
      DO k = 1, nd
         pivpos = k
         DO j = k+1, nd
            IF ( abs(work(k,j)) .GT. abs(work(k,pivpos)) ) pivpos = j
         END DO
         DO i = k, nd
            wtemp = work(i,k)
            work(i,k) = work(i,pivpos)
            work(i,pivpos) = wtemp
         END DO
         vol = vol*work(k,k)/k
         DO j = k+1, nd
            mult = work(k,j)/work(k,k)
            DO i = k+1, nd
               work(i,j) = work(i,j) - mult*work(i,k)
            END DO
         END DO
      END DO
      smpvol = abs(vol)
*
****END SMPVOL
*
      END
*
      SUBROUTINE smprul( TUNE, ND, VERTEX, VOLUME, NF, INTGND,
     &                   INKEY, BASVAL, RGNERR, GREAT, GT, RULE )
*
****BEGIN PROLOGUE SMPRUL
****KEYWORDS basic numerical integration rule
****PURPOSE  To compute basic integration rule values.
****AUTHOR
*
*            Alan Genz
*            Department of Mathematics
*            Washington State University
*            Pullman, WA 99164-3113, USA
*            AlanGenz@wsu.edu
*
****LAST MODIFICATION 2001-07
****DESCRIPTION SMPRUL computes basic integration rule values for a
*            vector of integrands over a hyper-rectangular region.
*            These are estimates for the integrals. SMPRUL also computes
*            estimates for the errors.
*
*   ON ENTRY
*
*     TUNE   Real, tuning parameter, with 0 <= TUNE <= 1, with
*            TUNE = 1 for the most conservative error estimates. 
*            If TUNE < 0, only the rule parameters are computed.
*     ND    Integer, number of variables.
*     VERTEX Real array of dimension (ND,0:ND).
*            The simplex vertices; vertex J must have components
*            VERTEX(I,J), I = 1, 2, ..., ND.
*     NF     Integer, number of components for the vector integrand.
*     INTGND Subroutine for computing components of the integrand at Z.
*            It must have parameters (ND,X,NF,FUNVLS)
*            Input parameters:
*              ND    Integer that gives the dimension.
*              X      Real array of dimension ND that contains the 
*                     evaluation point.
*              NF     Integer that gives the number of components of I.
*            Output parameter:
*              FUNVLS Real array of dimension NF that contains the
*                     components of the integrand.
*     INKEY  Integer rule parameter. 
*            If INKEY .GT. 0 and INKEY .LT. 5 then a rule of degree 
*            2*INKEY + 1; otherwise default degree 7 rule is used.
*     GT     Real work array of length 2*ND+1.
*     RULE   Real work array of dimension (NF,7).
*
*   ON RETURN
*
*     BASVAL Real array of length NF, values for the basic rule for 
*            each component of the integrand.
*     RGNERR Real array of length NF, error estimates for BASVAL.
*     GREAT  Real, maximum component of RGNERR.
*
*
****ROUTINES CALLED: SMPRMS, SYMRUL
*
****END PROLOGUE SMPRUL
*
*   Global variables.
*
      EXTERNAL intgnd
      INTEGER NF, ND, INKEY
      DOUBLE PRECISION VERTEX(ND,0:ND), BASVAL(NF), RGNERR(NF)
      DOUBLE PRECISION VOLUME, TUNE, GREAT
*
*   Local variables.
*
*   WTS    Integer number of weights in the integration rules.
*   W      Real array of dimension (WTS,RLS).
*          The weights for the basic and null rules.
*          W(1,1),...,W(WTS,1) are weights for the basic rule.
*          W(1,I),...,W(WTS,I), for I > 1 are null rule weights.
*   G      Real array of dimension (0:4, WTS).
*          The fully symmetric sum generators for the rules.
*
      INTEGER KEY, NUMNUL, RLS, WTS, MXW, MXRLS, MXG
      PARAMETER( MXW = 21, mxrls = 7, mxg = 4  )
      DOUBLE PRECISION W( MXW, MXRLS ), G( 0:MXG, MXW ), WTSUM
      DOUBLE PRECISION GT( 0:2*ND ), RULE( NF, MXRLS )
      DOUBLE PRECISION NORMCF, NORMNL, NORMCP, ALPHA(MXRLS)
      DOUBLE PRECISION RATIO, ERRCOF, RATMIN, SMALL, SMPROD
      parameter( ratmin = 1d-1, small = 1d-12 )
      INTEGER I, J, K, OLDKEY, OLDN, PTS(MXW)
      SAVE oldkey, oldn, key, pts, w, g, rls, wts
      DATA oldkey, oldn/ -1, 0 /
*
****FIRST PROCESSING STATEMENT SMPRUL
*     
      IF ( oldkey .NE. inkey .OR. oldn .NE. nd ) THEN
         oldn = nd
         oldkey = inkey
         IF ( inkey .GT. 0 .AND. inkey .LT. 5 ) THEN
            key = inkey
         ELSE
            key = 3
         END IF
*
*        Compute WTS, RLS, weights, generators, ERRCOF and PTS.
*
         CALL smprms( nd, key, mxw, w, mxg, g, wts, rls, pts )
*
*        Orthogonalize and normalize null rules.
*
         normcf = smprod( wts, pts, w(1,1), w(1,1) )
         DO k = 2, rls
            DO j = 2, k-1
               alpha(j) = -smprod( wts, pts, w(1,j), w(1,k) ) 
            END DO
            DO i = 1, wts
               wtsum = 0
               DO j = 2, k-1
                  wtsum = wtsum + w(i,j)*alpha(j)
               END DO
               w(i,k) = w(i,k) + wtsum/normcf
            END DO
            normnl = smprod( wts, pts, w(1,k), w(1,k) )
            DO i = 1, wts
               w(i,k) = w(i,k)*sqrt( normcf/normnl )
            END DO
         END DO
      ENDIF
      IF ( tune .GE. 0 ) THEN
*
*     Compute the rule values.
*
         DO i = 1, nf
            DO j = 1, rls
               rule(i,j) = 0
            END DO
         END DO
         DO k = 1, wts
            IF ( pts(k) .GT. 0 ) THEN
               DO i = 0, min(nd,mxg-1)
                  gt(i) = g(i,k)
               END DO
               IF ( nd .GE. mxg ) CALL smpcpy( mxg, nd, gt, g(mxg,k) )
               CALL smpsms( nd, vertex, nf, intgnd, gt, basval, 
     &                                              gt(nd+1), rgnerr )
               DO j = 1, rls
                  DO i = 1, nf
                     rule(i,j) = rule(i,j) + w(k,j)*basval(i)
                  END DO
               END DO
            END IF
         END DO
*
*     Scale integral values and compute the error estimates.
*
         errcof = ( 8*tune + ( 1 - tune ) )
         great = 0
         DO i = 1, nf
            basval(i) = rule(i,1)
            normcf = abs( basval(i) )
            rgnerr(i) = 0
            ratio = ratmin
            DO k = rls, 3, -2
               normnl = max( abs( rule(i,k) ), abs( rule(i,k-1) ) )
               IF ( normnl .GT. small*normcf .AND. k .LT. rls )
     &              ratio = max( normnl/normcp, ratio )
               rgnerr(i) = max( normnl, rgnerr(i) )
               normcp = normnl 
            END DO
            IF( ratio .GE. 1 ) THEN
               rgnerr(i) = tune*rgnerr(i) + ( 1 - tune )*normcp
            ELSE IF ( key .GT. 1 ) THEN
               rgnerr(i) = ratio*normcp
            END IF
            rgnerr(i) = volume*max( errcof*rgnerr(i), small*normcf )     
            basval(i) = volume*basval(i)
            great = max( great, rgnerr(i) )
         END DO
      END IF
*
****END SMPRUL
*
      END 
*
      DOUBLE PRECISION FUNCTION smprod( N, W, X, Y )
      INTEGER N, I, W(*)
      DOUBLE PRECISION X(*), Y(*), SUM
      SUM = 0
      DO i = 1, n
         sum = sum + w(i)*x(i)*y(i)
      END DO
      smprod = sum
      END
*
      SUBROUTINE smprms( ND, KEY, MXW, W, MXG, G, WTS, RLS, PTS )
*
****BEGIN PROLOGUE SMPRMS
****KEYWORDS basic integration rule, degree 2*KEY+1
****PURPOSE  To initialize a degree 2*KEY+1 basic rule and null rules.
****AUTHOR
*
*            Alan Genz
*            Department of Mathematics
*            Washington State University
*            Pullman, WA 99164-3113, USA
*            AlanGenz@wsu.edu
*
****LAST MODIFICATION 2001-07
****DESCRIPTION  SMPRMS initializes a degree 2*KEY+1 rule, and
*                and max(2*KEY,2) lower degree null rules.
*
*   ON ENTRY
*
*   ND    Integer, number of variables.
*   KEY    Integer, < 5 and >= 0, rule parameter.
*          If KEY > 0 a degree 2*KEY+1 rule is initialized.
*          If KEY = 0 a degree 7 rule is initialized.
*
*   ON RETURN
*   RLS    Integer, total number of rules.
*   WTS    Integer, total number of weights in each of the rules.
*   W      Real array of dimension (MXW,*).
*          The weights for the basic and null rules.
*          W(1,1),...,W(WTS,1) are weights for the basic rule.
*          W(I,1),...,W(WTS,I) for I .GT. 1 are null rule weights.
*   G      Real array of dimension (0:MXG,MXW).
*          The fully symmetric sum generators for the rules.
*          G(0,J), ..., G(MXG,J) are the generators for the
*          points associated with the Jth weights.
*   PTS    Integer array of length (MXW). PTS(J) is number of integrand 
*          values needed for generator J.
*
****REFERENCES
*
*  Axel Grundmann and H. M. Moller
*  "Invariant Integration Formulas for the n-Simplex by Combinatorial 
*    Methods", SIAM J Numer. Anal. 15(1978), 282--290,
* and
*  A. H. Stroud
*  "A Fifth Degree Integration Formula for the n-Simplex
*  SIAM J Numer. Anal. 6(1969), 90--98,
* and           
*  I. P. Mysovskikh
*  "On a cubature formula for the simplex"
*  Vopros. Vycisl. i Prikl. Mat., Tashkent 51(1978), 74--90.
*
*
****ROUTINES CALLED NONE
****END PROLOGUE SMPRMS
*
*   Global variables
*
      INTEGER ND, KEY, WTS, MXW, RLS, MXG
      INTEGER PTS(MXW)
      DOUBLE PRECISION W(MXW,*), G(0:MXG,*)
*
*   Local Variables
*
      DOUBLE PRECISION ONE, FFTEEN
      parameter( one = 1, ffteen = 15 )
      DOUBLE PRECISION DR, DR2, DR4, DR6, DR8
      DOUBLE PRECISION R1, S1, R2, S2, U1, V1, U2, V2, L1, L2, D1, D2
      DOUBLE PRECISION A1, A2, A3, P0, P1, P2, P3, U5, U6, U7, SG
      DOUBLE PRECISION R, A, P, Q, TH, TP
      INTEGER IW, GMS, I, J
*
****FIRST PROCESSING STATEMENT SMPRMS
*
*
*     Initialize RLS and GMS.
*
      IF ( key .EQ. 1 ) THEN
         rls = 3
         gms = 2
         wts = 3
      ELSE IF ( key .EQ. 2 ) THEN
         rls = 5
         gms = 4
         wts = 6
      ELSE IF ( key .EQ. 3 .OR. key .EQ. 0 ) THEN
         rls = 7
         gms = 7
         wts = 11
      ELSE IF ( key .EQ. 4 ) THEN
         rls = 7
         IF ( nd .EQ. 2 ) THEN
            gms = 11
            wts = 20
         ELSE
            gms = 12
            wts = 21
         END IF
      END IF
*
*     Initialize generators, weights and PTS.
*
      DO i = 1, wts
         DO j = 1, rls
            w(i,j) = 0
         END DO
         pts(i) = 0
      END DO
*
*     Compute generator, PTS and weight values for all rules.
*
      dr = nd
      dr2 =     ( dr + 1 )*( dr + 2 )
      dr4 = dr2*( dr + 3 )*( dr + 4 )
      dr6 = dr4*( dr + 5 )*( dr + 6 )
      dr8 = dr6*( dr + 7 )*( dr + 8 )
      CALL smpcpy( 0, mxg, g(0,1), 1/( dr + 1 ) )
      pts(1) = 1
      r1 = ( dr + 4 - sqrt(ffteen) )/( dr*dr + 8*dr + 1 )
      s1 = 1 - dr*r1
      l1 = s1 - r1
      g(0   ,gms+1) = s1
      CALL smpcpy( 1, mxg, g(0,gms+1), r1 )
      DO i = 1, mxg
         g(i,gms+1) = r1
      END DO
      pts(gms+1) = dr + 1
      iw = rls
      IF ( key .LT. 4 )  THEN
*
*        Compute weights for special degree 1 rule.
*
         w(1,iw) = 1
         iw = iw - 1
         w(gms+1,iw) = 1/( dr + 1 )
         iw = iw - 1
      END IF
*
*     Compute weights, generators and PTS for degree 3 rule.
*
      g(0,2) = 3/( dr + 3 )
      CALL smpcpy( 1, mxg, g(0,2), 1/( dr + 3 ) )
      pts(2) = dr + 1
        w(2,iw) = ( dr + 3 )**3/( 4*dr2*( dr + 3 ) )
      IF ( key .GT. 1 ) THEN
         iw = iw - 1
*
*        Compute weights, generators and PTS for degree 3 and 5 rules.
*
         IF ( nd .EQ. 2 ) THEN
*
*           Special degree 3 rule.
*
            l2 = .62054648267200632589046034361711d0
            l1 = -sqrt( one/2 - l2**2 )
            r1 = ( 1 - l1 )/3
            s1 = 1 - 2*r1
            g(0,gms+1) = s1
            CALL smpcpy( 1, mxg, g(0,gms+1), r1 )
            pts(gms+1) = 3
              w(gms+1,iw) = one/6
            r2 = ( 1 - l2 )/3
            s2 = 1 - 2*r2
            g(0,gms+2) = s2
            CALL smpcpy( 1, mxg, g(0,gms+2), r2 )
            pts(gms+2) = 3
              w(gms+2,iw) = one/6
         ELSE
*
*           Degree 3 rule using Stroud points.
*
            r2 = ( dr + 4 + sqrt(ffteen) )/( dr*dr + 8*dr + 1 )
            s2 = 1 - dr*r2
            l2 = s2 - r2
            g(0,gms+2) = s2
            CALL smpcpy( 1, mxg, g(0,gms+2), r2 )
            pts(gms+2) = dr + 1
              w(gms+2,iw) = ( 2/(dr+3) - l1 )/( dr2*(l2-l1)*l2**2 )
              w(gms+1,iw) = ( 2/(dr+3) - l2 )/( dr2*(l1-l2)*l1**2 )
         END IF
         iw = iw - 1
*
*        Grundmann-Moller degree 5 rule.
*
         g(0,3) = 5/( dr + 5 )
         CALL smpcpy( 1, mxg, g(0,3), 1/( dr + 5 ) )
         pts(3) = dr + 1
         g(0,4) = 3/( dr + 5 )
         g(1,4) = 3/( dr + 5 )
         CALL smpcpy( 2, mxg, g(0,4), 1/( dr + 5 ) )
         pts(4) = ( ( dr + 1 )*dr )/2
           w(2,iw) = -( dr + 3 )**5/( 16*dr4 )
           w(3,iw) =  ( dr + 5 )**5/( 16*dr4*( dr + 5 ) )
           w(4,iw) =  ( dr + 5 )**5/( 16*dr4*( dr + 5 ) )
      END IF
      IF ( key .GT. 2 )  THEN
         iw = iw - 1
*
*        Compute weights, generators and PTS for degree 5 and 7 rules.
*
*
*        Stroud degree 5 rule.
*
         u1 = ( dr + 7 + 2*sqrt(ffteen) )/( dr*dr + 14*dr - 11 )
         v1 = ( 1 - ( dr - 1 )*u1 )/2
         d1 = v1 - u1
         g(0,gms+3) = v1
         g(1,gms+3) = v1
         CALL smpcpy( 2, mxg, g(0,gms+3), u1 )
         pts(gms+3) = ( ( dr + 1 )*dr )/2
         u2 = ( dr + 7 - 2*sqrt(ffteen) )/( dr*dr + 14*dr - 11 )
         v2 = ( 1 - ( dr - 1 )*u2 )/2
         d2 = v2 - u2
         g(0,gms+4) = v2
         g(1,gms+4) = v2
         CALL smpcpy( 2, mxg, g(0,gms+4), u2 )
         pts(gms+4) = ( ( dr + 1 )*dr )/2
         IF ( nd .EQ. 2 ) THEN
            w(gms+3,iw) = ( 155 - sqrt(ffteen) )/1200
            w(gms+4,iw) = ( 155 + sqrt(ffteen) )/1200
            w(1,    iw) = 1 - 3*( w(gms+3,iw) + w(gms+4,iw) ) 
         ELSE IF ( nd .EQ. 3 ) THEN
            w(gms+1,iw) = ( 2665 + 14*sqrt(ffteen) )/37800
            w(gms+2,iw) = ( 2665 - 14*sqrt(ffteen) )/37800
            w(gms+3,iw) = 2*ffteen/567
            pts(gms+4) = 0
         ELSE
            w(gms+1,iw) = ( 2*(27-dr)/(dr+5)-l2*(13-dr) )
     &                       /( l1**4*(l1-l2)*dr4 )
            w(gms+2,iw) = ( 2*(27-dr)/(dr+5)-l1*(13-dr) )
     &                       /( l2**4*(l2-l1)*dr4 )
            w(gms+3,iw)=( 2/( dr + 5 ) - d2 )/( dr4*( d1 - d2 )*d1**4 )
            w(gms+4,iw)=( 2/( dr + 5 ) - d1 )/( dr4*( d2 - d1 )*d2**4 )
         END IF
         iw = iw - 1
*
*        Grundmann-Moller degree 7 rule.
*
         g(0,5) = 7/( dr + 7 )
         CALL smpcpy( 1, mxg, g(0,5), 1/( dr + 7 ) )
         pts(5) = dr + 1 
         g(0,6) = 5/( dr + 7 )
         g(1,6) = 3/( dr + 7 )
         CALL smpcpy( 2, mxg, g(0,6), 1/( dr + 7 ) )
         pts(6) = ( dr + 1 )*dr
         g(0,7) = 3/( dr + 7 )
         g(1,7) = 3/( dr + 7 )
         g(2,7) = 3/( dr + 7 )
         CALL smpcpy( 3, mxg, g(0,7), 1/( dr + 7 ) )
         pts(7) = ( ( dr + 1 )*dr*( dr - 1 ) )/6
         w(2,iw) =  ( dr + 3 )**7/( 2*64*dr4*( dr + 5 ) )
         w(3,iw) = -( dr + 5 )**7/(   64*dr6 )
         w(4,iw) = -( dr + 5 )**7/(   64*dr6 )
         w(5,iw) =  ( dr + 7 )**7/(   64*dr6*( dr + 7 ) )
         w(6,iw) =  ( dr + 7 )**7/(   64*dr6*( dr + 7 ) )
         w(7,iw) =  ( dr + 7 )**7/(   64*dr6*( dr + 7 ) )
      END IF
      IF ( key .EQ. 4 )  THEN
         iw = iw - 1
*
*        Compute weights, generators and PTS for degree 7, 9 rules.
*
*        Mysovskikh degree 7 rule.
*
         sg = 1/( 23328*dr6 )
         u5 = -6**3*sg*( 52212 - dr*( 6353 + dr*( 1934 - dr*27 ) ) )       
         u6 =  6**4*sg*(  7884 - dr*( 1541 - dr*9 ) )
         u7 = -6**5*sg*(  8292 - dr*( 1139 - dr*3 ) )/( dr + 7 )
         p0 = -144*( 142528 + dr*( 23073 - dr*115 ) )
         p1 = -12*( 6690556 + dr*( 2641189 + dr*( 245378 - dr*1495 ) ) )
         p2 = -16*(6503401 + dr*(4020794+dr*(787281+dr*(47323-dr*385))))      
         p3 = -( 6386660 + dr*(4411997+dr*(951821+dr*(61659-dr*665))) )
     &        *( dr + 7 )
         a = p2/( 3*p3 )
         p = a*( p1/p2 - a )
         q = a*( 2*a*a - p1/p3 ) + p0/p3
         r = sqrt( -p**3 )
         th = acos( -q/( 2*r ) )/3
         r = 2*r**( one/3 )
         tp = 2*acos(-one)/3
         a1 = -a + r*cos( th ) 
         a2 = -a + r*cos( th + tp + tp )
         a3 = -a + r*cos( th + tp )
         g(0,gms+5) = ( 1 - dr*a1 )/( dr + 1 )
         CALL smpcpy( 1, mxg, g(0,gms+5), ( 1 + a1 )/( dr + 1 ) )
         pts(gms+5) = dr + 1
         g(0,gms+6) = ( 1 - dr*a2 )/( dr + 1 )
         CALL smpcpy( 1, mxg, g(0,gms+6), ( 1 + a2 )/( dr + 1 ) )
         pts(gms+6) = dr + 1
         g(0,gms+7) = ( 1 - dr*a3 )/( dr + 1 )
         CALL smpcpy( 1, mxg, g(0,gms+7), ( 1 + a3 )/( dr + 1 ) )
         pts(gms+7) = dr + 1
           w(gms+5,iw) = ( u7-(a2+a3)*u6+a2*a3*u5 )
     &                  /( a1**2-(a2+a3)*a1+a2*a3 )/a1**5
           w(gms+6,iw) = ( u7-(a1+a3)*u6+a1*a3*u5 )
     &                  /( a2**2-(a1+a3)*a2+a1*a3 )/a2**5
           w(gms+7,iw) = ( u7-(a2+a1)*u6+a2*a1*u5 )
     &                  /( a3**2-(a2+a1)*a3+a2*a1 )/a3**5
         g(0,gms+8) = 4/( dr + 7 )
         g(1,gms+8) = 4/( dr + 7 )
         CALL smpcpy( 2, mxg, g(0,gms+8), 1/( dr + 7 ) )
         pts(gms+8) = ( ( dr + 1 )*dr )/2
           w(gms+8,iw) = 10*(dr+7)**6/( 729*dr6 )
         g(0,gms+9) = 11/( dr + 7 )/2
         g(1,gms+9) =  5/( dr + 7 )/2
         CALL smpcpy( 2, mxg, g(0,gms+9), 1/( dr + 7 ) )
         pts(gms+9) = ( ( dr + 1 )*dr )
           w(gms+9,iw) = 64*(dr+7)**6/( 6561*dr6 )
           w(    4,iw) = w(4,iw+1)
           w(    7,iw) = w(7,iw+1)
         iw = iw - 1
*
*        Grundmann-Moller degree 9 rule.
*
         g(0,8) = 9/( dr + 9 )
         CALL smpcpy( 1, mxg, g(0, 8), 1/( dr + 9 ) )
         pts(8) = dr + 1 
         g(0,9) = 7/( dr + 9 )
         g(1,9) = 3/( dr + 9 )
         CALL smpcpy( 2, mxg, g(0, 9), 1/( dr + 9 ) )
         pts(9) = ( dr + 1 )*dr 
         g(0,10) = 5/( dr + 9 )
         g(1,10) = 5/( dr + 9 )
         CALL smpcpy( 2, mxg, g(0,10), 1/( dr + 9 ) )
         pts(10) = ( ( dr + 1 )*dr )/2
         g(0,11) = 5/( dr + 9 )
         g(1,11) = 3/( dr + 9 )
         g(2,11) = 3/( dr + 9 )
         CALL smpcpy( 3, mxg, g(0,11), 1/( dr + 9 ) )
         pts(11) = ( ( dr + 1 )*dr*( dr - 1 ) )/2
           w(2 ,iw) = -( dr + 3 )**9/( 6*256*dr6 )
           w(3 ,iw) =  ( dr + 5 )**9/( 2*256*dr6*( dr + 7 ) )
           w(4 ,iw) =  ( dr + 5 )**9/( 2*256*dr6*( dr + 7 ) )
           w(5 ,iw) = -( dr + 7 )**9/(   256*dr8 )
           w(6 ,iw) = -( dr + 7 )**9/(   256*dr8 )
           w(7 ,iw) = -( dr + 7 )**9/(   256*dr8 )
           w(8 ,iw) =  ( dr + 9 )**9/(   256*dr8*( dr + 9 ) )
           w(9 ,iw) =  ( dr + 9 )**9/(   256*dr8*( dr + 9 ) )
           w(10,iw) =  ( dr + 9 )**9/(   256*dr8*( dr + 9 ) )
           w(11,iw) =  ( dr + 9 )**9/(   256*dr8*( dr + 9 ) )
         IF ( nd .GT. 2 ) THEN
            g(0,12) = 3/( dr + 9 )
            g(1,12) = 3/( dr + 9 )
            g(2,12) = 3/( dr + 9 )
            g(3,12) = 3/( dr + 9 )
            CALL smpcpy( 4, mxg, g(0,12), 1/( dr + 9 ) )
            pts(12) = ( ( dr + 1 )*dr*( dr - 1 )*( dr - 2 ) )/24
              w(12,iw) = w(8,iw)
         END IF         
      END IF
*
*     Compute constant weight values.
*
      DO j = 1, rls
         w(1,j) = 1
         DO i = 2, wts
            w(1,j) = w(1,j) - pts(i)*w(i,j) 
         END DO
      END DO
*
*     Compute final weight values; null rule weights are computed as 
*     differences between weights from highest degree and lower degree rules.
*
      DO j = 2, rls
         DO i = 1, wts
            w(i,j) = w(i,j) - w(i,1) 
         END DO
      END DO
*
****END SMPRMS
*
      END
*
      SUBROUTINE smpcpy( START, END, PARAM, VALUE )
      DOUBLE PRECISION VALUE, PARAM(0:*)
      INTEGER START, END, I
      DO I = start, END
         param(i) = VALUE
      END DO
      END 
*
      SUBROUTINE smpsms( N, VERTEX, NF, F, G, SYMSMS, X, FUNVLS )
*
****BEGIN PROLOGUE SMPSMS
****KEYWORDS fully symmetric sum
****PURPOSE  To compute fully symmetric basic rule sums
****AUTHOR
*
*        Alan Genz
*        Department of Mathematics
*        Washington State University
*        Pullman, WA 99164-3113, USA
*
****LAST MODIFICATION 97-04
****DESCRIPTION SMPSMS computes a fully symmetric sum for a vector
*            of integrand values over a simplex. The sum is taken over
*            all permutations of the generators for the sum.
*
*   ON ENTRY
*
*   N       Integer, number of variables.
*   VERTEX  Real array of dimension (N,0:N)
*           The vertices of the simplex, one vertex per column.
*   NF      Integer, number of components for the vector integrand.
*   F       Subroutine for computing components of the integrand at X.
*            It must have parameters ( N, X, NF, FUNVLS ); 
*            Input parameters:
*              N      Integer dimension of integral.
*              X      Real array of length N, the evaluation point.
*              NF     Integer number of components of the integrand.
*            Output parameter:
*             FUNVLS  Real array of length NF, the integrand values at X.
*   G       Real Array of dimension (0:N).
*           The generators for the fully symmetric sum. 
*
*   ON RETURN
*
*   SYMSMS  Real array of length NF, the values for the fully symmetric 
*            sums for each component of the integrand.
*
****ROUTINES CALLED: Integrand
*
****END PROLOGUE SMPSMS
*
*   Global variables.
*
      INTEGER N, NF
      DOUBLE PRECISION VERTEX(N,0:N),G(0:N), SYMSMS(NF),FUNVLS(NF), X(N)
*
*   Local variables.
*
      INTEGER IX, LX, I, J, K, L
      DOUBLE PRECISION GL, GI
*
****FIRST PROCESSING STATEMENT SymSum
*
      DO i = 1, nf
         symsms(i) = 0
      END DO
*
*     Sort generators if necessary
*
      k = 0
      DO i = 1, n
         IF ( g(i) .GT. g(i-1) ) k = 1
      END DO
      IF ( k .GT. 0 ) THEN
         DO i = 1, n
            k = i - 1
            DO j = i, n
               IF ( g(j) .GT. g(k) ) k = j
            END DO
            IF ( k .GE. i ) THEN
               gi = g(i-1)
               g(i-1) = g(k)
               g(k) = gi
            END IF
         END DO
      END IF
*
*     Compute integrand value for permutations of G
*
 10   DO i = 1, n
         x(i) = vertex(i,0)*g(0)
         DO j = 1, n
            x(i) = x(i) + vertex(i,j)*g(j)
         END DO
      END DO
      CALL f( n, x, nf, funvls )
      DO j = 1, nf
         symsms(j) = symsms(j) + funvls(j)
      END DO
*
*     Find next distinct permuation of G and loop back for value.
*     Permutations are generated in reverse lexicographic order.
*
      DO i = 1, n
         IF ( g(i-1) .GT. g(i) ) THEN
            gi = g(i)
            ix = i - 1
            DO l = 0, i/2-1
               gl = g(l)
               g(l) = g(i-l-1)
               g(i-l-1) = gl
               IF (  gl .LE. gi ) ix = ix - 1
               IF ( g(l) .GT. gi ) lx = l
            END DO
            IF ( g(ix) .LE. gi ) ix = lx
            g(i) = g(ix)
            g(ix) = gi
            GO TO 10
         END IF
      END DO
*
****END SMPSMS
*
      END 
*
      SUBROUTINE smpstr( POINTR, SBRGNS, PONTRS, RGNERS )
*
****BEGIN PROLOGUE SMPSTR
****AUTHOR
*
*            Alan Genz 
*            Department of Mathematics 
*            Washington State University 
*            Pullman, WA 99164-3113, USA
*
****LAST MODIFICATION 2001-07
****PURPOSE SMPSTR maintains a heap for subregions.
****DESCRIPTION SMPSTR maintains a heap for subregions.
*            The subregions are ordered according to the size of the
*            greatest error estimates of each subregion (RGNERS).
*
*   PARAMETERS
*
*     POINTR Integer.
*            The index for the subregion to be inserted in the heap.
*     SBRGNS Integer.
*            Number of subregions in the heap.
*     PONTRS Real array of dimension SBRGNS.
*            Used to store the indices for the greatest estimated errors
*            for each subregion.
*     RGNERS Real array of dimension SBRGNS.
*            Used to store the greatest estimated errors for each 
*            subregion.
*
****ROUTINES CALLED NONE
****END PROLOGUE SMPSTR
*
*   Global variables.
*
      INTEGER POINTR, SBRGNS
      DOUBLE PRECISION PONTRS(*), RGNERS(*)
*
*   Local variables.
*
*   RGNERR Intermediate storage for the greatest error of a subregion.
*   SUBRGN Position of child/parent subregion in the heap.
*   SUBTMP Position of parent/child subregion in the heap.
*
      INTEGER SUBRGN, SUBTMP, PT, PTP
      DOUBLE PRECISION RGNERR
*
****FIRST PROCESSING STATEMENT SMPSTR
*     
      RGNERR = rgners(pointr)
      IF ( pointr .EQ. pontrs(1) ) THEN
*
*        Move the new subregion inserted at the top of the heap 
*        to its correct position in the heap.
*
         subrgn = 1
 10      subtmp = 2*subrgn
         IF ( subtmp .LE. sbrgns ) THEN
            IF ( subtmp .NE. sbrgns ) THEN
*     
*              Find maximum of left and right child.
*
               pt = pontrs(subtmp)
               ptp = pontrs(subtmp+1)
               IF ( rgners(pt) .LT. rgners(ptp) ) subtmp = subtmp + 1
            ENDIF
*
*           Compare maximum child with parent.
*           If parent is maximum, then done.
*
            pt = pontrs(subtmp)
            IF ( rgnerr .LT. rgners(pt) ) THEN
*     
*              Move the pointer at position subtmp up the heap.
*     
               pontrs(subrgn) = pt
               subrgn = subtmp
               GO TO 10
            ENDIF
         ENDIF
      ELSE
*
*        Insert new subregion in the heap.
*
         subrgn = sbrgns
 20      subtmp = subrgn/2
         IF ( subtmp .GE. 1 ) THEN
*
*           Compare child with parent. If parent is maximum, then done.
*     
            pt = pontrs(subtmp)
            IF ( rgnerr .GT. rgners(pt) ) THEN
*     
*              Move the pointer at position subtmp down the heap.
*
               pontrs(subrgn) = pt
               subrgn = subtmp
               GO TO 20
            ENDIF
         ENDIF
      ENDIF
      pontrs(subrgn) = pointr
*
****END SMPSTR
*
      END
*
      SUBROUTINE smpdfs( ND, NF, FUNSUB, TOP, SBRGNS, VERTCS, VOLUMS,
     *                    X, H, CENTER, WORK, FRTHDF, NEWSBS )
*
****BEGIN PROLOGUE SMPDFS
****PURPOSE  To compute new subregions
****AUTHOR
*
*            Alan Genz 
*            Department of Mathematics 
*            Washington State University 
*            Pullman, WA 99164-3113, USA
*
****LAST MODIFICATION 2001-07
****DESCRIPTION SMPDFS computes fourth differences along each edge
*            direction. It uses these differences to determine a 
*            subdivision of the orginal subregion into either three or 
*            four new subregions.
*
*   ON ENTRY
*
*   ND   Integer, number of variables.
*   NF   Integer, number of components for the vector integrand.
*   FUNSUB Externally declared subroutine.
*          For computing the components of the integrand at a point X.
*          It must have parameters (ND, X, NF, FUNVLS).
*           Input Parameters:
*            X  Real array of dimension ND, the evaluation point.
*            ND Integer, number of variables for the integrand.
*            NF Integer, number of components for the vector integrand.
*           Output Parameters:
*            FUNVLS Real array of dimension NF.
*                   The components of the integrand at the point X.
*   TOP    Integer, location in VERTCS array for original subregion.
*   SBRGNS Integer, number of subregions in VERTCS BEFORE subdivision.
*   VERTCS Real array of dimension (ND,0:ND,*), vertices of orginal 
*          subregion must be in VERTCS(1:ND,0:ND,TOP).
*   VOLUMS Real array of dimension (*) of volumes for subregions.
*   X      Real work array of dimension ND.
*   H      Real work array of dimension ND.
*   CENTER Real work array of dimension (0:ND).
*   WORK   Real work array of dimension 5*NF.
*   FRTHDF Real work array of dimension (0:ND-1,ND).
*
*   ON RETURN
*
*   NEWSBS Integer, number of new subregions (3 or 4).
*   FUNCLS Integer, number of FUNSUB calls used by SMPDFS.
*   VERTCS Real array of dimension (ND,0:ND,*).
*          The vertices of the of new subegions will be at locations 
*          TOP, SBRGNS+1, ..., SBRGNS+NEWSBS-1.
*   VOLUMS Real Array of dimension (*).
*          VOLUMS has been updated for new subregions.
*
****ROUTINES CALLED: FUNSUB
*
****END PROLOGUE SMPDFS
*
      EXTERNAL funsub
      INTEGER ND, NF, TOP, SBRGNS, NEWSBS
      DOUBLE PRECISION VERTCS(ND,0:ND,*), VOLUMS(*), WORK(NF,*)
      DOUBLE PRECISION X(ND), H(ND), CENTER(ND), FRTHDF(0:ND-1,ND)
      DOUBLE PRECISION DIFFER, DIFMAX, DIFMID, DIFNXT, EWIDTH, EDGMAX
      DOUBLE PRECISION CUTTF, CUTTB, DIFIL, DIFLJ, DFSMAX, VTI, VTJ, VTL 
      PARAMETER ( CUTTF = 2, cuttb = 8 )
      INTEGER I, J, K, L, IE, JE,  IS, JS, LS, IT, JT, LT
      DOUBLE PRECISION SMPVOL
*
****FIRST PROCESSING STATEMENT SMPDFS
*
*
*       Compute the differences.
*
      is = 0
      js = 1
      difmax = 0
      edgmax = 0
      DO k = 1, nd
         center(k) = vertcs(k,0,top)
         DO l = 1, nd
            center(k) = center(k) + vertcs(k,l,top)
         END DO
         center(k) = center(k)/( nd + 1 )
      END DO
      CALL funsub(nd, center, nf, work(1,3))
      DO i = 0, nd-1
         DO j = i+1, nd
            ewidth = 0
            DO k = 1, nd
               h(k) = 2*( vertcs(k,i,top)-vertcs(k,j,top) )/( 5*(nd+1) )
               ewidth = ewidth + abs( h(k) )
               x(k) = center(k) - 3*h(k)
            END DO
            DO l = 1, 5
               DO k = 1, nd
                  x(k) = x(k) + h(k)
               END DO
               IF ( l. ne. 3 ) CALL funsub(nd, x, nf, work(1,l))
            END DO
            IF ( ewidth .GE. edgmax ) THEN
               ie = i
               je = j
               edgmax = ewidth
            END IF
            differ = 0
            difmid = 0
            DO k = 1, nf
               difmid = difmid + abs( work(k,3) )
               differ = differ + abs( work(k,1) + work(k,5)+ 6*work(k,3)
     &                                - 4*( work(k,2) + work(k,4) ) )
            END DO
            IF ( difmid + differ/8 .EQ. difmid ) differ = 0 
            differ = differ*ewidth
            frthdf(i,j) = differ
            IF ( differ .GE. difmax ) THEN
               it = is
               jt = js
               difnxt = difmax
               is = i
               js = j
               difmax = differ
            ELSE IF ( differ .GE. difnxt ) THEN
               it = i
               jt = j
               difnxt = differ
            END IF
         END DO
      END DO
*
*     Determine whether to compute three or four new subregions.
*
      IF ( difnxt .GT. difmax/cuttf ) THEN
         newsbs = 4
      ELSE
         newsbs = 3 
         IF ( difmax .EQ. 0 ) THEN
            is = ie
            js = je
         ELSE
            dfsmax = 0
            DO l = 0, nd
               IF ( l .NE. is .AND. l .NE. js ) THEN
                  it = min( l, is, js )
                  jt = max( l, is, js )
                  lt = is + js + l - it - jt
                  differ =  frthdf(it,lt) + frthdf(lt,jt)
                  IF ( differ .GE. dfsmax ) THEN
                     dfsmax = differ
                     ls = l
                  END IF
               END IF
            END DO
            difil = frthdf( min(is,ls), max(is,ls) )
            diflj = frthdf( min(js,ls), max(js,ls) )
            difnxt = difil + diflj - min( difil,diflj )
            IF ( difmax/cuttb .LT. difnxt .AND. difil .GT. diflj ) THEN 
               it = is
               is = js
               js = it
            END IF
         END IF
      END IF
*
*     Copy vertices and volume for TOP to new subregions
*
      volums(top) = volums(top)/newsbs
      DO l = sbrgns + 1, sbrgns + newsbs - 1
         volums(l) = volums(top)
         DO j = 0, nd
            DO k = 1, nd
               vertcs(k,j,l) = vertcs(k,j,top)
            END DO
         END DO
      END DO
      DO k = 1, nd
         vti = vertcs(k,is,top)
         vtj = vertcs(k,js,top)
         IF ( newsbs .EQ. 4 ) THEN
*     
*     Compute four new subregions.
*     
            vertcs(k,js,top)      = ( vti + vtj )/2
            vertcs(k,is,sbrgns+1) = vti
            vertcs(k,js,sbrgns+1) = ( vti + vtj )/2
            vertcs(k,is,sbrgns+2) = ( vti + vtj )/2
            vertcs(k,js,sbrgns+2) = vtj
            vertcs(k,is,sbrgns+3) = ( vti + vtj )/2
            vertcs(k,js,sbrgns+3) = vtj
            vti = vertcs(k,it,top)
            vtj = vertcs(k,jt,top)
            vertcs(k,jt,top)      = ( vti + vtj )/2
            vertcs(k,it,sbrgns+1) = ( vti + vtj )/2
            vertcs(k,jt,sbrgns+1) = vtj
            vti = vertcs(k,it,sbrgns+2)
            vtj = vertcs(k,jt,sbrgns+2)
            vertcs(k,jt,sbrgns+2) = ( vti + vtj )/2
            vertcs(k,it,sbrgns+3) = ( vti + vtj )/2
            vertcs(k,jt,sbrgns+3) = vtj
         ELSE
*
*     Compute three new subregions.
*
            vertcs(k,js,top)      = ( 2*vti + vtj )/3
            vertcs(k,is,sbrgns+1) = ( 2*vti + vtj )/3
            IF ( difmax/cuttf .LT. difnxt ) THEN
               vertcs(k,js,sbrgns+1) = vtj
               vertcs(k,is,sbrgns+2) = ( 2*vti + vtj )/3
               vertcs(k,js,sbrgns+2) = vtj
               vtj = vertcs(k,js,sbrgns+1)
               vtl = vertcs(k,ls,sbrgns+1)
               vertcs(k,ls,sbrgns+1) = ( vtj + vtl )/2
               vertcs(k,js,sbrgns+2) = ( vtj + vtl )/2
               vertcs(k,ls,sbrgns+2) = vtl
            ELSE
               vertcs(k,js,sbrgns+1) = ( vti + 2*vtj )/3
               vertcs(k,is,sbrgns+2) = ( vti + 2*vtj )/3
               vertcs(k,js,sbrgns+2) = vtj
            END IF
         END IF
      END DO
*     
****END SMPDFS
*
      END