      SUBROUTINE SINTMA (ANSWER,WORK,IFLAG)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2009-10-31 SINTMA Krogh  Initialized ACUM,PACUM,RESULT(2).
C>> 2008-01-11 SINTMA Krogh  Added new error message.
C>> 1996-03-31 SINTMA Krogh  Removed unused variable in common.
c>> 1995-11-20 SINTMA Krogh  Converted from SFTRAN to Fortran 77.
C>> 1995-11-16 SINTMA Krogh  Corrected comment.
C>> 1994-11-23 SINTMA Snyder Make recursion storage local
C>> 1994-11-14 SINTMA Krogh  Declared all vars.
c>> 1994-10-19 SINTMA Krogh  Changes to use M77CON
c>> 1994-07-07 SINTMA Snyder set up for CHGTYP.
C>> 1993-05-18 SINTMA Krogh  Changed "END" to "END PROGRAM"
c>> 1993-05-04 SINTMA Krogh  Additions for Conversion to C.
C>> 1992-04-09 SINTMA Krogh  added error message processing.
C>> 1991-09-20 SINTMA Krogh  converted '(1)' dimensioning to '(*)'.
C>> 1989-02-28 SINTMA Snyder Dimensioned MOVE
C>> 1988-04-28 SINTMA Snyder Initial code.
C
C     MULTIDIMENSIONAL QUADRATURE SUPERVISION PROGRAM.
c
c--S replaces "?": ?INTA,?INTC,?INTEC,?INTF,?INTM,?INTMA,?INTNC,?INTOP
C
C     *****     M77CON INFORMATION     *********************************
C
C     This program unit has two versions.  One will use ?COPY to
c     store the entire common block /SINTC/ in WORK.  This will work
c     in all environments where storage unit sizes follow the Fortran
c     standard: DOUBLE PRECISION uses twice as much storage as REAL, and
c     INTEGER and LOGICAL are the same size as real.  This version is
c     selected by setting STORE = WORK.
c
c     The other version has local SAVE arrays of types DOUBLE PRECISION,
c     REAL, INTEGER and LOGICAL, with enough space for DIMS+1 dimensions
c     of integration.  The default for DIMS is 5.  This version is
c     selected by setting STORE = LOCAL (or anything other than WORK).
c
c     One cannot automatically derive an extended precision version that
c     stores in WORK.
c
c++   Default STORE = LOCAL
c     DON'T SET SW, DW or SL in M77JOB !!!
c++   Default DW = {D} & STORE == WORK
c++   Default SW = {S} & STORE == WORK
c++   Default SL = ~(DW | SW)
c++   Default DIMS = 5
C
C     *****     PARAMETERS     *****************************************
c
c The following apply to the case when STORE = LOCAL:

c DIMS    is the number of dimensions for which to provide storage.
c         1 + DIMS dimensions may be integrated.
c KDBLE   is the number of double precision cells to copy.
c KINT    is the number of integer cells to copy.
c KLOG    is the number of logical cells to copy.
c KREAL   is the number of real or double precision cells to copy.
c
      integer DIMS, KDBLE, KINT, KLOG, KREAL
c++   Substitute for DIMS below
      parameter (DIMS=5, KDBLE=4, KINT=29, KLOG=11, KREAL=169)
c
C KWORK   IS THE AMOUNT OF WORKING STORAGE NEEDED FOR EVERY DIMENSION
C         OTHER THAN THE INNERMOST.  THE TOTAL SIZE OF WORK MUST BE AT
C         LEAST 3*NDIMI + KWORK*(NDIMI-1).  THE VALUE OF KWORK DEPENDS
C         ON THE MACHINE AND THE PRECISION OF THE PROGRAM, BUT FOR
C         PORTABILITY, THE USAGE SHOULD ALWAYS ASSUME THE WORST CASE FOR
C         EACH PRECISION.
C
c++   Code for ~SL is INACTIVE
c      INTEGER KWORK
c++   Code for DW is INACTIVE
c      parameter ( KWORK = KDBLE + KREAL + (KINT+KLOG+1)/2 )
c++   Code for SW is INACTIVE
c      parameter ( KWORK = 2*KDBLE + KREAL + KINT + KLOG )
c++   End
C
C     *****     FORMAL ARGUMENTS     ***********************************
C
C ANSWER  THE INTEGRAL OVER ALL DIMENSIONS WHEN THE INTEGRATION IS
C         COMPLETE.  THE INTEGRAL OVER THE INNER DIMENSIONS WHEN
C         THE INTEGRATION IS IN PROGRESS.
      REAL             ANSWER
