      PROGRAM xconvlv
C     driver for routine convlv
      INTEGER N,N2,M
      REAL PI
      PARAMETER(N=16,N2=32,M=9,PI=3.14159265)
      INTEGER i,isign,j
      REAL cmp,data(N),respns(M),resp(N),ans(N2)
      do 11 i=1,N
        data(i)=0.0
        if ((i.ge.(N/2-N/8)).and.(i.le.(N/2+N/8))) data(i)=1.0
11    continue
      do 12 i=1,M
        respns(i)=0.0
        if (i.gt.2 .and. i.lt.7) respns(i)=1.0
        resp(i)=respns(i)
12    continue
      isign=1
      call convlv(data,N,resp,M,isign,ans)
C     compare with a direct convolution
      write(*,'(/1x,t4,a,t13,a,t24,a)') 'I','CONVLV','Expected'
      do 14 i=1,N
        cmp=0.0
        do 13 j=1,M/2
          cmp=cmp+data(mod(i-j-1+N,N)+1)*respns(j+1)
          cmp=cmp+data(mod(i+j-1,N)+1)*respns(M-j+1)
13      continue
        cmp=cmp+data(i)*respns(1)
        write(*,'(1x,i3,3x,2f12.6)') i,ans(i),cmp
14    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xconvlv.for


C GE WITH SCALED PARTIAL PIVOTING

      SUBROUTINE GESPP(N,A,IA,L,S)
      DIMENSION  A(IA,N),L(N),S(N)
      DO 3 I = 1,N
        L(I) = I
        SMAX = 0.0
        DO 2 J = 1,N
          SMAX = AMAX1(SMAX,ABS(A(I,J)))
   2    CONTINUE
        S(I) = SMAX
   3  CONTINUE
      DO 7 K = 1,N-1
        RMAX = 0.0
        DO 4 I = K,N
          R = ABS(A(L(I),K))/S(L(I))
          IF(R .LE. RMAX)  GO TO 4
          J = I
          RMAX = R
   4    CONTINUE
        LK = L(J)
        L(J) = L(K)
        L(K) = LK
        DO 6 I = K+1,N
          XMULT = A(L(I),K)/A(LK,K)
          DO 5 J = K+1,N
            A(L(I),J) = A(L(I),J) - XMULT*A(LK,J)
   5      CONTINUE
          A(L(I),K) = XMULT
   6    CONTINUE
   7  CONTINUE
      RETURN
      END


      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


