This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / 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