C WORK    WORKING STORAGE AS DESCRIBED IN SINTM.
      REAL             WORK(*)
C IFLAG   INDICATES THE ACTION OR STATUS, AS DESCRIBED IN SINTM.
      INTEGER IFLAG(*)
C
C     *****     EXTERNAL REFERENCES     ********************************
C
c--       Begin mask code changes
c DCOPY   is used to copy DOUBLE PRECISION data.
c D1MACH  is used to get characteristics of DOUBLE PRECISION storage.
c I1MACH  is used to get characteristics of INTEGER storage.  We assume
c         INTEGER and LOGICAL occupy the same amount of storage.
c QCOPY   is used to copy EXTENDED PRECISION data.
c R1MACH  is used to get characteristics of REAL storage.
c SCOPY   is used to copy REAL data.
c--       End mask code changes
c
      external DCOPY
c++   Code for SL & {XQ} is INACTIVE
c      external QCOPY
c++   Code for SL & {SP} is ACTIVE
      external SCOPY
c++   Code for ~SL is INACTIVE
cc--D Next line special: S => D, X => Q, D => D
c      double precision D1MACH
cc--D Next line special: S => D, X => Q, D => D
c      external D1MACH
c      integer I1MACH
c      external I1MACH
c++   Code for SW is INACTIVE
c      real R1MACH
c      external R1MACH
c++   End
C
C     *****     LOCAL VARIABLES     ************************************
C
c NWORK   is the necessary amount of work space per dimension.
      integer NWORK
c++   Code for SL is ACTIVE
c DSAVE   is used to save variables that are DOUBLE PRECISION in all
c         versions.
c ISAVE   is used to save variables that are INTEGER.
c LC      is used for loop control.
c LSAVE   is used to save variables that are LOGICAL.
c RSAVE   is used to save variables that are REAL or DOUBLE PRECISION
c         depending on the version.
c
c--D Next line special: S => D, X => Q, D => D
      double precision DSAVE(KDBLE,DIMS)
      integer LC, ISAVE(KINT,DIMS)
      logical LSAVE(KLOG,DIMS)
      real             RSAVE(KREAL,DIMS)
      save DSAVE, ISAVE, LSAVE, RSAVE
c++   Code for ~SL is INACTIVE
cc DROUND  is the DOUBLE PRECISION round-off level.
cc FIRST   indicates whether the first call to SINTMA is in progress.
cc IBIG    is the biggest integer.
cc RROUND  is the REAL round-off level.
cc--D Next line special: S => D, X => Q, D => D
c      double precision DROUND
c      logical FIRST
c      save FIRST
c      integer IBIG
c++   Code for SW is INACTIVE
c      real             RROUND
c++   END
C
C     *****     COMMON VARIABLES     ***********************************
C
C MOVE    IS EQUIVALENCED TO ACUM.  MOVE IS USED TO PASS THE CORRECT
C         TYPE VARIABLE TO DCOPY, AND TO MAKE SINTC THE CORRECT
C         LENGTH.
c++   Code for ~SL is INACTIVE
c      REAL             MOVE(KWORK)
c++   Code for SL is ACTIVE
c DMOVE   is equivalenced to ACUM, to save DOUBLE PRECISION variables.
c IMOVE   is equivalenced to DISCF, to save INTEGER variables.
c LMOVE   is equivalenced to DID1, to save LOGICAL variables.
c RMOVE   is equivalenced to AACUM, to save variables that are REAL
c         or DOUBLE PRECISION depending on the version.
      integer IMOVE(KINT)
      logical LMOVE(KLOG)
      real             RMOVE(KREAL)