subroutine MakeGridDH(griddh, n, cilm, lmax, norm, sampling, csphase, lmax_calc)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Given the Spherical Harmonic coefficients CILM, this subroutine
!	will evalate the function on a grid with an equal number of samples N in
!	both latitude and longitude (or N by 2N by specifying the optional parameter
!	SAMPLING = 2). This is the inverse of the routine SHExpandDH, both of which
!	are done quickly using FFTs for each degree of each latitude band.
!	The number of samples is determined by the spherical harmonic bandwidth LMAX.
!	Nevertheless, the coefficients can be evaluated up to smaller spherical harmonic
!	degree by specifying the optional parameter LMAX_CALC. Note that N is always
!	EVEN for this routine.
!
!	The Legendre functions are computed on the fly using the scaling methodolgy
!	presented in Holmes and Featherston (2002). When NORM = 1, 2 or 4, these are
!	accurate to about degree 2800. When NORM = 3, the routine is only stable to about
!	degree 15!
!
!	The output grid contains N samples in latitude from 90 to -90+interval, and in
!	longitude from 0 to 360-2*interval (or N x 2N, see below), where interval is the
!	sampling interval, and n=2*(LMAX+1). Note that the datum at 90 degees latitude
!	is ultimately downweighted to zero, so this point does not contribute to the
!	spherical harmonic coefficients.
!
!	Calling Parameters
!		IN
!			cilm		Input spherical harmonic coefficients with
!					dimension (2, lmax+1, lmax+1).
!			lmax		Maximum spherical harmonic degree used in the expansion.
!					This determines the spacing of the output grid.
!		OUT
!			griddh		Gridded data of the spherical harmonic
!					coefficients CILM with dimensions (2*LMAX+2 , 2*LMAX+2).
!			n		Number of samples in the grid, always even, which is 2*(LMAX+2).
!		OPTIONAL (IN)
!			norm:		Normalization to be used when calculating Legendre functions
!						(1) "geodesy" (default)
!						(2) Schmidt
!						(3) unnormalized
!						(4) orthonormalized
!			sampling	(1) Grid is N latitudes by N longitudes (default).
!					(2) Grid is N by 2N. The higher frequencies resulting
!					from this oversampling in longitude are discarded, and hence not
!					aliased into lower frequencies.
!			csphase		1: Do not include the phase factor of (-1)^m
!					-1: Apply the phase factor of (-1)^m.
!			lmax_calc	The maximum spherical harmonic degree to evaluate
!					the coefficients up to.
!
!	Notes:
!		1.	If lmax is greater than the the maximum spherical harmonic
!			degree of the input file, then this file will be ZERO PADDED!
!			(i.e., those degrees after lmax are assumed to be zero).
!		2. 	Latitude is geocentric latitude.
!
!	Dependencies:	FFTW3, CSPHASE_DEFAULT
!
!	Written by Mark Wieczorek 2004.
!
!	September 3, 2005. 	Modifed so that the array plx is now optional.
!	September 26, 2005. 	Added optional argument NORM.
!	May 30, 2006. 		Modified routine to take into acount the symmetry of the
!				Legendre functions about the equator, i.e., (-1)^(l+m).
!	October 16, 2006. 	The Legendre functions are now computed within this program
!				during the summations over l and m. This leads to an increase in speed
!				of about a factor of 2. Added optional argument SAMPLING.
!	July 22, 2007.		Added optional parameter LMAX_CALC for evaluating coefficients up
!				to a maximum degree smaller than LMAX.
!	November 21, 2011	Fixed problem where saved variables used in Plm recursion were not recalculated
!				if NORM changed from one call to the next (with the same value of N).
!
!	Copyright (c) 2006-2011, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use FFTW3
	use SHTOOLS, only: CSPHASE_DEFAULT

	implicit none

	real*8, intent(in) :: 	cilm(:,:,:)
	real*8, intent(out) ::	griddh(:,:)
	integer, intent(in) :: 	lmax
	integer, intent(out) ::	n
	integer, intent(in), optional :: norm, sampling, csphase, lmax_calc
	integer :: 		l, m, i, l1, m1, lmax_comp, i_eq, i_s, phase, astat(4), lnorm, &
				k, kstart, nlong
	real*8 :: 		grid(4*lmax+4), pi, theta, coef0, scalef, rescalem, u, p, pmm, &
				pm1, pm2, z, coef0s, tempr
	complex*16 ::		coef(2*lmax+3), coefs(2*lmax+3), tempc
	integer*8 ::		plan
	real*8, save, allocatable ::	f1(:), f2(:), sqr(:), symsign(:)
	integer, save ::	lmax_old=0, norm_old = 0

	n = 2*lmax+2

	if (present(sampling)) then
		if (sampling /= 1 .and. sampling /=2) then
			print*, "Error --- MakeGridDH"
			print*, "Optional parameter SAMPLING must be 1 (N by N) or 2 (N by 2N)."
			print*, "Input value is ", sampling
			stop
		endif
	endif

	if (size(cilm(:,1,1)) < 2) then
		print*, "Error --- MakeGridDH"
		print*, "CILM must be dimensioned as (2, *, *)."
		print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
		stop
	endif

	if (present(sampling)) then
		if (sampling == 1) then
			if (size(griddh(:,1)) < n .or. size(griddh(1,:)) < n) then
				print*, "Error --- MakeGridDH"
				print*, "GRIDDH must be dimensioned as (N, N) where N is ", n
				print*, "Input dimension is ", size(griddh(:,1)), size(griddh(1,:))
				stop
			endif
		elseif (sampling ==2) then
			if (size(griddh(:,1)) < n .or. size(griddh(1,:)) < 2*n) then
				print*, "Error --- MakeGriddDH"
				print*, "GRIDDH must be dimensioned as (N, 2*N) where N is ", n
				print*, "Input dimension is ", size(griddh(:,1)), size(griddh(1,:))
				stop
			endif
		endif
	else

		if (size(griddh(:,1)) < n .or. size(griddh(1,:)) < n) then
			print*, "Error --- MakeGridDH"
			print*, "GRIDDH must be dimensioned as (N, N) where N is ", n
			print*, "Input dimension is ", size(griddh(:,1)), size(griddh(1,:))
			stop
		endif

	endif

	if (present(norm)) then
		if (norm > 4 .or. norm < 1) then
			print*, "Error --- MakeGridDH"
			print*, "Parameter NORM must be 1 (geodesy), 2 (Schmidt), 3 (unnormalized), or 4 (orthonormalized)."
			print*, "Input value is ", norm
			stop
		endif

		lnorm = norm

	else
		lnorm = 1
	endif

	if (present(csphase)) then
     		if (csphase /= -1 .and. csphase /= 1) then
     			print*, "MakeGridDH --- Error"
     			print*, "CSPHASE must be 1 (exclude) or -1 (include)"
     			print*, "Input valuse is ", csphase
     			stop
     		else
     			phase = csphase
     		endif
     	else
     		phase = CSPHASE_DEFAULT
     	endif

	pi = acos(-1.0d0)

	scalef = 1.0d-280

	if (present(lmax_calc)) then
		lmax_comp = min(lmax, size(cilm(1,1,:))-1, size(cilm(1,:,1))-1, lmax_calc)
	else
		lmax_comp = min(lmax, size(cilm(1,1,:))-1, size(cilm(1,:,1))-1)
	endif

	if (present(sampling)) then
		if (sampling == 1) then
			nlong = n
		else
			nlong = 2*n
		endif
	else
		nlong = n
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate recursion constants used in computing the Legendre polynomials
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (lmax_comp /= lmax_old .or. lnorm /= norm_old) then

		if (allocated(sqr)) deallocate(sqr)
		if (allocated(f1)) deallocate(f1)
		if (allocated(f2)) deallocate(f2)
		if (allocated(symsign)) deallocate(symsign)

		allocate(sqr(2*lmax_comp+1), stat=astat(1))
		allocate(f1((lmax_comp+1)*(lmax_comp+2)/2), stat=astat(2))
		allocate(f2((lmax_comp+1)*(lmax_comp+2)/2), stat=astat(3))
		allocate(symsign((lmax_comp+1)*(lmax_comp+2)/2), stat=astat(4))

		if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0 .or. astat(4) /= 0) then
			print*, "MakeGridDH --- Error"
			print*, "Problem allocating arrays SQR, F1, F2, or SYMSIGN", astat(1), astat(2), astat(3), astat(4)
			stop
		endif

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		! 	Calculate signs used for symmetry of Legendre functions about equator
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		k = 0
		do l = 0, lmax_comp, 1
			do m = 0, l, 1
				k = k + 1
				if (mod(l-m,2) == 0) then
					symsign(k) = 1.0d0
				else
					symsign(k) = -1.0d0
				endif
			enddo
		enddo

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		!	Precompute square roots of integers that are used several times.
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		do l=1, 2*lmax_comp+1
			sqr(l) = sqrt(dble(l))
		enddo

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		! 	Precompute multiplicative factors used in recursion relationships
		! 		P(l,m) = x*f1(l,m)*P(l-1,m) - P(l-2,m)*f2(l,m)
		!		k = l*(l+1)/2 + m + 1
		!	Note that prefactors are not used for the case when m=l as a different
		!	recursion is used. Furthermore, for m=l-1, Plmbar(l-2,m) is assumed to be zero.
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		k = 1

		select case(lnorm)

			case(1,4)

				if (lmax_comp /= 0) then
					k = k + 1
					f1(k) = sqr(3)
					f2(k) = 0.0d0
					k = k + 1
				endif

				do l=2, lmax_comp, 1
					k = k + 1
					f1(k) = sqr(2*l-1) * sqr(2*l+1) / dble(l)
					f2(k) = dble(l-1) * sqr(2*l+1) / sqr(2*l-3) / dble(l)
					do m=1, l-2, 1
						k = k+1
						f1(k) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                				f2(k) = sqr(2*l+1) * sqr(l-m-1) * sqr(l+m-1) &
                  				 	/ sqr(2*l-3) / sqr(l+m) / sqr(l-m)
					enddo
					k = k+1
					f1(k) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                			f2(k) = 0.0d0
					k = k + 1
				enddo

			case(2)

				if (lmax_comp /= 0) then
					k = k + 1
					f1(k) = 1.0d0
					f2(k) = 0.0d0
					k = k + 1
				endif

				do l=2, lmax_comp, 1
					k = k + 1
					f1(k) = dble(2*l-1) /dble(l)
					f2(k) = dble(l-1) /dble(l)
					do m=1, l-2, 1
						k = k+1
						f1(k) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                  				f2(k) = sqr(l-m-1) * sqr(l+m-1) / sqr(l+m) / sqr(l-m)
					enddo
					k = k+1
					f1(k) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                  			f2(k) = 0.0d0
					k = k + 1
				enddo

			case(3)

				do l=1, lmax_comp, 1
					k = k + 1
					f1(k) = dble(2*l-1) /dble(l)
					f2(k) = dble(l-1) /dble(l)
					do m=1, l-1, 1
						k = k+1
						f1(k) = dble(2*l-1) / dble(l-m)
                  				f2(k) = dble(l+m-1) / dble(l-m)
					enddo
					k = k + 1
				enddo

		end select

		lmax_old = lmax_comp
		norm_old = lnorm

	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Do special case of lmax_comp = 0
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (lmax_comp == 0) then

		select case(lnorm)
			case(1,2,3);	pm2 = 1.0d0
			case(4);	pm2 = 1.0d0 / sqrt(4.0d0*pi)
		end select

		if (present(sampling)) then

			if (sampling == 1) then
				griddh(1:n, 1:n) = cilm(1,1,1) * pm2
			else
				griddh(1:n, 1:2*n) = cilm(1,1,1) * pm2
			endif

		else

			griddh(1:n, 1:n) = cilm(1,1,1) * pm2

		endif

		return

	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Determine Clms one l at a time by intergrating over latitude.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call dfftw_plan_dft_c2r_1d(plan, nlong, coef(1:nlong/2+1), grid(1:nlong), FFTW_MEASURE)

	i_eq = n/2 + 1	! Index correspondong to zero latitude

	do i=1, i_eq - 1, 1

		i_s = 2*i_eq -i

		theta = pi * dble(i-1)/dble(n)
		z = cos(theta)
		u = sqrt( (1.0d0-z) * (1.0d0+z) )

		coef(1:lmax+1) = dcmplx(0.0d0,0.0d0)
		coef0 = 0.0d0
		coefs(1:lmax+1) = dcmplx(0.0d0,0.0d0)
		coef0s = 0.0d0

		select case(lnorm)
			case(1,2,3);	pm2 = 1.0d0
			case(4);	pm2 = 1.0d0 / sqrt(4.0d0*pi)
		end select

		tempr =  cilm(1,1,1) * pm2
		coef0 = coef0 + tempr
		coef0s = coef0s + tempr 	! symsign is always 1 for l=m=0

		k = 2
		pm1 =  f1(k) * z * pm2
		tempr = cilm(1,2,1) * pm1
		coef0 = coef0 + tempr
		coef0s = coef0s - tempr 	! symsign = -1

		do l=2, lmax_comp, 1
			l1 = l+1
			k = k+l
			p = f1(k) * z * pm1 - f2(k) * pm2
			tempr = cilm(1,l1,1) * p
			coef0 = coef0 + tempr
			coef0s = coef0s + tempr * symsign(k)
			pm2 = pm1
			pm1 = p
		enddo

		select case(lnorm)
			case(1,2);	pmm = sqr(2) * scalef
			case(3);	pmm = scalef
			case(4);	pmm = sqr(2) * scalef / sqrt(4.0d0*pi)
		end select

		rescalem = 1.0d0/scalef
		kstart = 1

		do m = 1, lmax_comp-1, 1

			m1 = m+1
			rescalem = rescalem * u
			kstart = kstart+m+1

			select case(lnorm)
				case(1,4)
					pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm
				case(2)
					pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm / sqr(2*m+1)
				case(3)
					pmm = phase * pmm * dble(2*m-1)
					pm2 = pmm
			end select

			tempc = dcmplx(cilm(1,m1,m1), - cilm(2,m1,m1)) * pm2
			coef(m1) = coef(m1) + tempc
			coefs(m1) = coefs(m1) + tempc
			! symsign(kstart) = 1

			k = kstart+m+1
	   		pm1 = z * f1(k) * pm2

	   		tempc = dcmplx(cilm(1,m1+1,m1), - cilm(2,m1+1,m1)) * pm1
	   		coef(m1) = coef(m1) + tempc
			coefs(m1) = coefs(m1) - tempc
			! symsign = -1

			do l = m+2, lmax_comp, 1
				l1 = l+1
				k = k + l
				p = z * f1(k) * pm1 - f2(k) * pm2
				pm2 = pm1
       				pm1 = p
       				tempc = dcmplx(cilm(1,l1,m1), - cilm(2,l1,m1)) * p
				coef(m1) = coef(m1) + tempc
				coefs(m1) = coefs(m1) + tempc * symsign(k)
			enddo

			coef(m1) = coef(m1) * rescalem
			coefs(m1) = coefs(m1) * rescalem

		enddo

		rescalem = rescalem * u

         	select case(lnorm)
            		case(1,4);	pmm = phase * pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem
            		case(2);	pmm = phase * pmm / sqr(2*lmax_comp) * rescalem
            		case(3);	pmm = phase * pmm * dble(2*lmax_comp-1) * rescalem
        	end select

        	tempc = dcmplx(cilm(1,lmax_comp+1,lmax_comp+1), - cilm(2,lmax_comp+1,lmax_comp+1)) * pmm
        	coef(lmax_comp+1) = coef(lmax_comp+1) + tempc
		coefs(lmax_comp+1) = coefs(lmax_comp+1) + tempc
		! symsign = 1

		coef(1) = dcmplx(coef0,0.0d0)
		coef(2:lmax+1) = coef(2:lmax+1)/2.0d0

		if (present(sampling)) then
			if (sampling == 2) then
				coef(lmax+2:2*lmax+3) = dcmplx(0.0d0,0.0d0)
			endif
		endif

               	call dfftw_execute(plan)	! take fourier transform
               	griddh(i,1:nlong) = grid(1:nlong)

               	if (i /= 1) then	! don't compute value for south pole.
               		coef(1) = dcmplx(coef0s,0.0d0)
			coef(2:lmax+1) = coefs(2:lmax+1)/2.0d0

			if (present(sampling)) then
				if (sampling == 2) then
					coef(lmax+2:2*lmax+3) = dcmplx(0.0d0,0.0d0)
				endif
			endif

               		call dfftw_execute(plan)	! take fourier transform
               		griddh(i_s,1:nlong) = grid(1:nlong)
               	endif

	enddo

	! Finally, do equator

	z = 0.0d0
	u = 1.0d0

	coef(1:lmax+1) = dcmplx(0.0d0,0.0d0)
	coef0 = 0.0d0

	select case(lnorm)
		case(1,2,3);	pm2 = 1.0d0
		case(4);	pm2 = 1.0d0 / sqrt(4.0d0*pi)
	end select

	coef0 = coef0 + cilm(1,1,1) * pm2

	k = 2

	do l=2, lmax_comp, 2
		l1 = l+1
		k = k+l
		p = - f2(k) * pm2
		pm2 = p
		coef0 = coef0 + cilm(1,l1,1) * p
		k = k + l + 1
	enddo

	select case(lnorm)
		case(1,2);	pmm = sqr(2) * scalef
		case(3);	pmm = scalef
		case(4);	pmm = sqr(2) * scalef / sqrt(4.0d0*pi)
	end select

	rescalem = 1.0d0/scalef
	kstart = 1

	do m = 1, lmax_comp-1, 1

		m1 = m + 1
		kstart = kstart+m+1

		select case(lnorm)
			case(1,4)
				pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
				pm2 = pmm
			case(2)
				pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
				pm2 = pmm / sqr(2*m+1)
			case(3)
				pmm = phase * pmm * dble(2*m-1)
				pm2 = pmm
		end select

		coef(m1) = coef(m1) + dcmplx(cilm(1,m1,m1), &
				- cilm(2,m1,m1)) * pm2

		k = kstart+m+1

		do l = m+2, lmax_comp, 2
			l1 = l+1
			k = k + l
			p = - f2(k) * pm2
			coef(m1) = coef(m1) + dcmplx(cilm(1,l1,m1), &
				- cilm(2,l1,m1)) * p
			pm2 = p
                 	k = k + l + 1
		enddo

	enddo

        select case(lnorm)
            	case(1,4);	pmm = phase * pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp)
            	case(2);	pmm = phase * pmm / sqr(2*lmax_comp)
            	case(3);	pmm = phase * pmm * dble(2*lmax_comp-1)
        end select

        coef(lmax_comp+1) = coef(lmax_comp+1) + dcmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
				- cilm(2,lmax_comp+1,lmax_comp+1)) * pmm

	coef(1) = dcmplx(coef0,0.0d0)
	coef(2:lmax+1) = coef(2:lmax+1) * rescalem /2.0d0

	if (present(sampling)) then
		if (sampling == 2) then
			coef(lmax+2:2*lmax+3) = dcmplx(0.0d0,0.0d0)
		endif
	endif

        call dfftw_execute(plan)	! take fourier transform

	griddh(i_eq,1:nlong) = grid(1:nlong)

	call dfftw_destroy_plan(plan)

