[u/mrichter/AliRoot.git] / MINICERN / mathlib / gen / divon / split.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1996/04/01 15:03:24  mclareni
* Mathlib gen
*
*
#include "gen/pilot.h"
      SUBROUTINE SPLIT (NDIM,UMINUS,UPLUS,FLOBD,FUPBD,TERMNL,DISCRM,PART
     1N,BUCKTS,IRBUC)
      INTEGER NDIM, DISCRM, IRBUC
      LOGICAL TERMNL
      REAL FLOBD, FUPBD, PARTN
      REAL UMINUS(NDIM), UPLUS(NDIM), BUCKTS(IRBUC)
      INTEGER MPOINT
      COMMON /SAMPLE/ MPOINT
      INTEGER MAXWRD
      COMMON /BUKSZE/ MAXWRD
      REAL ERRPCT, ERRABS
      COMMON /MAXERR/ ERRPCT, ERRABS
      INTEGER NFUN, NFOPT, NFCUT
      COMMON /FUNN/ NFUN, NFOPT, NFCUT
      LOGICAL FSTENT, DOSPLT
      REAL COORD, PLACE
      COMMON /SIGSPL/ COORD, PLACE, FSTENT, DOSPLT
      INTEGER DEGREE
      COMMON /QUADRE/ DEGREE
      INTEGER MXRGNS, ISTOR
      COMMON /ISTRGE/ MXRGNS, ISTOR(12000)
      INTEGER RSTSZE
      REAL RSTOR
      COMMON /RSTRGE/ RSTSZE,RSTOR(18001)
      REAL BNDTOL, FRACT, REGNTL, FNLTOL
      COMMON /CUTOLS/ BNDTOL, FRACT, REGNTL, FNLTOL
      INTEGER MAJOR, MINOR
      INTEGER ICUT(20), IWORK(20)
      INTEGER DCMSVE(20)
      INTEGER MAXJ, MINJ, NPOINT, NFCNT
      INTEGER DISCNT
      INTEGER NCUT
      EXTERNAL FUN
      LOGICAL LMAX
      REAL DIFEXT
      REAL X(10, 202), Y(202)
      REAL PARSVE(20)
C*NS  REAL DEVMAX, DEVMIN, YMAX, YMIN, SUM, CELVOL, YBAR, ERROR, ERRSQ
C*NS  DOUBLE PRECISION DPARTN, DFLOAT, DBNDTL, DFRACT, DREGTL, DFNLTL
      REAL         DEVMIN, YMAX, YMIN,      CELVOL, YBAR, ERROR, ERRSQ
      DOUBLE PRECISION DPARTN,         DBNDTL, DFRACT, DREGTL, DFNLTL
      DOUBLE PRECISION FMAJOR, FMINOR, VOL
      DOUBLE PRECISION DELPLS(10), DELNEG(10)
      DOUBLE PRECISION XLOW(10), XUP(10)
      DOUBLE PRECISION Z(10), WORK(200)
      DATA DISCNT /0/
      DATA NCUT /0/
      IF(.NOT.(DOSPLT)) GOTO 10
      DOSPLT=.FALSE.
      FSTENT=DOSPLT
      DISCRM=COORD
      PARTN=PLACE
      RETURN
 10   IF(NCUT.EQ.0) GOTO 20
      DISCRM=DCMSVE(NCUT)
      PARTN=PARSVE(NCUT)
      NCUT=NCUT-1
      DOSPLT=.FALSE.
      FSTENT=DOSPLT
      TERMNL=FSTENT
      RETURN
 20   ISCR=MXRGNS*(MAXWRD+1)+1
      NPOINT=MPOINT
      CALL QUASI(X,NDIM,NPOINT,MPOINT)
      DO 40 J=1,NPOINT
      DO 30 I=1,NDIM
      X(I,J)=(UPLUS(I)-UMINUS(I))*X(I,J)+UMINUS(I)
 30   CONTINUE
      Y(J)=FUN(NDIM,X(1,J))
 40   CONTINUE
      NFUN=NFUN+NPOINT
      CELVOL=1.0E+0
      DO 50 I=1,NDIM
      CELVOL=CELVOL*(UPLUS(I)-UMINUS(I))
 50   CONTINUE