c++   Code for SL & {XQ} is INACTIVE
cc--D Next line special: S => D, X => Q, D => D, P => D
c      double precision DMOVE(KDBLE)
c++   END
C
C     THE VARIABLES BELOW ARE NOT SEPARATELY SAVED FOR EACH DIMENSION
C     OF THE INTEGRATION, OR ARE ONLY USED FOR THE MULTIDIMENSIONAL
C     QUADRATURE.  SEE SINTA FOR DESCRIPTIONS OF VARIABLES NOT
C     EXPLAINED BELOW.
C
C ERRF    IS THE ERROR COMMITTED ON AN INNER INTEGRAL.  IT IS USED AS
C         THE ESTIMATED ERROR IN THE INTEGRAND FOR AN OUTER INTEGRAL.
C FEA1    STORES THE VALUE OF FEA FOR THE INNER INTEGRAL.
C FER1    STORES THE VALUE OF FER FOR THE INNER INTEGRAL.
C IPRINT  IS THE CURRENT DIAGNOSTIC PRINT LEVEL.  SEE SINTA.
C IXKDIM  INDEX IN IFLAG (=IOPT) IN WHICH UNUSUAL DIMENSION CHANGES ARE
C         TO BE STORED.  THIS IS SET BY OPTION 12, BUT THE DEFAULT IS 1.
C JPRINT  IS AN NDIM DIGIT INTEGER SPECIFYING ALL DIAGNOSTIC PRINT
C         LEVELS.  THE LOW ORDER DIGIT IS FOR THE INNER DIMENSION.
C         SEE SINTM.
C KDIM    IS THE CURRENT DIMENSION.
C NDIM    IS THE NUMBER OF DIMENSIONS.
C NFMAXM  IS THE TOTAL NUMBER OF FUNCTION VALUES ALLOWED IN THE INNER
C         INTEGRAL.  BY CONTRAST, NFMAX IS THE NUMBER OF FUNCTION VALUES
C         ALLOWED ON A SINGLE ITERATION OF THE INNER INTEGRAL.
C NXKDIM  INDEX-1 OF THE DIMENSION TO RESUME WHEN CALCULATION OF THE
C         INTEGRAL OVER THE CURRENT DIMENSION IS COMPLETE.  NXKDIM IS
C         USUALLY KDIM, BUT MAY BE DIFFERENT IF THE USER MAKES UNUSUAL
C         DIMENSION CHANGES.
C REVERM  IS THE USERS SELECTION OF REVERSE COMMUNICATION.
C REVERS  IS THE REVERSE COMMUNICATION FLAG FOR SINTA.
C WHEREM  IS USED AS A COMPUTED GO TO INDEX IF REVERM IS NON-ZERO.
C
C     COMMON /SINTNC/ CONTAINS VARIABLES NOT SEPARATELY SAVED FOR
C     EACH DIMENSION OF A MULTIPLE QUADRATURE.  COMMON /SINTC/
C     CONTAINS VARIABLES THAT MUST BE SAVED FOR EACH DIMENSION OF THE
C     QUADRATURE.  THE VARIABLES IN EACH COMMON BLOCK ARE STORED IN THE
C     ORDER - ALWAYS DOUBLE, DOUBLE IF DOUBLE PRECISION PROGRAM, DOUBLE
C     IF DOUBLE PRECISION PROGRAM AND EXPONENT RANGE OF DOUBLE AND
C     SINGLE VERY DIFFERENT, SINGLE, INTEGER, LOGICAL.  A PAD OF LOGICAL
C     VARIABLES IS INCLUDED AT THE END OF /SINTC/.  THE DIMENSION OF
C     THE PAD MAY NEED TO BE VARIED SO THAT NO VARIABLES BEYOND THE END
C     OF THE COMMON BLOCK ARE ALTERED.
C
C     DECLARATIONS OF COMMON /SINTNC/ VARIABLES.
C
      REAL             AINIT, BINIT, FNCVAL, S, TP
      REAL             FER, FER1, RELOBT, TPS, XJ, XJP
      INTEGER     FEA,       FEA1,      INC,       INC2,      IPRINT,
     1 ISTOP(2,2),JPRINT,    KDIM,      KK,        KMAXF,     NDIM,
     2 NFINDX,    NFMAX,     NFMAXM,    RELTOL,    REVERM,    REVERS,
     3 WHEREM
      LOGICAL NEEDH
C
C     DECLARATIONS OF COMMON /SINTC/ VARIABLES.
C
c--D Next line special: S => D, X => Q, D => D, P => D
      DOUBLE PRECISION ACUM, PACUM, RESULT(2)
C     139 $.TYPE.$ VARIABLES
      REAL
     1 AACUM,     ABSCIS,    DELMIN,    DELTA,     DIFF,      DISCX(2),
     2 END(2),    ERRINA,    ERRINB,    FAT(2),    FSAVE,
     3 FUNCT(24), F1,        F2,        LOCAL(4),  PAACUM,    PF1,
     4 PF2,       PHISUM,    PHTSUM,    PX,        SPACE(6),
     5 STEP(2),   START(2),  SUM,       T,         TA,        TASAVE,
     6 TB,        TEND,      WORRY(2),  X,         X1,
     7 X2,        XT(17),    FT(17),    PHI(34)
