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