end subroutine MakeGridDH


C  Copyright (C) 2007: Leslie Greengard
C  Contact: greengard@cims.nyu.edu
C
C  All rights reserved.
C  This copy is not for distribution without permission of the author.
C
C**********************************************************************C
      subroutine spheresolver(nsphere,nterms,nquad,nn1,nn,x0y0z0,
     1     sphererads,scale,zk0,zk,beta0,delta0,beta,delta,
     1     multfmm3dt,rhs,rhs2,rhsjoin,eps,numit,sol,
     1     niter,errs,ngmrec,cw,www,lcw,ierr)
c
c     See Notes for a discussion of mathematical approach.
c
c     Step 1: create rhs for linear system by combining the
c     jump condition data in rhs and rhs2 into a single vector.
c
c     INPUT:
c
c     nsphere  =    number of spheres
c     nterms   =    order of expansions (currently the same for all
c                     spheres)
c     nquad    =    number of quadrature nodes used in projection
c                   2*nterms is generally sufficient.
c     nn1      =    number of unknowns associated with a single sphere
c     nn       =    total number of unknowns
c     x0y0z0   =    sphere centers
c     sphererads   =  sphere radii
c     scale   =       scale parameters for each sphere
c     zk0     =       exterior Helmholtz coefficient
c     zk      =       vector of interior Helmholtz coefficients for
c                     all spheres
c     beta0, delta0  =  material coefficients for exterior region.
c     beta, delta  =  material coefficients for interior regions.
c
c                      [beta phi] = rhs
c                      [delta phi_n] = rhs2
c
c     multfmm3dt =  user-supplied subroutine to carry out matrix-vector
c                   products
c     rhs    =    first jump condition [beta phi]
c     rhs2   =    second jump condition [delta phi_n]
c     eps    =    tolerance for GMRES scheme.
c     numit  =    maximum number of iterations allowed for GMRES.
c     ngmrec =    maximum number of iterations before restarting GMRES.
c     cw     =    workspace
c     www    =    second workspace
c     lcw    =    length of BOTH workspaces.
c
c     OUTPUT:
c
c     rhsjoin = right-hand side for scattering solver - a linear
c               combination of rhs and rhs2.
c
c-------------------------------------------------------
c     sol    =     solution vector.
c
c                  i.e. compact (unrolled) H-expansion coefficients
c                  for spheres 1,2,...,nsphere
c-------------------------------------------------------
c
c     niter  =     number of iterations used.
c     errs  =      errors at each iteration.
c     ierr   =     error return code, not fully implemented
c
c
      implicit none
      integer *4 lcw,nterms,nsphere,nn,nn1,ier,ierr
      integer *4 numit,ngmrec,iflag,lw,niter,i,iffld,lused
      integer *4 nquad,nsp,ltemp,ifder,ntop,next,j,k
      real *8 sphererads(nsphere)
      real *8 x0y0z0(3,nsphere)
      complex *16 zk(nsphere)
      complex *16 beta(nsphere),delta(nsphere)
