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