c Note XT, FT, and PHI above are last, because they must be in adjacent
c locations in SINTC.
C     30 $DSTYP$ VARIABLES
      REAL
     1 ABSDIF,    COUNT,     EDUE2A,    EDUE2B,    EP,        EPNOIZ,
     2 EPS,       EPSMAX,    EPSMIN,    EPSO,      EPSR,      EPSS,
     3 ERR,       ERRAT(2),  ERRC,      ERRF,      ERRI,      ERRT(2),
     4 ESOLD,     EXTRA,     PEPSMN,    RE,        RELEPS,    REP,
     5 REPROD,    RNDC,      TLEN,      XJUMP
C     29 INTEGER VARIABLES
      INTEGER     DISCF,     DISCHK,    ENDPTS,    I,         INEW,
     1 IOLD,      IP,        IXKDIM,    J,         J1,        J1OLD,
     2 J2,        J2OLD,     K,         KAIMT,     KMAX,      KMIN,
     3 L,         LENDT,     NFEVAL,    NFJUMP,    NSUB,      NSUBSV,
     4 NXKDIM,    PART,      SEARCH,    TALOC,     WHERE,     WHERE2
C     11 TO 18 LOGICALS (7 ARE PADDING).
      LOGICAL     DID1,      FAIL,      FATS(2),   FSAVED,    HAVDIF,
     1 IEND,      INIT,      ROUNDF,    XCDOBT(2), PAD(7)
C
C     THE COMMON BLOCKS.
C
      COMMON /SINTNC/
c        1       2       3     4        5       6       7        8
     W AINIT,  BINIT,  FNCVAL, S,      TP,     FER,    FER1,   RELOBT,
c       9      10       11      12      13       1       2        3
     X TPS,    XJ,     XJP,    FEA,    FEA1,   KDIM,    INC,    INC2,
c     4 (2,2)    8       9     10       11      12       13      14
     Y ISTOP,  JPRINT, IPRINT, KK,     KMAXF,  NDIM,   NFINDX, NFMAX,
c        15     16       17      18      19      20
     Z NFMAXM, RELTOL, REVERM, REVERS, WHEREM, NEEDH
      COMMON /SINTC/
     1 ACUM,   PACUM,  RESULT
      COMMON /SINTC/
c        1     2 (4)     6      7        8       9      10     11 (2)
     1 AACUM,  LOCAL,  ABSCIS, TA,     DELTA,  DELMIN, DIFF,   DISCX,
c     13 (2)     15      16    17 (2)   19     20 (24) 44
     2 END,    ERRINA, ERRINB, FAT,    FSAVE,  FUNCT,  F2,
c       45      46     47       48      49     50      51 (6)
     3 PAACUM, PF1,    PF2,    PHISUM, PHTSUM, PX,     SPACE,
c      57 (2)  59 (2)   61     62        63    64       65
     4 STEP,   START,  SUM,    T,      TASAVE, TB,     TEND,
c      66 (2)  68      69      70      71       72
     5 WORRY,  X1,     X2,     X,      F1,     COUNT,
c      73 (17) 90 (17) 107 (34)
     6 XT,     FT,     PHI
      COMMON /SINTC/
c       141     142    143     144      145     146
     1 ABSDIF, EDUE2A, EDUE2B, EP,     EPNOIZ, EPSMAX,
c       147     148     149    150 (2)  152     153
     2 EPSO,   EPSR,   EPSS,   ERRAT,  ERRC,   ERRF,
c     154 (2)   156     157     158     159    160
     3 ERRT,   ESOLD,  EXTRA,  PEPSMN, RELEPS, REP,
c       161     162     163
     4 RNDC,   TLEN,   XJUMP,
c       164    165      166    167    168       169
     5 ERRI,   ERR,    EPSMIN, EPS,    RE,     REPROD
      COMMON /SINTC/
c       170     171     172
     1 DISCF,  DISCHK, ENDPTS, INEW,   IOLD,   IP,     IXKDIM,
     2 J,      J1,     J1OLD,  J2,     J2OLD,  KMAX,   KMIN,
     3 L,      LENDT,  NFJUMP, NSUBSV, NXKDIM, TALOC,  WHERE2,