c
      complex *16 sol(nn)
      complex *16 rhs(nn),rhs2(nn),rhsjoin(nn)
      complex *16 beta0,delta0,zk0,z
      complex *16 cw(lcw),eye
      complex *16 www(lcw),hout
      real *8 targ(3),scale(nsphere),eps
      real *8 errs(1000)
      external multfmm3dt
      data eye/(0.0d0,1.0d0)/
c
      ierr = 0
c
c     Combine f and g according to formula to construct
c     right-hand side for integral equation and store in vector
c     rhs.
c
      do nsp = 1,nsphere
         z = zk(nsp)*sphererads(nsp)
         ltemp = (lcw-2)/3
         ifder = 1
         call jfuns3d(ier,nterms,z,scale(nsp),cw(1),ifder,
     1             cw(ltemp+1),ltemp,cw(2*ltemp+1),ntop)
         next = (nsp-1)*nn1+1
         do j = 0,nterms
            do k = -j,j
               hout  = beta(nsp)*cw(j+1)*rhs2(next) -
     1                 delta(nsp)*zk(nsp)*cw(ltemp+1+j)*rhs(next)
               rhsjoin(next)  = hout
	       next = next+1
            enddo
         enddo
      enddo
c
c    now solve iteratively using GMRES with input parameters.
c
      iflag = 0
      call diagprec3dt(rhsjoin,nsphere,nterms,x0y0z0,sphererads,
     1     scale,zk0,zk,beta0,delta0,beta,delta,cw,lw,iflag)
