MINICERN/mathlib/gen/divon/exmbuc.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       INTEGER FUNCTION EXMBUC(NUMBER, NDIM, BUCKTS, GOOD, MAXFUN, MAXDPH
  11      1, IRM)
  12       INTEGER NUMBER, NDIM, MAXFUN, MAXDPH
  13       REAL GOOD, BUCKTS(IRM)
  14       COMMON /PRINT/ IPRINT
  15       INTEGER IPRINT
  16       COMMON /ANSWER/ INTGRL,ERROR,ERRMAX,GEFF,Q2,Q3,Q5,NUMBR,MBUC
  17       COMMON /DEPTHS/ FSTDPH,INCDPH
  18       INTEGER FSTDPH,INCDPH,NTREES
  19       REAL INTGRL,VAR,ERROR,ERRMAX,VARMAX,VARMX2,PRCNT
  20       REAL Q2,Q3,Q5,GEFF,SEFF,FMAX,FMIN,TOTVOL
  21       COMMON /QUADRE/ DEGREE
  22       INTEGER DEGREE
  23       COMMON /MAXERR/ ERRPCT,ERRABS
  24       REAL ERRPCT,ERRABS
  25       COMMON /FUNN/ NFUN, NFOPT, NFCUT
  26       INTEGER NFUN, NFOPT, NFCUT
  27       COMMON /SIGSPL/ COORD,PLACE,FSTENT,DOSPLT
  28       COMMON /BUKSZE/ MAXWRD
  29       INTEGER MAXWRD
  30       COMMON /LIMITS/ GMINUS(10),GPLUS(10)
  31       LOGICAL FSTENT,DOSPLT,UTERM,USRTRM
  32       REAL COORD,PLACE
  33       INTEGER NUMBR,PTR
  34       NUMBR=NUMBER
  35       IF(NUMBER.NE.1) GOTO 40
  36       NTREES=0
  37       ERRPCT=GOOD
  38       ERRABS=0
  39       MAXDPH=FSTDPH
  40       FSTENT=.TRUE.
  41       NFUN=0
  42       NFOPT=0
  43       NFCUT=0
  44       DOSPLT=.FALSE.
  45       GUUD=ABS(GOOD)
  46       IF(GOOD.GE.0) GOTO 10
  47       ERRABS=GUUD
  48       ERRPCT=0
  49  10   IF(DEGREE.NE.1.AND.DEGREE.NE.2.AND.DEGREE.NE.3.AND.DEGREE.NE.5)
  50      1 DEGREE=0
  51       IF(DEGREE.NE.1) GOTO 30
  52       TOTVOL=1.0E+0
  53       DO 20 I=1,NDIM
  54       TOTVOL=TOTVOL*(GPLUS(I)-GMINUS(I))
  55  20   CONTINUE
  56  30   EXMBUC=0
  57       RETURN
  58  40   NTREES=NTREES+1
  59       MBUC=0
  60       PTR=MBUC
  61       INTGRL=0.0E+0
  62       VAR=INTGRL
  63       VARMAX=VAR
  64       VARMX2=VARMAX
  65       Q2=VARMX2
  66       Q3=Q2
  67       Q5=Q3
  68       GEFF=Q5
  69       FMAX=GEFF
  70       FMIN=FMAX
  71       DO 80 IBUC=1,NUMBER
  72       INTGRL=INTGRL+BUCKTS(PTR+1)
  73       VAR=VAR+BUCKTS(PTR+2)
  74       IF(BUCKTS(PTR+2).LE.VARMAX) GOTO 50
  75       VARMX2=VARMAX
  76       VARMAX=BUCKTS(PTR+2)
  77       MBUC=IBUC
  78       GOTO 60
  79  50   IF(BUCKTS(PTR+2).LE.VARMX2) GOTO 60
  80       VARMX2=BUCKTS(PTR+2)
  81  60   IF(DEGREE.NE.1) GOTO 70
  82       GEFF=GEFF+(BUCKTS(PTR+5)-BUCKTS(PTR+6))*BUCKTS(PTR+7)
  83       FMAX=MAX(FMAX,BUCKTS(PTR+5))
  84       FMIN=MIN(FMIN,BUCKTS(PTR+6))
  85  70   IF(DEGREE.GE.2) Q2=Q2+BUCKTS(PTR+5)
  86       IF(DEGREE.GE.3) Q3=Q3+BUCKTS(PTR+6)
  87       IF(DEGREE.EQ.5) Q5=Q5+BUCKTS(PTR+7)
  88       PTR=PTR+MAXWRD
  89  80   CONTINUE
  90       ERROR=SQRT(VAR)
  91       ERRMAX=SQRT(VARMAX)
  92       IF(DEGREE.EQ.1) GEFF=INTGRL/GEFF
  93       IF(GOOD.LE.0) GOTO 100
  94       IF(INTGRL.EQ.0.0E+0) GOTO 90
  95       PRCNT=ERROR/ABS(INTGRL)
  96       GOTO 110
  97  90   PRCNT=0.0E+0
  98       GOTO 110
  99  100  PRCNT=ERROR
 100  110  UTERM=USRTRM(NTREES)
 101       IF(IPRINT.LE.0) GOTO 220
 102       IF(MOD(NTREES,IPRINT).NE.0 .AND. NFUN.LT.MAXFUN .AND. PRCNT.GT
 103      1.GUUD .AND. .NOT.UTERM) GOTO 220
 104       WRITE(6,120) NTREES,NUMBER,INTGRL,ERROR,ERRMAX,MBUC
 105  120  FORMAT(///' ITERATION ',I5,'.',I10,' REGIONS'/
 106      1 ' APPROXIMATE INTEGRAL = ',G13.5,'  WITH TOTAL RSS SPREAD ',
 107      2 G13.5/' THE LARGEST SINGLE SPREAD IS ',G13.5,
 108      3 '  IN REGION ',I5)
 109       IF(DEGREE.NE.1) GOTO 140
 110       SEFF=INTGRL/((FMAX-FMIN)*TOTVOL)
 111       WRITE(6,130) GEFF,SEFF
 112   130 FORMAT(' ESTIMATED RANGEN EFFICIENCY =',G13.5/
 113      *' SIMPLE ACCEPT/REJECT =',G13.5)
 114  140  IF(DEGREE.LT.2) GOTO 160
 115       WRITE(6,150) Q2
 116  150  FORMAT(' 2ND DEGREE QUADRATURE =  ',G13.5)
 117  160  IF(DEGREE.LT.3) GOTO 180
 118       WRITE(6,170) Q3
 119  170  FORMAT(' 3RD DEGREE QUADRATURE =  ',G13.5)
 120  180  IF(DEGREE.NE.5) GOTO 200
 121       WRITE(6,190) Q5
 122  190  FORMAT(' 5TH DEGREE QUADRATURE =  ',G13.5)
 123  200  WRITE(6,210) NFUN,NFOPT,NFCUT
 124  210  FORMAT(1X,I10,' INTEGRAND EVALUATIONS SO FAR'/1X,I10,
 125      1 ' IN OPTIMIZATION, ',I10,' IN FINDING CUTS')
 126  220  IF(NFUN.LT.MAXFUN) GOTO 250
 127       IF(IPRINT.LE.0) GOTO 240
 128       WRITE(6,230) MAXFUN
 129  230  FORMAT(' THIS EXCEEDES SPECIFIED LIMIT OF',I10)
 130  240  EXMBUC=0
 131       RETURN
 132  250  IF(PRCNT.GT.GUUD) GOTO 280
 133       IF(IPRINT.LE.0) GOTO 270
 134       WRITE(6,260) ERROR
 135  260  FORMAT(' TOTAL RSS SPREAD ',G13.5,' IS BELOW SPECIFIED MAXIMUM')
 136  270  EXMBUC=0
 137       RETURN
 138  280  IF(.NOT.(UTERM)) GOTO 310
 139       IF(IPRINT.LE.0) GOTO 300
 140       WRITE(6,290)
 141  290  FORMAT(' USER REQUESTED TERMINATION')
 142  300  EXMBUC=0
 143       RETURN
 144  310  EXMBUC=MBUC
 145       MAXDPH=INCDPH
 146       ERRABS=SQRT(VARMX2)
 147       DOSPLT=.TRUE.
 148       PTR=MAXWRD*(MBUC-1)
 149       COORD=BUCKTS(PTR+3)
 150       PLACE=BUCKTS(PTR+4)
 151       RETURN
 152       END