c      1       2          3      4       5         6      7       8
     4 I,      K,      KAIMT,  NSUB,   PART,   SEARCH, WHERE, NFEVAL
      COMMON /SINTC/
     1 DID1,   FAIL,   FATS,   FSAVED, HAVDIF, IEND,   INIT,   ROUNDF,
     2 XCDOBT, PAD
      SAVE /SINTNC/, /SINTC/
C
C     THE VARIABLES HERE DEFINE THE MACHINE ENVIRONMENT.  ALL ARE SET
C     IN SINTOP.  THE MEANING ATTACHED TO THESE VARIABLES CAN BE
C     FOUND BY LOOKING AT THE DEFINITIONS IN SINTOP.
      REAL
     1  EMEPS,  EEPSM8, EDELM2, EDELM3, ESQEPS, ERSQEP, ERSQE6, EMINF,
     2  ESMALL, ENZER,  EDELM1, ENINF
      COMMON /SINTEC/
     1  EMEPS,  EEPSM8, EDELM2, EDELM3, ESQEPS, ERSQEP, ERSQE6, EMINF,
     2  ESMALL, ENZER,  EDELM1, ENINF
      SAVE /SINTEC/
C
C     *****     EQUIVALENCE STATEMENTS     *****************************
C
c++   Code for ~SL is INACTIVE
c      EQUIVALENCE (ACUM, MOVE)
c++   Code for SL is ACTIVE
      equivalence (AACUM, RMOVE)
      equivalence (DISCF, IMOVE)
      equivalence (DID1, LMOVE)
c++   Code for SL & {XQ} is INACTIVE
c      equivalence (ACUM, DMOVE)
c++   End
C
C     *****    Statements for Processing Messages **********************
C
      INTEGER MERET, MEEMES
      PARAMETER (MERET  =51)
      PARAMETER (MEEMES =52)
      INTEGER MACT(5), IDAT(3)
c ********* Error message text ***************
c[Last 2 letters of Param. name]  [Text generating message.]
cAA SINTMA$B
cAB NWORK = $I, needs to be at least $I, for NDIM = $I.$E
cAC Since you are using reverse communication you probably $C
c   forgot to exit when IOPT(1) + NDIM was .le. 0$E
cAD $I = IFLAG($I) should be an inner integral dimension $C
c   in the interval [1,$I].$E
      integer LTXTAA,LTXTAB,LTXTAC,LTXTAD
      parameter (LTXTAA=  1,LTXTAB=  9,LTXTAC= 62,LTXTAD=164)
      character MTXTAA(1) * (242)
      data MTXTAA/'SINTMA$BNWORK = $I, needs to be at least $I, for NDIM
     * = $I.$ESince you are using reverse communication you probably for
     *got to exit when IOPT(1) + NDIM was .le. 0$E$I = IFLAG($I) should$
     * be an inner integral dimension in the interval [1,$I].$E'/
c **** End of automatically generated text
      DATA MACT / MEEMES, 88, 0, 0, MERET /
c
c     *****     DATA Statement     *************************************
c
c++   Code for ~SL is INACTIVE
c      data FIRST /.TRUE./
c++   End
C
C     *****     PROCEDURES     *****************************************
C
      IF (WHEREM.NE.0) THEN
        GO TO (90,75,30), WHEREM
      end if
C
C     OUTERMOST DIMENSION.
C
c++   Code for SL is ACTIVE
      nwork = 0
c++   Code for ~SL is INACTIVE
c      if (first) then
c        first = .false.
cc--D Next line special: S => D, X => Q, D => D
c        dround = d1mach(4)
c        ibig = i1mach(9)
c++   Code for SW is INACTIVE
c        rround = r1mach(4)
c        if (rround .ge. 0.875*dround) then
c          nwork = kdble + kreal
c        else
c          nwork = 2*kdble + kreal
c        end if
c        if (ibig * rround .ge. 0.125) then
c          nwork = nwork + kint + klog
c        else
c          nwork = nwork + (kint + klog + 1) / 2
c        end if
c++   Code for DW is INACTIVE
c        if (ibig * dround .ge. 0.125) then
c          nwork = kdble + kreal + kint + klog
c        else
c          nwork = kdble + kreal + (kint + klog + 1) / 2
c        end if
c      end if
c++   End
      IDAT(2) = NWORK*(NDIM-1)+3*NDIM
      IF (KDIM.LT.IDAT(2)) THEN
         IFLAG(1)=-NDIM-3
         if ((REVERM .ne. 0) .and. (KDIM .ge. NDIM)) then
           MACT(4) = LTXTAC
         else
           MACT(4) = LTXTAB
         end if
         IDAT(1) = KDIM
         IDAT(3) = NDIM
         GO TO 118
      END IF
      KDIM=NDIM
      FEA1=FEA
      FER1=FER
      IF (NFINDX.NE.0) IFLAG(NFINDX)=0
      GO TO 25