#if defined(CERNLIB_IBM)||defined(CERNLIB_SINGLE)
      YMAX=-9.9E+60
      YMIN=9.9E+60
#endif
#if (!defined(CERNLIB_IBM))&&(defined(CERNLIB_DOUBLE))
      YMAX= -9.9E34
      YMIN=  9.9E34
#endif
      DO 70 J=1,NPOINT
      IF(Y(J).GE.YMIN) GOTO 60
      YMIN=Y(J)
      MINJ=J
 60   IF(Y(J).LE.YMAX) GOTO 70
      YMAX=Y(J)
      MAXJ=J
 70   CONTINUE
      DO 80 I=1,NDIM
      X(I,NPOINT+1)=X(I,MAXJ)
      X(I,NPOINT+2)=X(I,MINJ)
 80   CONTINUE
      Y(NPOINT+1)=YMAX
      Y(NPOINT+2)=YMIN
      CALL BUFOPT(NDIM,X(1,NPOINT+2),X(1,NPOINT+1),UMINUS,UPLUS,Y(NPOIN
     1T+2),Y(NPOINT+1),FLOBD,FUPBD,WORK,200,IWORK,20,NFCNT,IRESLT)
      NFUN=NFUN+NFCNT
      NFOPT=NFOPT+NFCNT
      DIFEXT=Y(NPOINT+1)-Y(NPOINT+2)
      ERROR=DIFEXT*CELVOL*0.5E+0
      YBAR=0.0E+0
      DO 90 I=1,NPOINT
      YBAR=YBAR+Y(I)
 90   CONTINUE
      YBAR=YBAR/NPOINT
      FBAR=YBAR*CELVOL
      IF(ABS(Y(NPOINT+2)-YBAR).LE.ABS(Y(NPOINT+1)-YBAR)) GOTO 100
      MAJOR=NPOINT+2
      MINOR=NPOINT+1
      GOTO 110
 100  MAJOR=NPOINT+1
      MINOR=NPOINT+2
 110  FMAJOR=Y(MAJOR)
      FMINOR=Y(MINOR)
      I=1
      GOTO 130
 120  I=I+1
 130  IF((I).GT.(NDIM)) GOTO 140
      Z(I)=X(I,MAJOR)
      GOTO 120
 140  I=1
      GOTO 160
 150  I=I+1
 160  IF((I).GT.(NDIM)) GOTO 170
      XLOW(I)=UMINUS(I)
      XUP(I)=UPLUS(I)
      GOTO 150
 170  NCDIM=2*NDIM
      DFRACT=FRACT
      DBNDTL=BNDTOL
      CALL TSTEXT(NDIM,Z,XLOW,XUP,DBNDTL,DFRACT,NCUT,NCDIM,ICUT,DELPLS,
     1DELNEG)
      IF(NCUT.NE.0) GOTO 180
      CALL NOCUT(NDIM,XLOW,XUP,WORK(1),DISCNT,DISCRM,DPARTN,NFUN)
      PARTN=DPARTN
      GOTO 240
 180  LMAX=.TRUE.
      IF(FMAJOR.GE.FMINOR) GOTO 190
      LMAX=.FALSE.
 190  VOL=CELVOL
      DREGTL=REGNTL
      DFNLTL=FNLTOL
      CALL DELSLV(NDIM,FMAJOR,FMINOR,LMAX,DFRACT,Z,XLOW,XUP,VOL,NCUT,NCD
     1IM,ICUT,DELPLS,DELNEG,DREGTL,DFNLTL,WORK(1),WORK(NCDIM+1),WORK(2*N
     2CDIM+1),WORK(3*NCDIM+1),WORK(4*NCDIM+1),WORK(5*NCDIM+1),WORK(6*NCD
     3IM+1),WORK(7*NCDIM+1),WORK(8*NCDIM+1),NFCNT)
      NFUN=NFUN+NFCNT
      NFCUT=NFCUT+NFCNT
      IF(NCUT.NE.0) GOTO 200
      CALL NOCUT(NDIM,XLOW,XUP,WORK(1),DISCNT,DISCRM,DPARTN,NFUN)
      PARTN=DPARTN
      GOTO 240
 200  I=1
      GOTO 220
 210  I=I+1
 220  IF((I).GT.(NCUT)) GOTO 240
      DCMSVE(I)=ICUT(I)
      II=ABS(ICUT(I))
      IF(ICUT(I).LE.0) GOTO 230
      PARSVE(I)=X(II,MAJOR)+DELPLS(II)
      GOTO 210
 230  PARSVE(I)=X(II,MAJOR)-DELNEG(II)
      GOTO 210
 240  NCUTSV=NCUT
      IF(NCUT.LE.0) GOTO 250
      DISCRM=ICUT(NCUT)
      PARTN=PARSVE(NCUT)
      NCUT=NCUT-1
 250  IF(.NOT.(FSTENT)) GOTO 260
      FSTENT=.FALSE.
      TERMNL=FSTENT
      RETURN
 260  IF(ERROR.EQ.0.0E+0) GOTO 270
      TERMNL=TERMNL.OR.ERROR.LT.ERRABS
      IF(FBAR.NE.0.0E+0) TERMNL=TERMNL.OR.ERROR/ABS(FBAR).LE.ERRPCT
 270  IF(.NOT.(TERMNL)) GOTO 330
      NCUT=0
      IF(NCUTSV.LE.0) GOTO 290