ccc      call prin2('after diagprec, rhs=*',rhs,2*nn)
      call multini3dt(nsphere,nterms,nquad,x0y0z0,sphererads,
     1     scale,zk0,zk,beta0,delta0,beta,delta,ier)
      call cgmrespc(ier,nn,multfmm3dt,rhsjoin,eps,numit,sol,
     1     niter,errs,ngmrec,cw,www,lcw)
ccc      call prin2(' errs is *',errs,niter)
      return
      end


      DOUBLE PRECISION FUNCTION DMPVAL (P, NDEG, X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-10-20 DMPVAL Krogh  Changes to use M77CON
C>> 1994-04-20 DMPVAL CLL Making DP and SP versions similar.
C>> 1987-12-09 DMPVAL Lawson  Initial code.
C     Evaluation of polynomial using monomial basis and a
c     linear transformation of the argument.
C     C.L.LAWSON, JPL, 1974 NOV 19
c     ------------------------------------------------------------------
c--D replaces "?": ?MPVAL
c     ------------------------------------------------------------------
      integer j, ndeg
      double precision p(*), x, u
c     ------------------------------------------------------------------
      DMPVAL=0.0d0
      u=(x-p(1))/p(2)
      do 20 j = ndeg, 0, -1
          DMPVAL=DMPVAL*u + p(j+3)
   20 continue
      end


c     # ---------------------------------------------------
c     # Trace back solution to initial position
c     # Input arguments should be the coordinates
c     # for the canonical swirl mapping in terms of
c     # (x,y)
c     #
c     #   T = (R*cos(2*pi*x), R*sin(2*pi*x), r*sin(2*pi*y))
c     #
c     #        r = alpha*(1 + beta*sin(2*pi*x))
c     #        R = 1 + r*cos(2*pi*y)
c     #
c     # The solution proceeds in two steps. If we are
c     # solving an incompressible problem, we only need
c     # to evolve (x(t), y(t)).  If we have a compressible
c     # problem, we first evolve (x(t),y(t)) back to a starting
c     # location (x0,y0), and then evolve x, y and q from
c     # the starting location back to final position.
c     # --------------------------------------------------------

      double precision function qexact(x,y,tfinal)
      implicit none

      external map_rhs_divfree, map_rhs_nondivfree
      external solout

      integer mapping
      common /mapping_comm/ mapping

      integer example
      common /example_comm/ example

      double precision x,y,tfinal
      integer blockno

      double precision xc0, yc0
c      double precision xc1, yc1

c      integer blockno_dummy
      double precision t0
      double precision xp,yp,zp

      double precision sigma(3), rtol, atol
      integer itol, iout

      integer Nmax, lwork,nrdens, liwork
      parameter(Nmax=3, nrdens=0)
      parameter(lwork=8*Nmax+5*nrdens+21)
      parameter(liwork=nrdens+21)

      double precision work(lwork), rpar
      double precision q0_physical, q0
      integer iwork(liwork), ipar(2), idid

      double precision tol

      logical evolve_q

      integer*8 cont, get_context

      integer i

      cont = get_context()

c     # ------------------------------------------
c     # Numerical parameters
c     # ------------------------------------------
      itol = 0
      rtol = 1.d-12
      atol = 1.d-12
      iout = 0

      do i = 1,20
          work(i) = 0
          iwork(i) = 0
      enddo

c     # Evolve from t=t0 to t=tfinal
      t0 = 0

c     # Initial conditions for ODE
      sigma(1) = x
      sigma(2) = y

c     # This traces the velocity field back to the origin.
      call dopri5(2,map_rhs_divfree,t0,sigma,tfinal,
     &            rtol,atol,itol,
     &            solout,iout, work,lwork,iwork,liwork,
     &            rpar,ipar,idid)

      if (idid .ne. 1) then
          write(6,*) 'DOPRI5 : idid .ne. 1'
          stop
      endif

c     # Initial position traced back from (xc1,yc1)
      xc0 = sigma(1)
      yc0 = sigma(2)

c     # Our physical domain is a unit square, which is the same
c     # as our computational domain
      xp = xc0
      yp = yc0
      zp = 0

      q0 = q0_physical(xp,yp,zp)

c     # Evolve q along characteristics for variable coefficient case
      if (example .eq. 0) then
           evolve_q = .false.
      else
           evolve_q = .true.
      endif
      if (evolve_q) then
c         # Variable coefficient case
c         # We now need to evolve q along with (x,y), starting from
c         # from (xc0,yc0)
          sigma(1) = xc0
          sigma(2) = yc0
          sigma(3) = q0

          do i = 1,20
              work(i) = 0
              iwork(i) = 0
          enddo

          t0 = 0
          call dopri5(3,map_rhs_nondivfree,t0,sigma,tfinal,
     &                rtol,atol,itol,
     &                solout,iout, work,lwork,iwork,liwork,
     &                rpar,ipar,idid)

          if (idid .ne. 1) then
              write(6,*) 'DOPRI5 : idid .ne. 1'
              stop
          endif

          tol = 1e-8
          if (abs(sigma(1)-x) .gt. tol) then
              write(6,*) 'qexact.f : Did not evolve x correctly'
              write(6,100) xc0,yc0
              write(6,100) x,y
              write(6,100) sigma(1), sigma(2)
              write(6,105) abs(x-sigma(1)), abs(y-sigma(2))
              stop
          endif
          if (abs(sigma(2)-y) .gt. tol) then
              write(6,*) 'qexact.f : Did not evolve y correctly'
              write(6,100) xc0,yc0
              write(6,100) x,y
              write(6,100) sigma(1), sigma(2)
              write(6,105) abs(x-sigma(1)), abs(y-sigma(2))
              stop
          endif
100       format(2F24.16)
105       format(2E24.4)

          qexact = sigma(3)
      else
          qexact = q0
      endif

      end

c     # ---------------------------------------------------------------
      subroutine solout(nr,xold,x,y,n,con,icomp,nd,rpar,ipar,irtrn)
      dimension y(n),con(5*nd),icomp(nd)

c     # Dummy routine

      end

c     # ----------------------------------------------------------------
c     # RHS functions for ODE solver DOPRI5  (original ode45)
c     #        -- divfree field
c     #        -- field with divergence
c     # ----------------------------------------------------------------

      subroutine map_rhs_divfree(n,t,sigma,f,rpar,ipar)
      implicit none

      external velocity_components
      integer n, ipar(2)
      double precision t, sigma(n), f(n), rpar

      integer m, i
      double precision xc1,yc1, q, u1,u2, x,y
      double precision p, px, py
      double precision t1(3), t2(3), t1xt2(3), w
      double precision u(2)

      x = sigma(1)
      y = sigma(2)

      call velocity_components(x,y,u)

c     # We are tracing these back, so use negative velocities
      f(1) = -u(1)
      f(2) = -u(2)

      end

      subroutine map_rhs_nondivfree(n,t,sigma,f,rpar,ipar)
      implicit none

      integer n, ipar(2)
      double precision t, sigma(n), f(n), rpar

      double precision x,y, q
      double precision u(2)
      double precision divu, map_divergence

      double precision t1(3), t2(3), t1xt2(3), w
      double precision p,px,py

c     # Track evolution of these three quantities

      x = sigma(1)
      y = sigma(2)
      q = sigma(3)

      call velocity_components(x,y,u)

      divu = map_divergence(x,y)

      f(1) = u(1)
      f(2) = u(2)
      f(3) = -divu*q   !! Non-conservative case

      end


integer grid,gridz

real*4,allocatable ::   rho(:,:,:)

double precision ss,ss2,totval

character*80  filename

print*, ' Input densfield'

read (*,'(A)') filename

open(1,file=filename, form='unformatted',status='old')

read (1) grid,grid, gridz

allocate(rho(grid,grid,gridz))

 do kk=1,gridz
    read(1)  ((RHO(II,JJ,KK), ii=1,GRID),jj=1,GRID)
 enddo

close(1)

ss=0.

!$OMP PARALLEL DO DEFAULT (SHARED) PRIVATE(I,J,K) REDUCTION(+:ss)
do K=1,grid
   do J=1,grid
      do I=1,grid
         ss = ss + rho(i,j,k)
      enddo
   enddo
enddo

totval = float(grid)**3

ss = ss / totval

print*, ' Mean valuel=', ss

ss2=0.

!$OMP PARALLEL DO DEFAULT (SHARED) PRIVATE(I,J,K) REDUCTION(+:ss2)
do K=1,grid
   do J=1,grid
      do I=1,grid
         ss2 = (ss-rho(i,j,k))**2 + ss2
      enddo
   enddo
enddo

print*, ' Min-Max values ', Minval(rho), Maxval(rho)

ss2 = sqrt(ss2) / totval

print*, ' RMS=', ss2

stop
end


! { dg-do  run }
! { dg-options "-ffrontend-optimize -fdump-tree-optimized -Wrealloc-lhs" }
! PR 37131 - check basic functionality of inlined matmul, making
! sure that the library is not called, with and without reallocation.

program main
  implicit none
  integer, parameter :: offset = -2
  real, dimension(3,2) :: a
  real, dimension(2,4) :: b
  real, dimension(3,4) :: c
  real, dimension(3,4) :: cres
  real, dimension(:,:), allocatable :: c_alloc
  integer, parameter :: a1_lower_p = 1 + offset, a1_upper_p = size(a,1) + offset
  integer, parameter :: a2_lower_p = 1 + offset, a2_upper_p = size(a,2) + offset
  integer, parameter :: b1_lower_p = 1 + offset, b1_upper_p = size(b,1) + offset
  integer, parameter :: b2_lower_p = 1 + offset, b2_upper_p = size(b,2) + offset
  integer, parameter :: c1_lower_p = 1 + offset, c1_upper_p = size(c,1) + offset
  integer, parameter :: c2_lower_p = 1 + offset, c2_upper_p = size(c,2) + offset
  real, dimension(a1_lower_p:a1_upper_p, a2_lower_p:a2_upper_p) :: ap
  real, dimension(b1_lower_p:b1_upper_p, b2_lower_p:b2_upper_p) :: bp
  real, dimension(c1_lower_p:c1_upper_p, c2_lower_p:c2_upper_p) :: cp
  real, dimension(4,8,4) :: f, fresult
  integer :: eight = 8, two = 2

  type foo
     real :: a
     integer :: i
  end type foo

  type(foo), dimension(3,2) :: afoo
  type(foo), dimension(2,4) :: bfoo
  type(foo), dimension(3,4) :: cfoo

  data a / 2.,  -3.,  5.,  -7., 11., -13./
  data b /17., -23., 29., -31., 37., -39., 41., -47./
  data cres /195., -304.,  384.,  275., -428.,  548.,  347., -540.,  692.,  411., -640.,  816./
  data fresult / &
   0.,   0., 195.,   0.,   0.,  17.,   0.,   0.,   0., -23.,-304.,   0.,   0.,   0.,   0.,   0., &
   0.,   0., 384.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., &
   2.,   0., 275.,   0.,  -3.,  29.,   0.,   0.,   5., -31.,-428.,   0.,   0.,   0.,   0.,   0., &
   0.,   0., 548.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., &
  -7.,   0., 347.,   0.,  11.,  37.,   0.,   0., -13., -39.,-540.,   0.,   0.,   0.,   0.,   0., &
   0.,   0., 692.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., &
   0.,   0., 411.,   0.,   0.,  41.,   0.,   0.,   0., -47.,-640.,   0.,   0.,   0.,   0.,   0., &
   0.,   0., 816.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0./

  integer :: a1 = size(a,1), a2 = size(a,2)
  integer :: b1 = size(b,1), b2 = size(b,2)
  integer :: c1 = size(c,1), c2 = size(c,2)

  integer :: a1_lower, a1_upper, a2_lower, a2_upper
  integer :: b1_lower, b1_upper, b2_lower, b2_upper
  integer :: c1_lower, c1_upper, c2_lower, c2_upper

  a1_lower = 1 + offset ; a1_upper = a1 + offset
  a2_lower = 1 + offset ; a2_upper = a2 + offset
  b1_lower = 1 + offset ; b1_upper = b1 + offset
  b2_lower = 1 + offset ; b2_upper = b2 + offset
  c1_lower = 1 + offset ; c1_upper = c1 + offset
  c2_lower = 1 + offset ; c2_upper = c2 + offset

  c = matmul(a,b)
  if (sum(abs(c-cres))>1e-4) call abort

  c_alloc = matmul(a,b)      ! { dg-warning "Code for reallocating the allocatable array" }
  if (sum(abs(c_alloc-cres))>1e-4) call abort
  if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) call abort
  deallocate(c_alloc)

  allocate(c_alloc(4,4))
  c_alloc = matmul(a,b)      ! { dg-warning "Code for reallocating the allocatable array" }
  if (sum(abs(c_alloc-cres))>1e-4) call abort
  if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) call abort
  deallocate(c_alloc)

  allocate(c_alloc(3,3))
  c_alloc = matmul(a,b)      ! { dg-warning "Code for reallocating the allocatable array" }
  if (sum(abs(c_alloc-cres))>1e-4) call abort
  if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) call abort

  c_alloc = 42.
  c_alloc(:,:) = matmul(a,b)
  if (sum(abs(c_alloc-cres))>1e-4) call abort
  if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) call abort

  deallocate(c_alloc)

  ap = a
  bp = b
  cp = matmul(ap, bp)
  if (sum(abs(cp-cres)) > 1e-4) call abort

  f = 0
  f(1,1:3,2:3) = a
  f(2,2:3,:) = b
  c = matmul(f(1,1:3,2:3), f(2,2:3,:))
  if (sum(abs(c-cres))>1e-4) call abort

  f(3,1:eight:2,:) = matmul(a, b)
  if (sum(abs(f(3,1:eight:2,:)-cres))>1e-4) call abort

  afoo%a = a
  bfoo%a = b
  cfoo%a = matmul(afoo%a, bfoo%a)

  if (sum(abs(cfoo%a-cres)) > 1e-4) call abort

  block
    real :: aa(a1, a2), bb(b1, b2), cc(c1, c2)
    real :: am(a1_lower:a1_upper, a2_lower:a2_upper)
    real :: bm(b1_lower:b1_upper, b2_lower:b2_upper)
    real :: cm(c1_lower:c1_upper, c2_lower:c2_upper)

    aa = a
    bb = b
    am = a
    bm = b

    cc = matmul(aa,bb)
    if (sum(cc-cres)>1e-4) call abort
    c_alloc = matmul(aa,bb)    ! { dg-warning "Code for reallocating the allocatable array" }
    if (sum(abs(c_alloc-cres))>1e-4) call abort
    if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) call abort
    c_alloc = 42.
    deallocate(c_alloc)

    allocate(c_alloc(4,4))
    c_alloc = matmul(aa,bb)   ! { dg-warning "Code for reallocating the allocatable array" }
    if (sum(abs(c_alloc-cres))>1e-4) call abort
    if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) call abort
    deallocate(c_alloc)

    allocate(c_alloc(3,3))
    c_alloc = matmul(aa,bb)  ! { dg-warning "Code for reallocating the allocatable array" }
    if (sum(abs(c_alloc-cres))>1e-4) call abort
    if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) call abort
    deallocate(c_alloc)

    cm = matmul(am, bm)
    if (sum(abs(cm-cres)) > 1e-4) call abort

    cm = 42.

    cm(:,:) = matmul(a,bm)
    if (sum(abs(cm-cres)) > 1e-4) call abort

  end block