C
C     ASK FOR LIMITS OF THE KDIMTH DIMENSION.
C
20    TALOC=0
25    WHEREM=3
      IFLAG(1)=KDIM
      IFLAG(IXKDIM)=KDIM
      WORK(1)=1.0e0
      ERRINA=0.0e0
      ERRINB=0.0e0
      NFEVAL=1
C     NFEVAL IS TESTED IN SINTOP.  SINTF MAY CALL SINTOP.
C  Intialize ACUM,PACUM,RESULT(2) to avoid diagnostics.
      ACUM = 0.E0
      PACUM = 0.E0
      RESULT(2) = 0.E0

      IF (REVERM.NE.0) RETURN
      CALL SINTF (ANSWER,WORK,IFLAG(1))
30    IF (ABS(IFLAG(1)).GT.NDIM) TALOC=IFLAG(1)
      WHERE=0
      IF (KDIM.NE.NDIM) THEN
C        WE CAN USE EPS HERE BECAUSE SINTA WILL CHANGE IT BEFORE USE
         EPS=ABS((WORK(NDIM+KDIM+1)-WORK(2*NDIM+KDIM+1))*WORK(1))
         EPS=MAX(EPS,MAX(EPSO*ESMALL,ESMALL))
         EPSO=EPSO/EPS
         IF (ABS(IFLAG(1)).LE.NDIM .AND. IFLAG(IXKDIM).LE.NDIM) THEN
            IF (IFLAG(IXKDIM).LT.1 .OR. IFLAG(IXKDIM).GT.KDIM) GO TO 115
C           INNER DIMENSION MAY BE LESS THAN EXPECTED.
            KDIM=IFLAG(IXKDIM)
         END IF
      END IF
50    IPRINT=MOD(JPRINT/10**(KDIM-1),10)
      AINIT=WORK(NDIM+KDIM)
      BINIT=WORK(2*NDIM+KDIM)
      IF (KDIM.EQ.1) THEN
         FEA=FEA1
         FER=FER1
         IF (NFINDX.NE.0) NFEVAL=IFLAG(NFINDX)
         NFMAX=NFMAXM
         REVERS=REVERM
      ELSE
         FEA=1
         FER=EMEPS
c        FER=EFERVL
c        EFERVL was EMEPS in single precision, and 8*EMEPS in double
         NFMAX=0
         REVERS=1
      END IF
      IFLAG(1)=0
C     TEST IFLAG(1) IN CASE REVERSE COMMUNICATION IS IN EFFECT, AND THE
C     CALLING PROGRAM IS ITERATING CALLS TO SINTA.
75    IF (IFLAG(1).LT.0) GO TO 80
      CALL SINTA (ANSWER,WORK(1),IFLAG)
      IF (IFLAG(1)) 80,100,110
C
C     FINISHED WITH INTEGRAL OF KDIMTH DIMENSION.
C
80    IF (KDIM.EQ.NDIM) GO TO 120
85    WHEREM=1
      IFLAG(1)=-KDIM
      IFLAG(IXKDIM)=-KDIM
      IF (REVERM.NE.0) RETURN
      CALL SINTF (ANSWER,WORK,IFLAG(1))
C     *****     ITERATE ON INNER INTEGRALS IF NECESSARY HERE     *******
90    CONTINUE
      KDIM=NXKDIM
      IF (IFLAG(IXKDIM).GE.0) THEN
         IF (IFLAG(IXKDIM).GT.NXKDIM) GO TO 115
         KDIM=IFLAG(IXKDIM)
C        INTEGRAND IS A FUNCTION OF MORE INTEGRALS.
         GO TO 20
      END IF