#if defined(CERNLIB_IBM)||defined(CERNLIB_SINGLE)
      DEVMIN=9.9E60
#endif
#if (!defined(CERNLIB_IBM))&&(defined(CERNLIB_DOUBLE))
      DEVMIN= 9.9E34
#endif
      DO 280 I=1,NCUTSV
      J=ABS(ICUT(I))
      XX=ABS(X(J,MAJOR)-PARSVE(I))
      IF(XX.GE.DEVMIN) GOTO 280
      DEVMIN=XX
      PARTN=PARSVE(I)
      DISCRM=ICUT(I)
 280  CONTINUE
 290  ERRSQ=ERROR**2
      ERRABS=MAX(ERRABS,ERROR)
      BUCKTS(1)=FBAR
      BUCKTS(2)=ERRSQ
      BUCKTS(3)=DISCRM
      BUCKTS(4)=PARTN
      IF(DEGREE.NE.1) GOTO 300
      BUCKTS(5)=Y(NPOINT+1)
      BUCKTS(6)=Y(NPOINT+2)
      BUCKTS(7)=CELVOL
 300  IF(DEGREE.LT.2) GOTO 310
      NFUN=NFUN+NDIM+1
      BUCKTS(5)=QUAD(NDIM,2,UMINUS,UPLUS,FUN)*CELVOL
 310  IF(DEGREE.LT.3) GOTO 320
      NFUN=NFUN+NDIM+NDIM
      BUCKTS(6)=QUAD(NDIM,3,UMINUS,UPLUS,FUN)*CELVOL
 320  IF(DEGREE.NE.5) GOTO 330
      NFUN=NFUN+2*NDIM**2+1
      BUCKTS(7)=QUAD(NDIM,5,UMINUS,UPLUS,FUN)*CELVOL
 330  RETURN
      END
Commit	Line	Data
fe4da5cc	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=DIFEXTCELVOL0.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(3NCDIM+1),WORK(4NCDIM+1),WORK(5NCDIM+1),WORK(6NCD
158	3IM+1),WORK(7NCDIM+1),WORK(8NCDIM+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+2NDIM*2+1
223	BUCKTS(7)=QUAD(NDIM,5,UMINUS,UPLUS,FUN)*CELVOL
224	330 RETURN
225	END