JIMMY first commit.
[u/mrichter/AliRoot.git] / HERWIG / jimmy / divon4 / split.F
1 *CMZ :          04/09/93  17.07.27  by  Jonathan Butterworth
2 *-- Author :
3       SUBROUTINE SPLIT (NDIM,UMINUS,UPLUS,FLOBD,FUPBD,TERMNL,DISCRM,PART
4      1N,BUCKTS,IRBUC)
5       INTEGER NDIM, DISCRM, IRBUC
6       LOGICAL TERMNL
7       REAL FLOBD, FUPBD, PARTN
8       REAL UMINUS(NDIM), UPLUS(NDIM), BUCKTS(IRBUC)
9       INTEGER MPOINT
10       COMMON /SAMPLE/ MPOINT
11       INTEGER MAXWRD
12       COMMON /BUKSZE/ MAXWRD
13       REAL ERRPCT, ERRABS
14       COMMON /MAXERR/ ERRPCT, ERRABS
15       INTEGER NFUN, NFOPT, NFCUT
16       COMMON /FUNN/ NFUN, NFOPT, NFCUT
17       LOGICAL FSTENT, DOSPLT
18       REAL COORD, PLACE
19       COMMON /SIGSPL/ COORD, PLACE, FSTENT, DOSPLT
20       INTEGER DEGREE
21       COMMON /QUADRE/ DEGREE
22       INTEGER MXRGNS, ISTOR
23       COMMON /ISTRGE/ MXRGNS, ISTOR(12000)
24       INTEGER RSTSZE
25       REAL RSTOR
26       COMMON /RSTRGE/ RSTSZE,RSTOR(18001)
27       REAL BNDTOL, FRACT, REGNTL, FNLTOL
28       COMMON /CUTOLS/ BNDTOL, FRACT, REGNTL, FNLTOL
29       INTEGER MAJOR, MINOR
30       INTEGER ICUT(20), IWORK(20)
31       INTEGER DCMSVE(20)
32       INTEGER MAXJ, MINJ, NPOINT, NFCNT
33       INTEGER DISCNT
34       INTEGER NCUT
35       EXTERNAL FUN
36       LOGICAL LMAX
37       REAL DIFEXT
38       REAL X(10, 202), Y(202)
39       REAL PARSVE(20)
40 C*NS  REAL DEVMAX, DEVMIN, YMAX, YMIN, SUM, CELVOL, YBAR, ERROR, ERRSQ
41 C*NS  DOUBLE PRECISION DPARTN, DFLOAT, DBNDTL, DFRACT, DREGTL, DFNLTL
42       REAL         DEVMIN, YMAX, YMIN,      CELVOL, YBAR, ERROR, ERRSQ
43       DOUBLE PRECISION DPARTN,         DBNDTL, DFRACT, DREGTL, DFNLTL
44       DOUBLE PRECISION FMAJOR, FMINOR, VOL
45       DOUBLE PRECISION DELPLS(10), DELNEG(10)
46       DOUBLE PRECISION XLOW(10), XUP(10)
47       DOUBLE PRECISION Z(10), WORK(200)
48       DATA DISCNT /0/
49       DATA NCUT /0/
50 * JMB
51       SAVE
52       IF(.NOT.(DOSPLT)) GOTO 10
53       DOSPLT=.FALSE.
54       FSTENT=DOSPLT
55       DISCRM=COORD
56       PARTN=PLACE
57       RETURN
58  10   IF(NCUT.EQ.0) GOTO 20
59       DISCRM=DCMSVE(NCUT)
60       PARTN=PARSVE(NCUT)
61       NCUT=NCUT-1
62       DOSPLT=.FALSE.
63       FSTENT=DOSPLT
64       TERMNL=FSTENT
65       RETURN
66  20   ISCR=MXRGNS*(MAXWRD+1)+1
67       NPOINT=MPOINT
68       CALL QUASI(X,NDIM,NPOINT,MPOINT)
69       DO 40 J=1,NPOINT
70       DO 30 I=1,NDIM
71       X(I,J)=(UPLUS(I)-UMINUS(I))*X(I,J)+UMINUS(I)
72  30   CONTINUE
73       Y(J)=FUN(NDIM,X(1,J))
74  40   CONTINUE
75       NFUN=NFUN+NPOINT
76       CELVOL=1.0E+0
77       DO 50 I=1,NDIM
78       CELVOL=CELVOL*(UPLUS(I)-UMINUS(I))
79  50   CONTINUE
80       YMAX= -9.9E34
81       YMIN=  9.9E34
82       DO 70 J=1,NPOINT
83       IF(Y(J).GE.YMIN) GOTO 60
84       YMIN=Y(J)
85       MINJ=J
86  60   IF(Y(J).LE.YMAX) GOTO 70
87       YMAX=Y(J)
88       MAXJ=J
89  70   CONTINUE
90       DO 80 I=1,NDIM
91       X(I,NPOINT+1)=X(I,MAXJ)
92       X(I,NPOINT+2)=X(I,MINJ)
93  80   CONTINUE
94       Y(NPOINT+1)=YMAX
95       Y(NPOINT+2)=YMIN
96       CALL BUFOPT(NDIM,X(1,NPOINT+2),X(1,NPOINT+1),UMINUS,UPLUS,Y(NPOIN
97      1T+2),Y(NPOINT+1),FLOBD,FUPBD,WORK,200,IWORK,20,NFCNT,IRESLT)
98       NFUN=NFUN+NFCNT
99       NFOPT=NFOPT+NFCNT
100       DIFEXT=Y(NPOINT+1)-Y(NPOINT+2)
101       ERROR=DIFEXT*CELVOL*0.5E+0
102       YBAR=0.0E+0
103       DO 90 I=1,NPOINT
104       YBAR=YBAR+Y(I)
105  90   CONTINUE
106       YBAR=YBAR/NPOINT
107       IF (YBAR.LT.1.E-36) YBAR=0.E+0
108       FBAR=YBAR*CELVOL
109       IF(ABS(Y(NPOINT+2)-YBAR).LE.ABS(Y(NPOINT+1)-YBAR)) GOTO 100
110       MAJOR=NPOINT+2
111       MINOR=NPOINT+1
112       GOTO 110
113  100  MAJOR=NPOINT+1
114       MINOR=NPOINT+2
115  110  FMAJOR=Y(MAJOR)
116       FMINOR=Y(MINOR)
117       I=1
118       GOTO 130
119  120  I=I+1
120  130  IF((I).GT.(NDIM)) GOTO 140
121       Z(I)=X(I,MAJOR)
122       GOTO 120
123  140  I=1
124       GOTO 160
125  150  I=I+1
126  160  IF((I).GT.(NDIM)) GOTO 170
127       XLOW(I)=UMINUS(I)
128       XUP(I)=UPLUS(I)
129       GOTO 150
130  170  NCDIM=2*NDIM
131       DFRACT=FRACT
132       DBNDTL=BNDTOL
133       CALL TSTEXT(NDIM,Z,XLOW,XUP,DBNDTL,DFRACT,NCUT,NCDIM,ICUT,DELPLS,
134      1DELNEG)
135       IF(NCUT.NE.0) GOTO 180
136       CALL NOCUT(NDIM,XLOW,XUP,WORK(1),DISCNT,DISCRM,DPARTN,NFUN)
137       PARTN=DPARTN
138       GOTO 240
139  180  LMAX=.TRUE.
140       IF(FMAJOR.GE.FMINOR) GOTO 190
141       LMAX=.FALSE.
142  190  VOL=CELVOL
143       DREGTL=REGNTL
144       DFNLTL=FNLTOL
145       CALL DELSLV(NDIM,FMAJOR,FMINOR,LMAX,DFRACT,Z,XLOW,XUP,VOL,NCUT,NCD
146      1IM,ICUT,DELPLS,DELNEG,DREGTL,DFNLTL,WORK(1),WORK(NCDIM+1),WORK(2*N
147      2CDIM+1),WORK(3*NCDIM+1),WORK(4*NCDIM+1),WORK(5*NCDIM+1),WORK(6*NCD
148      3IM+1),WORK(7*NCDIM+1),WORK(8*NCDIM+1),NFCNT)
149       NFUN=NFUN+NFCNT
150       NFCUT=NFCUT+NFCNT
151       IF(NCUT.NE.0) GOTO 200
152       CALL NOCUT(NDIM,XLOW,XUP,WORK(1),DISCNT,DISCRM,DPARTN,NFUN)
153       PARTN=DPARTN
154       GOTO 240
155  200  I=1
156       GOTO 220
157  210  I=I+1
158  220  IF((I).GT.(NCUT)) GOTO 240
159       DCMSVE(I)=ICUT(I)
160       II=ABS(ICUT(I))
161       IF(ICUT(I).LE.0) GOTO 230
162       PARSVE(I)=X(II,MAJOR)+DELPLS(II)
163       GOTO 210
164  230  PARSVE(I)=X(II,MAJOR)-DELNEG(II)
165       GOTO 210
166  240  NCUTSV=NCUT
167       IF(NCUT.LE.0) GOTO 250
168       DISCRM=ICUT(NCUT)
169       PARTN=PARSVE(NCUT)
170       NCUT=NCUT-1
171  250  IF(.NOT.(FSTENT)) GOTO 260
172       FSTENT=.FALSE.
173       TERMNL=FSTENT
174       RETURN
175  260  IF(ERROR.EQ.0.0E+0) GOTO 270
176       TERMNL=TERMNL.OR.ERROR.LT.ERRABS
177       IF(FBAR.NE.0.0E+0) TERMNL=TERMNL.OR.ERROR/ABS(FBAR).LE.ERRPCT
178  270  IF(.NOT.(TERMNL)) GOTO 330
179       NCUT=0
180       IF(NCUTSV.LE.0) GOTO 290
181       DEVMIN= 9.9E34
182       DO 280 I=1,NCUTSV
183       J=ABS(ICUT(I))
184       XX=ABS(X(J,MAJOR)-PARSVE(I))
185       IF(XX.GE.DEVMIN) GOTO 280
186       DEVMIN=XX
187       PARTN=PARSVE(I)
188       DISCRM=ICUT(I)
189  280  CONTINUE
190 *** JMB 290  ERRSQ=ERROR**2
191  290  IF (ABS(ERROR).GT.1.E-16) THEN
192         ERRSQ=ERROR**2
193       ELSE
194         ERRSQ=0.0
195       ENDIF
196       ERRABS=MAX(ERRABS,ERROR)
197       BUCKTS(1)=FBAR
198       BUCKTS(2)=ERRSQ
199       BUCKTS(3)=DISCRM
200       BUCKTS(4)=PARTN
201       IF(DEGREE.NE.1) GOTO 300
202       BUCKTS(5)=Y(NPOINT+1)
203       BUCKTS(6)=Y(NPOINT+2)
204       BUCKTS(7)=CELVOL
205  300  IF(DEGREE.LT.2) GOTO 310
206       NFUN=NFUN+NDIM+1
207       BUCKTS(5)=QUAD(NDIM,2,UMINUS,UPLUS,FUN)*CELVOL
208  310  IF(DEGREE.LT.3) GOTO 320
209       NFUN=NFUN+NDIM+NDIM
210       BUCKTS(6)=QUAD(NDIM,3,UMINUS,UPLUS,FUN)*CELVOL
211  320  IF(DEGREE.NE.5) GOTO 330
212       NFUN=NFUN+2*NDIM**2+1
213       BUCKTS(7)=QUAD(NDIM,5,UMINUS,UPLUS,FUN)*CELVOL
214  330  RETURN
215       END