c++   Code for DW is INACTIVE
c      CALL DCOPY (KWORK,WORK(3*NDIM+KWORK*KDIM-KWORK+1),1,MOVE,1)
c++   Code for SW is INACTIVE
c      CALL SCOPY (KWORK,WORK(3*NDIM+KWORK*KDIM-KWORK+1),1,MOVE,1)
c++   Code for SL & {XQ} is INACTIVE
c      call qcopy (kdble, dsave(1,kdim), 1, dmove, 1)
c++   Code for SL & (~{XQ}) is ACTIVE
      acum = dsave(1,kdim)
      pacum = dsave(2,kdim)
      result(1) = dsave(3,kdim)
      result(2) = dsave(4,kdim)
c++   Code for SL & {Q} is INACTIVE
c      call qcopy (kreal, rsave(1,kdim), 1, rmove, 1)
c++   Code for SL & {XD} is INACTIVE
C      call dcopy (kreal, rsave(1,kdim), 1, rmove, 1)
c++   Code for SL & {PS} is ACTIVE
      call scopy (kreal, rsave(1,kdim), 1, rmove, 1)
c++   Code for SL is ACTIVE
      do 93 lc = 1, kint
        imove(lc) = isave(lc,kdim)
93    continue
      do 94 lc = 1, klog
        lmove(lc) = lsave(lc,kdim)
94    continue
c++   End
      KDIM=KDIM+1
      GO TO 50
C
C     NEED A FUNCTION VALUE FOR THE KDIMTH DIMENSION.
C
100   WHEREM=2
      IF (KDIM.EQ.1) RETURN
      KDIM=KDIM-1
c++   Code for DW is INACTIVE
c      CALL DCOPY (KWORK,MOVE,1,WORK(3*NDIM+KWORK*KDIM-KWORK+1),1)
c++   Code for SW is INACTIVE
c      CALL SCOPY (KWORK,MOVE,1,WORK(3*NDIM+KWORK*KDIM-KWORK+1),1)
c++   Code for SL & {XQ} is INACTIVE
c      call qcopy (kdble, dmove, 1, dsave(1,kdim), 1)
c++   Code for SL & (~{XQ}) is ACTIVE
      dsave(1,kdim) = acum
      dsave(2,kdim) = pacum
      dsave(3,kdim) = result(1)
      dsave(4,kdim) = result(2)
c++   Code for SL & {Q} is INACTIVE
c      call qcopy (kreal, rmove, 1, rsave(1,kdim), 1)
c++   Code for SL & {XD} is INACTIVE
C      call dcopy (kreal, rmove, 1, rsave(1,kdim), 1)
c++   Code for SL & {PS} is ACTIVE
      call scopy (kreal, rmove, 1, rsave(1,kdim), 1)
c++   Code for SL is ACTIVE
      do 103 lc = 1, kint
        isave(lc,kdim) = imove(lc)
103   continue
      do 104 lc = 1, klog
        lsave(lc,kdim) = lmove(lc)
104   continue
c++   End
      NXKDIM=KDIM
      GO TO 20
C
C     ERROR.
C
110   CONTINUE
      IF (KDIM.NE.NDIM) THEN
         IF (IFLAG(1).EQ.6) THEN
C           NON-INTEGRABLE SINGULARITY IN INNER INTEGRAL.  USE ALMOST
C           MACHINE INFINITY WITH THE SIGN OF ACUM FOR THE ANSWER, AND
C           ALMOST MACHINE INFINITY FOR THE ERROR ESTIMATE.
C           THE "SIGN" FUNCTION WANTS ITS ARGUMENTS TO BE THE SAME TYPE.
            ANSWER=ACUM
            ANSWER=SIGN(ENINF,ANSWER)
            WORK(1)=ENINF
            GO TO 85
         END IF
      END IF
      WHEREM=2
      IF (IFLAG(1).NE.5) WHEREM=0
      IFLAG(1)=-NDIM-IFLAG(1)
      GO TO 130
C
C     ERRONEOUS INNER INTEGRAL DIMENSIONALITY.
C
 115  MACT(4) = LTXTAD
      IDAT(3) = KDIM
      IDAT(2) = IXKDIM
      IDAT(1) = IFLAG(IXKDIM)
      IFLAG(1)=-NDIM-NDIM-KDIM-5
c                                  Print an error message and stop.
118   MACT(3) = IFLAG(1)
      call MESS(MACT, MTXTAA, IDAT)
      GO TO 130
C
C     NORMAL COMPLETION.
C
120   IFLAG(1)=-(NDIM-(IFLAG(1)+1))
      WHEREM=0
130   CONTINUE
      RETURN
C
      END