end program main

! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } }


PROGRAM AVRAGE
    ! This program reads in three numbers and Sums
    ! and average them.
    ! with :: we can assign variable while declaring
    IMPLICIT NONE
    REAL :: Num1, Num2, NUM3, Average, Total = 0.0
    INTEGER :: N = 3
    PRINT *, "Type three numbers"
    READ *, Num1, Num2, NUM3
    Total = Num1 + Num2 + NUM3
    Average = Total / N
    PRINT *, "Total OF  NUMBERS IS = ", Total
    PRINT *, " AVERAGE IS = ", Average
END


! { dg-do run }
!
! PR fortran/34404
!
! Contributed by Joost VandeVondele.
!
implicit none
complex :: x
character(len=80) :: t="(1.0E-7,4.0E-3)"
read(t,*) x
if (real(x) /= 1.0e-7 .or. aimag(x)/=4.0e-3) call abort()
END


program integration4

  use usermodule2

  implicit none

  real(8) :: x, y, integ, init
  real(8), dimension(2) :: step
  real(8), dimension(4) :: boundary

  call loadinput('input.dat', init, boundary, step)

  integ = init

  y = boundary(3)

  do while (y <= boundary(4))

     x = boundary(1)

     do while (x <= boundary(2))

        integ = integ + userfunc(x, y)

        x = x + step(1)

     end do

     y = y + step(2)

  end do

  call writeoutput('integration4.dat', integ, boundary, x, y)

