MINICERN/mathlib/gen/divon/intgrl.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:03:24  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10       SUBROUTINE INTGRL (NDIM,INTDEG,NPOINT,FUNINT,ERROR)
  11 C*NS  INTEGER NDIM, INTDEG, INTPNT
  12       INTEGER NDIM, INTDEG
  13       REAL ERROR
  14       COMMON /ISTRGE/ MXRGNS,ISTOR(12000)
  15       COMMON /RSTRGE/ RSTSZE,RSTOR(18001)
  16       INTEGER RSTSZE
  17       COMMON /BUKSZE/ MAXWRD
  18       INTEGER MAXWRD
  19       COMMON /TRESZE/ ENTREE,ENTBUC
  20       INTEGER ENTREE,ENTBUC
  21       COMMON /LIMITS/ GMINUS(10),GPLUS(10)
  22       COMMON /PRINT/ IPRINT
  23       COMMON /FUNN/ NFUN, NFOPT, NFCUT
  24       INTEGER NFUN, NFOPT, NFCUT
  25       COMMON /QUADRE/ DEGREE
  26       INTEGER DEGREE
  27       REAL UMINUS(10),UPLUS(10)
  28       INTEGER PARENT,PTR,NTOT,NIBUC,BUCPTR
  29       DOUBLE PRECISION FINT,ERRSQ
  30       EXTERNAL FUN
  31       IF(ENTBUC.GT.1) GOTO 20
  32       WRITE(6,10)
  33  10   FORMAT(' FUNINT CALLED BEFORE PARTN.')
  34       STOP
  35  20   IF(INTDEG.LE.1) GOTO 30
  36       IF(INTDEG.EQ.2) NFUN=NFUN+ENTBUC*(NDIM+1)
  37       IF(INTDEG.EQ.3) NFUN=NFUN+ENTBUC*2*NDIM
  38       IF(INTDEG.EQ.5) NFUN=NFUN+ENTBUC*(2*NDIM**2+1)
  39  30   ISCR=MXRGNS*(MAXWRD+1)
  40       FUNINT=0.0E+0
  41       ERROR=FUNINT
  42       BUCPTR=MXRGNS+1
  43       IF(INTDEG.NE.1) GOTO 50
  44       NTOT=NPOINT*ENTBUC
  45       J=BUCPTR+1
  46       ERRTOT=0.0E+0
  47       DO 40 I=1,ENTBUC
  48       ERRTOT=ERRTOT+SQRT(RSTOR(J))
  49       J=J+MAXWRD
  50  40   CONTINUE
  51  50   DO 180 IBUC=1,ENTBUC
  52       PARENT=1
  53       DO 60 J=1,NDIM
  54       UMINUS(J)=GMINUS(J)
  55       UPLUS(J)=GPLUS(J)
  56  60   CONTINUE
  57       CALL BOUNDS(IBUC,PARENT,ISTOR,RSTOR,UMINUS,UPLUS)
  58       IF(INTDEG.GE.0) GOTO 70
  59       CALL USRINT(UMINUS,UPLUS,RSTOR(BUCPTR),RSTOR(BUCPTR+1),RFINT,RERR
  60      1SQ)
  61       FUNINT=FUNINT+RFINT
  62       ERROR=ERROR+RERRSQ
  63       BUCPTR=BUCPTR+MAXWRD
  64       GOTO 180
  65  70   IF(DEGREE.NE.1) GOTO 80
  66       CELVOL=RSTOR(BUCPTR+6)
  67       GOTO 100
  68  80   CELVOL=1.0E+0
  69       DO 90 J=1,NDIM
  70       CELVOL=CELVOL*(UPLUS(J)-UMINUS(J))
  71  90   CONTINUE
  72  100  IF(INTDEG.LE.1) GOTO 110
  73       FUNINT=FUNINT+QUAD(NDIM,INTDEG,UMINUS,UPLUS,FUN)*CELVOL
  74       GOTO 180
  75  110  IF(INTDEG.NE.1) GOTO 120
  76       NIBUC=INT(SQRT(RSTOR(BUCPTR+1))*NTOT/ERRTOT+0.5)
  77       IF(NIBUC.GE.5) GOTO 130
  78       FUNINT=FUNINT+RSTOR(BUCPTR)
  79       ERROR=ERROR+RSTOR(BUCPTR+1)
  80       BUCPTR=BUCPTR+MAXWRD
  81       GOTO 180
  82  120  NIBUC=NPOINT
  83       CALL QUASI(XX,NDIM,NIBUC,-NPOINT)
  84  130  PTR=ISCR
  85       FINT=0.0E+0
  86       ERRSQ=FINT
  87       DO 170 J=1,NIBUC
  88       IF(INTDEG.NE.1) GOTO 140
  89       CALL RANUMS(RSTOR(PTR+1),NDIM)
  90       GOTO 150
  91  140  CALL QUASI(RSTOR(PTR+1),NDIM,1,NIBUC)
  92  150  DO 160 I=1,NDIM
  93       RSTOR(I+PTR)=(UPLUS(I)-UMINUS(I))*RSTOR(I+PTR)+UMINUS(I)
  94  160  CONTINUE
  95       F=FUN(NDIM,RSTOR(PTR+1))
  96       FINT=FINT+F
  97       IF(ABS(F).GT.1.0E-37) ERRSQ=ERRSQ+F**2
  98  170  CONTINUE
  99       FINT=FINT/NIBUC
 100       ERRSQ=ERRSQ/NIBUC
 101       ERRSQ=ERRSQ-FINT**2
 102       FINT=FINT*CELVOL
 103       ERRSQ=ERRSQ*CELVOL**2
 104       IF(INTDEG.EQ.0) ERRSQ=RSTOR(BUCPTR+1)/NIBUC
 105       ERRSQ=ERRSQ/NIBUC
 106       FUNINT=FUNINT+FINT
 107       ERROR=ERROR+ERRSQ
 108       NFUN=NFUN+NIBUC
 109       RSTOR(BUCPTR)=FINT
 110       BUCPTR=BUCPTR+MAXWRD
 111  180  CONTINUE
 112       IF(ERROR.GT.0) ERROR=SQRT(ERROR)
 113       IF(IPRINT.LE.0) GOTO 200
 114       WRITE(6,190) FUNINT,ERROR,NFUN
 115  190  FORMAT(' INTEGRAL ESTIMATE = ',G13.5,'   +/-',G13.5/1X,
 116      1 I10,' TOTAL INTEGRAND EVALUATIONS')
 117  200  RETURN
 118       END