end program integration4


! 2017, S.A. Sato, Modified the format of the code
! ----------------------------------------------------------------------------
! Numerical diagonalization of 3x3 matrcies
! Copyright (C) 2006  Joachim Kopp
! ----------------------------------------------------------------------------
! This library is free software; you can redistribute it and/or
! modify it under the terms of the GNU Lesser General Public
! License as published by the Free Software Foundation; either
! version 2.1 of the License, or (at your option) any later version.
!
! This library is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
! Lesser General Public License for more details.
!
! You should have received a copy of the GNU Lesser General Public
! License along with this library; if not, write to the Free Software
! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
! ----------------------------------------------------------------------------

! ----------------------------------------------------------------------------
      SUBROUTINE ZHEEVC3(A, W)
! ----------------------------------------------------------------------------
! Calculates the eigenvalues of a hermitian 3x3 matrix A using Cardano's
! analytical algorithm.
! Only the diagonal and upper triangular parts of A are accessed. The access
! is read-only.
! ----------------------------------------------------------------------------
! Parameters:
!   A: The hermitian input matrix
!   W: Storage buffer for eigenvalues
! ----------------------------------------------------------------------------
! Dependencies:
!   SQRABS()
! ---------------------------------------------------------------------------
!     .. Arguments ..
      COMPLEX(8)       A(3,3)
      DOUBLE PRECISION W(3)

!     .. Parameters ..
      DOUBLE PRECISION SQRT3
      PARAMETER        ( SQRT3 = 1.73205080756887729352744634151D0 )

!     .. Local Variables ..
      DOUBLE PRECISION M, C1, C0
      COMPLEX(8)       DE
      DOUBLE PRECISION DD, EE, FF
      DOUBLE PRECISION P, SQRTP, Q, C, S, PHI

!     .. External Functions ..
      DOUBLE PRECISION SQRABS
      EXTERNAL         SQRABS

!     Determine coefficients of characteristic poynomial. We write
!           | A   D   F  |
!      A =  | D*  B   E  |
!           | F*  E*  C  |
      DE    = A(1,2) * A(2,3)
      DD    = SQRABS(A(1,2))
      EE    = SQRABS(A(2,3))
      FF    = SQRABS(A(1,3))
      M     = DREAL(A(1,1)) + DREAL(A(2,2)) + DREAL(A(3,3))
      C1    = ( DREAL(A(1,1)) * DREAL(A(2,2)) &
      + DREAL(A(1,1)) * DREAL(A(3,3)) &
      + DREAL(A(2,2)) * DREAL(A(3,3)) ) &
      - (DD + EE + FF)
      C0    = DREAL(A(3,3))*DD + DREAL(A(1,1))*EE + DREAL(A(2,2))*FF &
              - DREAL(A(1,1))*DREAL(A(2,2))*DREAL(A(3,3)) &
              - 2.0D0*(DREAL(A(1,3))*DREAL(DE)+DIMAG(A(1,3))*DIMAG(DE))

      P     = M**2 - 3.0D0 * C1
      Q     = M*(P - (3.0D0/2.0D0)*C1) - (27.0D0/2.0D0)*C0
      SQRTP = SQRT(ABS(P))

      PHI   = 27.0D0 * ( 0.25D0 * C1**2 * (P - C1) &
      + C0 * (Q + (27.0D0/4.0D0)*C0) )
      PHI   = (1.0D0/3.0D0) * ATAN2(SQRT(ABS(PHI)), Q)

      C     = SQRTP * COS(PHI)
      S     = (1.0D0/SQRT3) * SQRTP * SIN(PHI)

      W(2) = (1.0D0/3.0D0) * (M - C)
      W(3) = W(2) + S
      W(1) = W(2) + C
      W(2) = W(2) - S

      END SUBROUTINE
! End of subroutine ZHEEVC3


      subroutine resid_betagd2(n_Lamx,n_beta,np1_Lamx,np1_beta,x,Nx,ck,e
     &psal,ht,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ck
      real*8 epsal
      real*8 ht
      real*8 myzero
      real*8 n_Lamx(Nx)
      real*8 n_beta(Nx)
      real*8 np1_Lamx(Nx)
      real*8 np1_beta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res
      real*8 qb
      res = 0.0D0
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = (-0.1D1 * n_beta(i) + np1_beta(i)) / ht + epsal * (-0.1D1 * n
     #_Lamx(i) + np1_Lamx(i)) / ht + 0.5000000000000000D0 * epsal * ck *
     # np1_Lamx(i) + 0.5000000000000000D0 * epsal * ck * n_Lamx(i)
      res = res + qb**2
      end do
      endif
      do i=2, Nx-1, 1
      qb = (-0.1D1 * n_beta(i) + np1_beta(i)) / ht + epsal * (-0.1D1 * n
     #_Lamx(i) + np1_Lamx(i)) / ht + 0.5000000000000000D0 * epsal * ck *
     # np1_Lamx(i) + 0.5000000000000000D0 * epsal * ck * n_Lamx(i)
      res = res + qb**2
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = np1_beta(i) + myzero * x(i)
      res = res + qb**2
      end do
      endif
      res = sqrt(res/(1*Nx))
      END